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 Acquire_Warning_Match_String (Arg : Node_Id);
3772 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3773 -- get the given string argument, and place it in Name_Buffer, adding
3774 -- leading and trailing asterisks if they are not already present. The
3775 -- caller has already checked that Arg is a static string expression.
3777 procedure Ada_2005_Pragma;
3778 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3779 -- Ada 95 mode, these are implementation defined pragmas, so should be
3780 -- caught by the No_Implementation_Pragmas restriction.
3782 procedure Ada_2012_Pragma;
3783 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3784 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3785 -- should be caught by the No_Implementation_Pragmas restriction.
3787 procedure Analyze_Depends_Global
3788 (Spec_Id : out Entity_Id;
3789 Subp_Decl : out Node_Id;
3790 Legal : out Boolean);
3791 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3792 -- legality of the placement and related context of the pragma. Spec_Id
3793 -- is the entity of the related subprogram. Subp_Decl is the declaration
3794 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3796 procedure Analyze_If_Present (Id : Pragma_Id);
3797 -- Inspect the remainder of the list containing pragma N and look for
3798 -- a pragma that matches Id. If found, analyze the pragma.
3800 procedure Analyze_Pre_Post_Condition;
3801 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3803 procedure Analyze_Refined_Depends_Global_Post
3804 (Spec_Id : out Entity_Id;
3805 Body_Id : out Entity_Id;
3806 Legal : out Boolean);
3807 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3808 -- Refined_Global and Refined_Post. Verify the legality of the placement
3809 -- and related context of the pragma. Spec_Id is the entity of the
3810 -- related subprogram. Body_Id is the entity of the subprogram body.
3811 -- Flag Legal is set when the pragma is legal.
3813 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3814 -- Perform full analysis of pragma Unmodified and the write aspect of
3815 -- pragma Unused. Flag Is_Unused should be set when verifying the
3816 -- semantics of pragma Unused.
3818 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3819 -- Perform full analysis of pragma Unreferenced and the read aspect of
3820 -- pragma Unused. Flag Is_Unused should be set when verifying the
3821 -- semantics of pragma Unused.
3823 procedure Check_Ada_83_Warning;
3824 -- Issues a warning message for the current pragma if operating in Ada
3825 -- 83 mode (used for language pragmas that are not a standard part of
3826 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3829 procedure Check_Arg_Count (Required : Nat);
3830 -- Check argument count for pragma is equal to given parameter. If not,
3831 -- then issue an error message and raise Pragma_Exit.
3833 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3834 -- Arg which can either be a pragma argument association, in which case
3835 -- the check is applied to the expression of the association or an
3836 -- expression directly.
3838 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3839 -- Check that an argument has the right form for an EXTERNAL_NAME
3840 -- parameter of an extended import/export pragma. The rule is that the
3841 -- name must be an identifier or string literal (in Ada 83 mode) or a
3842 -- static string expression (in Ada 95 mode).
3844 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3845 -- Check the specified argument Arg to make sure that it is an
3846 -- identifier. If not give error and raise Pragma_Exit.
3848 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3849 -- Check the specified argument Arg to make sure that it is an integer
3850 -- literal. If not give error and raise Pragma_Exit.
3852 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3853 -- Check the specified argument Arg to make sure that it has the proper
3854 -- syntactic form for a local name and meets the semantic requirements
3855 -- for a local name. The local name is analyzed as part of the
3856 -- processing for this call. In addition, the local name is required
3857 -- to represent an entity at the library level.
3859 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3860 -- Check the specified argument Arg to make sure that it has the proper
3861 -- syntactic form for a local name and meets the semantic requirements
3862 -- for a local name. The local name is analyzed as part of the
3863 -- processing for this call.
3865 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3866 -- Check the specified argument Arg to make sure that it is a valid
3867 -- locking policy name. If not give error and raise Pragma_Exit.
3869 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3870 -- Check the specified argument Arg to make sure that it is a valid
3871 -- elaboration policy name. If not give error and raise Pragma_Exit.
3873 procedure Check_Arg_Is_One_Of
3876 procedure Check_Arg_Is_One_Of
3878 N1, N2, N3 : Name_Id);
3879 procedure Check_Arg_Is_One_Of
3881 N1, N2, N3, N4 : Name_Id);
3882 procedure Check_Arg_Is_One_Of
3884 N1, N2, N3, N4, N5 : Name_Id);
3885 -- Check the specified argument Arg to make sure that it is an
3886 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3887 -- present). If not then give error and raise Pragma_Exit.
3889 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3890 -- Check the specified argument Arg to make sure that it is a valid
3891 -- queuing policy name. If not give error and raise Pragma_Exit.
3893 procedure Check_Arg_Is_OK_Static_Expression
3895 Typ : Entity_Id := Empty);
3896 -- Check the specified argument Arg to make sure that it is a static
3897 -- expression of the given type (i.e. it will be analyzed and resolved
3898 -- using this type, which can be any valid argument to Resolve, e.g.
3899 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3900 -- Typ is left Empty, then any static expression is allowed. Includes
3901 -- checking that the argument does not raise Constraint_Error.
3903 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3904 -- Check the specified argument Arg to make sure that it is a valid task
3905 -- dispatching policy name. If not give error and raise Pragma_Exit.
3907 procedure Check_Arg_Order (Names : Name_List);
3908 -- Checks for an instance of two arguments with identifiers for the
3909 -- current pragma which are not in the sequence indicated by Names,
3910 -- and if so, generates a fatal message about bad order of arguments.
3912 procedure Check_At_Least_N_Arguments (N : Nat);
3913 -- Check there are at least N arguments present
3915 procedure Check_At_Most_N_Arguments (N : Nat);
3916 -- Check there are no more than N arguments present
3918 procedure Check_Component
3921 In_Variant_Part : Boolean := False);
3922 -- Examine an Unchecked_Union component for correct use of per-object
3923 -- constrained subtypes, and for restrictions on finalizable components.
3924 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3925 -- should be set when Comp comes from a record variant.
3927 procedure Check_Duplicate_Pragma (E : Entity_Id);
3928 -- Check if a rep item of the same name as the current pragma is already
3929 -- chained as a rep pragma to the given entity. If so give a message
3930 -- about the duplicate, and then raise Pragma_Exit so does not return.
3931 -- Note that if E is a type, then this routine avoids flagging a pragma
3932 -- which applies to a parent type from which E is derived.
3934 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3935 -- Nam is an N_String_Literal node containing the external name set by
3936 -- an Import or Export pragma (or extended Import or Export pragma).
3937 -- This procedure checks for possible duplications if this is the export
3938 -- case, and if found, issues an appropriate error message.
3940 procedure Check_Expr_Is_OK_Static_Expression
3942 Typ : Entity_Id := Empty);
3943 -- Check the specified expression Expr to make sure that it is a static
3944 -- expression of the given type (i.e. it will be analyzed and resolved
3945 -- using this type, which can be any valid argument to Resolve, e.g.
3946 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3947 -- Typ is left Empty, then any static expression is allowed. Includes
3948 -- checking that the expression does not raise Constraint_Error.
3950 procedure Check_First_Subtype (Arg : Node_Id);
3951 -- Checks that Arg, whose expression is an entity name, references a
3954 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3955 -- Checks that the given argument has an identifier, and if so, requires
3956 -- it to match the given identifier name. If there is no identifier, or
3957 -- a non-matching identifier, then an error message is given and
3958 -- Pragma_Exit is raised.
3960 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3961 -- Checks that the given argument has an identifier, and if so, requires
3962 -- it to match one of the given identifier names. If there is no
3963 -- identifier, or a non-matching identifier, then an error message is
3964 -- given and Pragma_Exit is raised.
3966 procedure Check_In_Main_Program;
3967 -- Common checks for pragmas that appear within a main program
3968 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3970 procedure Check_Interrupt_Or_Attach_Handler;
3971 -- Common processing for first argument of pragma Interrupt_Handler or
3972 -- pragma Attach_Handler.
3974 procedure Check_Loop_Pragma_Placement;
3975 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3976 -- appear immediately within a construct restricted to loops, and that
3977 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3979 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3980 -- Check that pragma appears in a declarative part, or in a package
3981 -- specification, i.e. that it does not occur in a statement sequence
3984 procedure Check_No_Identifier (Arg : Node_Id);
3985 -- Checks that the given argument does not have an identifier. If
3986 -- an identifier is present, then an error message is issued, and
3987 -- Pragma_Exit is raised.
3989 procedure Check_No_Identifiers;
3990 -- Checks that none of the arguments to the pragma has an identifier.
3991 -- If any argument has an identifier, then an error message is issued,
3992 -- and Pragma_Exit is raised.
3994 procedure Check_No_Link_Name;
3995 -- Checks that no link name is specified
3997 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3998 -- Checks if the given argument has an identifier, and if so, requires
3999 -- it to match the given identifier name. If there is a non-matching
4000 -- identifier, then an error message is given and Pragma_Exit is raised.
4002 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4003 -- Checks if the given argument has an identifier, and if so, requires
4004 -- it to match the given identifier name. If there is a non-matching
4005 -- identifier, then an error message is given and Pragma_Exit is raised.
4006 -- In this version of the procedure, the identifier name is given as
4007 -- a string with lower case letters.
4009 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4010 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4011 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4012 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4013 -- is an OK static boolean expression. Emit an error if this is not the
4016 procedure Check_Static_Constraint (Constr : Node_Id);
4017 -- Constr is a constraint from an N_Subtype_Indication node from a
4018 -- component constraint in an Unchecked_Union type. This routine checks
4019 -- that the constraint is static as required by the restrictions for
4022 procedure Check_Valid_Configuration_Pragma;
4023 -- Legality checks for placement of a configuration pragma
4025 procedure Check_Valid_Library_Unit_Pragma;
4026 -- Legality checks for library unit pragmas. A special case arises for
4027 -- pragmas in generic instances that come from copies of the original
4028 -- library unit pragmas in the generic templates. In the case of other
4029 -- than library level instantiations these can appear in contexts which
4030 -- would normally be invalid (they only apply to the original template
4031 -- and to library level instantiations), and they are simply ignored,
4032 -- which is implemented by rewriting them as null statements.
4034 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4035 -- Check an Unchecked_Union variant for lack of nested variants and
4036 -- presence of at least one component. UU_Typ is the related Unchecked_
4039 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4040 -- Subsidiary routine to the processing of pragmas Abstract_State,
4041 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4042 -- Refined_Global and Refined_State. Transform argument Arg into
4043 -- an aggregate if not one already. N_Null is never transformed.
4044 -- Arg may denote an aspect specification or a pragma argument
4047 procedure Error_Pragma (Msg : String);
4048 pragma No_Return (Error_Pragma);
4049 -- Outputs error message for current pragma. The message contains a %
4050 -- that will be replaced with the pragma name, and the flag is placed
4051 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4052 -- calls Fix_Error (see spec of that procedure for details).
4054 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4055 pragma No_Return (Error_Pragma_Arg);
4056 -- Outputs error message for current pragma. The message may contain
4057 -- a % that will be replaced with the pragma name. The parameter Arg
4058 -- may either be a pragma argument association, in which case the flag
4059 -- is placed on the expression of this association, or an expression,
4060 -- in which case the flag is placed directly on the expression. The
4061 -- message is placed using Error_Msg_N, so the message may also contain
4062 -- an & insertion character which will reference the given Arg value.
4063 -- After placing the message, Pragma_Exit is raised. Note: this routine
4064 -- calls Fix_Error (see spec of that procedure for details).
4066 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4067 pragma No_Return (Error_Pragma_Arg);
4068 -- Similar to above form of Error_Pragma_Arg except that two messages
4069 -- are provided, the second is a continuation comment starting with \.
4071 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4072 pragma No_Return (Error_Pragma_Arg_Ident);
4073 -- Outputs error message for current pragma. The message may contain a %
4074 -- that will be replaced with the pragma name. The parameter Arg must be
4075 -- a pragma argument association with a non-empty identifier (i.e. its
4076 -- Chars field must be set), and the error message is placed on the
4077 -- identifier. The message is placed using Error_Msg_N so the message
4078 -- may also contain an & insertion character which will reference
4079 -- the identifier. After placing the message, Pragma_Exit is raised.
4080 -- Note: this routine calls Fix_Error (see spec of that procedure for
4083 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4084 pragma No_Return (Error_Pragma_Ref);
4085 -- Outputs error message for current pragma. The message may contain
4086 -- a % that will be replaced with the pragma name. The parameter Ref
4087 -- must be an entity whose name can be referenced by & and sloc by #.
4088 -- After placing the message, Pragma_Exit is raised. Note: this routine
4089 -- calls Fix_Error (see spec of that procedure for details).
4091 function Find_Lib_Unit_Name return Entity_Id;
4092 -- Used for a library unit pragma to find the entity to which the
4093 -- library unit pragma applies, returns the entity found.
4095 procedure Find_Program_Unit_Name (Id : Node_Id);
4096 -- If the pragma is a compilation unit pragma, the id must denote the
4097 -- compilation unit in the same compilation, and the pragma must appear
4098 -- in the list of preceding or trailing pragmas. If it is a program
4099 -- unit pragma that is not a compilation unit pragma, then the
4100 -- identifier must be visible.
4102 function Find_Unique_Parameterless_Procedure
4104 Arg : Node_Id) return Entity_Id;
4105 -- Used for a procedure pragma to find the unique parameterless
4106 -- procedure identified by Name, returns it if it exists, otherwise
4107 -- errors out and uses Arg as the pragma argument for the message.
4109 function Fix_Error (Msg : String) return String;
4110 -- This is called prior to issuing an error message. Msg is the normal
4111 -- error message issued in the pragma case. This routine checks for the
4112 -- case of a pragma coming from an aspect in the source, and returns a
4113 -- message suitable for the aspect case as follows:
4115 -- Each substring "pragma" is replaced by "aspect"
4117 -- If "argument of" is at the start of the error message text, it is
4118 -- replaced by "entity for".
4120 -- If "argument" is at the start of the error message text, it is
4121 -- replaced by "entity".
4123 -- So for example, "argument of pragma X must be discrete type"
4124 -- returns "entity for aspect X must be a discrete type".
4126 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4127 -- be different from the pragma name). If the current pragma results
4128 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4129 -- original pragma name.
4131 procedure Gather_Associations
4133 Args : out Args_List);
4134 -- This procedure is used to gather the arguments for a pragma that
4135 -- permits arbitrary ordering of parameters using the normal rules
4136 -- for named and positional parameters. The Names argument is a list
4137 -- of Name_Id values that corresponds to the allowed pragma argument
4138 -- association identifiers in order. The result returned in Args is
4139 -- a list of corresponding expressions that are the pragma arguments.
4140 -- Note that this is a list of expressions, not of pragma argument
4141 -- associations (Gather_Associations has completely checked all the
4142 -- optional identifiers when it returns). An entry in Args is Empty
4143 -- on return if the corresponding argument is not present.
4145 procedure GNAT_Pragma;
4146 -- Called for all GNAT defined pragmas to check the relevant restriction
4147 -- (No_Implementation_Pragmas).
4149 function Is_Before_First_Decl
4150 (Pragma_Node : Node_Id;
4151 Decls : List_Id) return Boolean;
4152 -- Return True if Pragma_Node is before the first declarative item in
4153 -- Decls where Decls is the list of declarative items.
4155 function Is_Configuration_Pragma return Boolean;
4156 -- Determines if the placement of the current pragma is appropriate
4157 -- for a configuration pragma.
4159 function Is_In_Context_Clause return Boolean;
4160 -- Returns True if pragma appears within the context clause of a unit,
4161 -- and False for any other placement (does not generate any messages).
4163 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4164 -- Analyzes the argument, and determines if it is a static string
4165 -- expression, returns True if so, False if non-static or not String.
4166 -- A special case is that a string literal returns True in Ada 83 mode
4167 -- (which has no such thing as static string expressions). Note that
4168 -- the call analyzes its argument, so this cannot be used for the case
4169 -- where an identifier might not be declared.
4171 procedure Pragma_Misplaced;
4172 pragma No_Return (Pragma_Misplaced);
4173 -- Issue fatal error message for misplaced pragma
4175 procedure Process_Atomic_Independent_Shared_Volatile;
4176 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4177 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4178 -- and treated as being identical in effect to pragma Atomic.
4180 procedure Process_Compile_Time_Warning_Or_Error;
4181 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4183 procedure Process_Convention
4184 (C : out Convention_Id;
4185 Ent : out Entity_Id);
4186 -- Common processing for Convention, Interface, Import and Export.
4187 -- Checks first two arguments of pragma, and sets the appropriate
4188 -- convention value in the specified entity or entities. On return
4189 -- C is the convention, Ent is the referenced entity.
4191 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4192 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4193 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4195 procedure Process_Extended_Import_Export_Object_Pragma
4196 (Arg_Internal : Node_Id;
4197 Arg_External : Node_Id;
4198 Arg_Size : Node_Id);
4199 -- Common processing for the pragmas Import/Export_Object. The three
4200 -- arguments correspond to the three named parameters of the pragmas. An
4201 -- argument is empty if the corresponding parameter is not present in
4204 procedure Process_Extended_Import_Export_Internal_Arg
4205 (Arg_Internal : Node_Id := Empty);
4206 -- Common processing for all extended Import and Export pragmas. The
4207 -- argument is the pragma parameter for the Internal argument. If
4208 -- Arg_Internal is empty or inappropriate, an error message is posted.
4209 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4210 -- set to identify the referenced entity.
4212 procedure Process_Extended_Import_Export_Subprogram_Pragma
4213 (Arg_Internal : Node_Id;
4214 Arg_External : Node_Id;
4215 Arg_Parameter_Types : Node_Id;
4216 Arg_Result_Type : Node_Id := Empty;
4217 Arg_Mechanism : Node_Id;
4218 Arg_Result_Mechanism : Node_Id := Empty);
4219 -- Common processing for all extended Import and Export pragmas applying
4220 -- to subprograms. The caller omits any arguments that do not apply to
4221 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4222 -- only in the Import_Function and Export_Function cases). The argument
4223 -- names correspond to the allowed pragma association identifiers.
4225 procedure Process_Generic_List;
4226 -- Common processing for Share_Generic and Inline_Generic
4228 procedure Process_Import_Or_Interface;
4229 -- Common processing for Import or Interface
4231 procedure Process_Import_Predefined_Type;
4232 -- Processing for completing a type with pragma Import. This is used
4233 -- to declare types that match predefined C types, especially for cases
4234 -- without corresponding Ada predefined type.
4236 type Inline_Status is (Suppressed, Disabled, Enabled);
4237 -- Inline status of a subprogram, indicated as follows:
4238 -- Suppressed: inlining is suppressed for the subprogram
4239 -- Disabled: no inlining is requested for the subprogram
4240 -- Enabled: inlining is requested/required for the subprogram
4242 procedure Process_Inline (Status : Inline_Status);
4243 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4244 -- indicates the inline status specified by the pragma.
4246 procedure Process_Interface_Name
4247 (Subprogram_Def : Entity_Id;
4251 -- Given the last two arguments of pragma Import, pragma Export, or
4252 -- pragma Interface_Name, performs validity checks and sets the
4253 -- Interface_Name field of the given subprogram entity to the
4254 -- appropriate external or link name, depending on the arguments given.
4255 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4256 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4257 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4258 -- nor Link_Arg is present, the interface name is set to the default
4259 -- from the subprogram name. In addition, the pragma itself is passed
4260 -- to analyze any expressions in the case the pragma came from an aspect
4263 procedure Process_Interrupt_Or_Attach_Handler;
4264 -- Common processing for Interrupt and Attach_Handler pragmas
4266 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4267 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4268 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4269 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4270 -- is not set in the Restrictions case.
4272 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4273 -- Common processing for Suppress and Unsuppress. The boolean parameter
4274 -- Suppress_Case is True for the Suppress case, and False for the
4277 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4278 -- Subsidiary to the analysis of pragmas Independent[_Components].
4279 -- Record such a pragma N applied to entity E for future checks.
4281 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4282 -- This procedure sets the Is_Exported flag for the given entity,
4283 -- checking that the entity was not previously imported. Arg is
4284 -- the argument that specified the entity. A check is also made
4285 -- for exporting inappropriate entities.
4287 procedure Set_Extended_Import_Export_External_Name
4288 (Internal_Ent : Entity_Id;
4289 Arg_External : Node_Id);
4290 -- Common processing for all extended import export pragmas. The first
4291 -- argument, Internal_Ent, is the internal entity, which has already
4292 -- been checked for validity by the caller. Arg_External is from the
4293 -- Import or Export pragma, and may be null if no External parameter
4294 -- was present. If Arg_External is present and is a non-null string
4295 -- (a null string is treated as the default), then the Interface_Name
4296 -- field of Internal_Ent is set appropriately.
4298 procedure Set_Imported (E : Entity_Id);
4299 -- This procedure sets the Is_Imported flag for the given entity,
4300 -- checking that it is not previously exported or imported.
4302 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4303 -- Mech is a parameter passing mechanism (see Import_Function syntax
4304 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4305 -- has the right form, and if not issues an error message. If the
4306 -- argument has the right form then the Mechanism field of Ent is
4307 -- set appropriately.
4309 procedure Set_Rational_Profile;
4310 -- Activate the set of configuration pragmas and permissions that make
4311 -- up the Rational profile.
4313 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4314 -- Activate the set of configuration pragmas and restrictions that make
4315 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4316 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4317 -- which is used for error messages on any constructs violating the
4320 procedure Validate_Acc_Condition_Clause (Clause : Node_Id);
4321 -- Make sure the argument of a given Acc_If clause is a Boolean
4323 procedure Validate_Acc_Data_Clause (Clause : Node_Id);
4324 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4325 -- Copyout...) is an identifier or an aggregate of identifiers.
4327 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id);
4328 -- Make sure the argument of an OpenAcc clause is an Integer expression
4330 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id);
4331 -- Make sure the argument of an OpenAcc clause is an Integer expression
4332 -- or a list of Integer expressions.
4334 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id);
4335 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4336 -- contains at least N-1 nested loops.
4338 procedure Validate_Acc_Loop_Gang (Clause : Node_Id);
4339 -- Make sure the argument of the Gang clause of a Loop directive is
4340 -- either an integer expression or a (Static => integer expressions)
4343 procedure Validate_Acc_Loop_Vector (Clause : Node_Id);
4344 -- When this procedure is called in a construct offloaded by an
4345 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4346 -- not exist on said pragma. In all cases, make sure the argument
4347 -- is an Integer expression.
4349 procedure Validate_Acc_Loop_Worker (Clause : Node_Id);
4350 -- When this procedure is called in a construct offloaded by an
4351 -- Acc_Parallel pragma, makes sure that no argument has been given.
4352 -- When this procedure is called in a construct offloaded by an
4353 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4354 -- makes sure that the Num_Workers clause does not appear on the
4355 -- Acc_Kernels pragma and that the argument is an integer.
4357 procedure Validate_Acc_Name_Reduction (Clause : Node_Id);
4358 -- Make sure the reduction clause is an aggregate made of a string
4359 -- representing a supported reduction operation (i.e. "+", "*", "and",
4360 -- "or", "min" or "max") and either an identifier or aggregate of
4363 procedure Validate_Acc_Size_Expressions (Clause : Node_Id);
4364 -- Makes sure that Clause is either an integer expression or an
4365 -- association with a Static as name and a list of integer expressions
4366 -- or "*" strings on the right hand side.
4372 function Acc_First (N : Node_Id) return Node_Id is
4374 if Nkind (N) = N_Aggregate then
4375 if Present (Expressions (N)) then
4376 return First (Expressions (N));
4378 elsif Present (Component_Associations (N)) then
4379 return Expression (First (Component_Associations (N)));
4390 function Acc_Next (N : Node_Id) return Node_Id is
4392 if Nkind (Parent (N)) = N_Component_Association then
4393 return Expression (Next (Parent (N)));
4395 elsif Nkind (Parent (N)) = N_Aggregate then
4403 ----------------------------------
4404 -- Acquire_Warning_Match_String --
4405 ----------------------------------
4407 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4409 String_To_Name_Buffer
4410 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4412 -- Add asterisk at start if not already there
4414 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4415 Name_Buffer (2 .. Name_Len + 1) :=
4416 Name_Buffer (1 .. Name_Len);
4417 Name_Buffer (1) := '*';
4418 Name_Len := Name_Len + 1;
4421 -- Add asterisk at end if not already there
4423 if Name_Buffer (Name_Len) /= '*' then
4424 Name_Len := Name_Len + 1;
4425 Name_Buffer (Name_Len) := '*';
4427 end Acquire_Warning_Match_String;
4429 ---------------------
4430 -- Ada_2005_Pragma --
4431 ---------------------
4433 procedure Ada_2005_Pragma is
4435 if Ada_Version <= Ada_95 then
4436 Check_Restriction (No_Implementation_Pragmas, N);
4438 end Ada_2005_Pragma;
4440 ---------------------
4441 -- Ada_2012_Pragma --
4442 ---------------------
4444 procedure Ada_2012_Pragma is
4446 if Ada_Version <= Ada_2005 then
4447 Check_Restriction (No_Implementation_Pragmas, N);
4449 end Ada_2012_Pragma;
4451 ----------------------------
4452 -- Analyze_Depends_Global --
4453 ----------------------------
4455 procedure Analyze_Depends_Global
4456 (Spec_Id : out Entity_Id;
4457 Subp_Decl : out Node_Id;
4458 Legal : out Boolean)
4461 -- Assume that the pragma is illegal
4468 Check_Arg_Count (1);
4470 -- Ensure the proper placement of the pragma. Depends/Global must be
4471 -- associated with a subprogram declaration or a body that acts as a
4474 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4478 if Nkind (Subp_Decl) = N_Entry_Declaration then
4481 -- Generic subprogram
4483 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4486 -- Object declaration of a single concurrent type
4488 elsif Nkind (Subp_Decl) = N_Object_Declaration
4489 and then Is_Single_Concurrent_Object
4490 (Unique_Defining_Entity (Subp_Decl))
4496 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4499 -- Subprogram body acts as spec
4501 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4502 and then No (Corresponding_Spec (Subp_Decl))
4506 -- Subprogram body stub acts as spec
4508 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4509 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4513 -- Subprogram declaration
4515 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4520 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4528 -- If we get here, then the pragma is legal
4531 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4533 -- When the related context is an entry, the entry must belong to a
4534 -- protected unit (SPARK RM 6.1.4(6)).
4536 if Is_Entry_Declaration (Spec_Id)
4537 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4542 -- When the related context is an anonymous object created for a
4543 -- simple concurrent type, the type must be a task
4544 -- (SPARK RM 6.1.4(6)).
4546 elsif Is_Single_Concurrent_Object (Spec_Id)
4547 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4553 -- A pragma that applies to a Ghost entity becomes Ghost for the
4554 -- purposes of legality checks and removal of ignored Ghost code.
4556 Mark_Ghost_Pragma (N, Spec_Id);
4557 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4558 end Analyze_Depends_Global;
4560 ------------------------
4561 -- Analyze_If_Present --
4562 ------------------------
4564 procedure Analyze_If_Present (Id : Pragma_Id) is
4568 pragma Assert (Is_List_Member (N));
4570 -- Inspect the declarations or statements following pragma N looking
4571 -- for another pragma whose Id matches the caller's request. If it is
4572 -- available, analyze it.
4575 while Present (Stmt) loop
4576 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4577 Analyze_Pragma (Stmt);
4580 -- The first source declaration or statement immediately following
4581 -- N ends the region where a pragma may appear.
4583 elsif Comes_From_Source (Stmt) then
4589 end Analyze_If_Present;
4591 --------------------------------
4592 -- Analyze_Pre_Post_Condition --
4593 --------------------------------
4595 procedure Analyze_Pre_Post_Condition is
4596 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4597 Subp_Decl : Node_Id;
4598 Subp_Id : Entity_Id;
4600 Duplicates_OK : Boolean := False;
4601 -- Flag set when a pre/postcondition allows multiple pragmas of the
4604 In_Body_OK : Boolean := False;
4605 -- Flag set when a pre/postcondition is allowed to appear on a body
4606 -- even though the subprogram may have a spec.
4608 Is_Pre_Post : Boolean := False;
4609 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4612 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4613 -- Implement rules in AI12-0131: an overriding operation can have
4614 -- a class-wide precondition only if one of its ancestors has an
4615 -- explicit class-wide precondition.
4617 -----------------------------
4618 -- Inherits_Class_Wide_Pre --
4619 -----------------------------
4621 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4622 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4625 Prev : Entity_Id := Overridden_Operation (E);
4628 -- Check ancestors on the overriding operation to examine the
4629 -- preconditions that may apply to them.
4631 while Present (Prev) loop
4632 Cont := Contract (Prev);
4633 if Present (Cont) then
4634 Prag := Pre_Post_Conditions (Cont);
4635 while Present (Prag) loop
4636 if Pragma_Name (Prag) = Name_Precondition
4637 and then Class_Present (Prag)
4642 Prag := Next_Pragma (Prag);
4646 -- For a type derived from a generic formal type, the operation
4647 -- inheriting the condition is a renaming, not an overriding of
4648 -- the operation of the formal. Ditto for an inherited
4649 -- operation which has no explicit contracts.
4651 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4652 or else not Comes_From_Source (Prev)
4654 Prev := Alias (Prev);
4656 Prev := Overridden_Operation (Prev);
4660 -- If the controlling type of the subprogram has progenitors, an
4661 -- interface operation implemented by the current operation may
4662 -- have a class-wide precondition.
4664 if Has_Interfaces (Typ) then
4669 Prim_Elmt : Elmt_Id;
4670 Prim_List : Elist_Id;
4673 Collect_Interfaces (Typ, Ints);
4674 Elmt := First_Elmt (Ints);
4676 -- Iterate over the primitive operations of each interface
4678 while Present (Elmt) loop
4679 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4680 Prim_Elmt := First_Elmt (Prim_List);
4681 while Present (Prim_Elmt) loop
4682 Prim := Node (Prim_Elmt);
4683 if Chars (Prim) = Chars (E)
4684 and then Present (Contract (Prim))
4685 and then Class_Present
4686 (Pre_Post_Conditions (Contract (Prim)))
4691 Next_Elmt (Prim_Elmt);
4700 end Inherits_Class_Wide_Pre;
4702 -- Start of processing for Analyze_Pre_Post_Condition
4705 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4706 -- offer uniformity among the various kinds of pre/postconditions by
4707 -- rewriting the pragma identifier. This allows the retrieval of the
4708 -- original pragma name by routine Original_Aspect_Pragma_Name.
4710 if Comes_From_Source (N) then
4711 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4712 Is_Pre_Post := True;
4713 Set_Class_Present (N, Pname = Name_Pre_Class);
4714 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4716 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4717 Is_Pre_Post := True;
4718 Set_Class_Present (N, Pname = Name_Post_Class);
4719 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4723 -- Determine the semantics with respect to duplicates and placement
4724 -- in a body. Pragmas Precondition and Postcondition were introduced
4725 -- before aspects and are not subject to the same aspect-like rules.
4727 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4728 Duplicates_OK := True;
4734 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4735 -- argument without an identifier.
4738 Check_Arg_Count (1);
4739 Check_No_Identifiers;
4741 -- Pragmas Precondition and Postcondition have complex argument
4745 Check_At_Least_N_Arguments (1);
4746 Check_At_Most_N_Arguments (2);
4747 Check_Optional_Identifier (Arg1, Name_Check);
4749 if Present (Arg2) then
4750 Check_Optional_Identifier (Arg2, Name_Message);
4751 Preanalyze_Spec_Expression
4752 (Get_Pragma_Arg (Arg2), Standard_String);
4756 -- For a pragma PPC in the extended main source unit, record enabled
4758 -- ??? nothing checks that the pragma is in the main source unit
4760 if Is_Checked (N) and then not Split_PPC (N) then
4761 Set_SCO_Pragma_Enabled (Loc);
4764 -- Ensure the proper placement of the pragma
4767 Find_Related_Declaration_Or_Body
4768 (N, Do_Checks => not Duplicates_OK);
4770 -- When a pre/postcondition pragma applies to an abstract subprogram,
4771 -- its original form must be an aspect with 'Class.
4773 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4774 if not From_Aspect_Specification (N) then
4776 ("pragma % cannot be applied to abstract subprogram");
4778 elsif not Class_Present (N) then
4780 ("aspect % requires ''Class for abstract subprogram");
4783 -- Entry declaration
4785 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4788 -- Generic subprogram declaration
4790 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4795 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4796 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4800 -- Subprogram body stub
4802 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4803 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4807 -- Subprogram declaration
4809 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4811 -- AI05-0230: When a pre/postcondition pragma applies to a null
4812 -- procedure, its original form must be an aspect with 'Class.
4814 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4815 and then Null_Present (Specification (Subp_Decl))
4816 and then From_Aspect_Specification (N)
4817 and then not Class_Present (N)
4819 Error_Pragma ("aspect % requires ''Class for null procedure");
4822 -- Implement the legality checks mandated by AI12-0131:
4823 -- Pre'Class shall not be specified for an overriding primitive
4824 -- subprogram of a tagged type T unless the Pre'Class aspect is
4825 -- specified for the corresponding primitive subprogram of some
4829 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4832 if Class_Present (N)
4833 and then Pragma_Name (N) = Name_Precondition
4834 and then Present (Overridden_Operation (E))
4835 and then not Inherits_Class_Wide_Pre (E)
4838 ("illegal class-wide precondition on overriding operation",
4839 Corresponding_Aspect (N));
4843 -- A renaming declaration may inherit a generated pragma, its
4844 -- placement comes from expansion, not from source.
4846 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4847 and then not Comes_From_Source (N)
4851 -- Otherwise the placement is illegal
4858 Subp_Id := Defining_Entity (Subp_Decl);
4860 -- A pragma that applies to a Ghost entity becomes Ghost for the
4861 -- purposes of legality checks and removal of ignored Ghost code.
4863 Mark_Ghost_Pragma (N, Subp_Id);
4865 -- Chain the pragma on the contract for further processing by
4866 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4868 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4870 -- Fully analyze the pragma when it appears inside an entry or
4871 -- subprogram body because it cannot benefit from forward references.
4873 if Nkind_In (Subp_Decl, N_Entry_Body,
4875 N_Subprogram_Body_Stub)
4877 -- The legality checks of pragmas Precondition and Postcondition
4878 -- are affected by the SPARK mode in effect and the volatility of
4879 -- the context. Analyze all pragmas in a specific order.
4881 Analyze_If_Present (Pragma_SPARK_Mode);
4882 Analyze_If_Present (Pragma_Volatile_Function);
4883 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4885 end Analyze_Pre_Post_Condition;
4887 -----------------------------------------
4888 -- Analyze_Refined_Depends_Global_Post --
4889 -----------------------------------------
4891 procedure Analyze_Refined_Depends_Global_Post
4892 (Spec_Id : out Entity_Id;
4893 Body_Id : out Entity_Id;
4894 Legal : out Boolean)
4896 Body_Decl : Node_Id;
4897 Spec_Decl : Node_Id;
4900 -- Assume that the pragma is illegal
4907 Check_Arg_Count (1);
4908 Check_No_Identifiers;
4910 -- Verify the placement of the pragma and check for duplicates. The
4911 -- pragma must apply to a subprogram body [stub].
4913 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4915 if not Nkind_In (Body_Decl, N_Entry_Body,
4917 N_Subprogram_Body_Stub,
4925 Body_Id := Defining_Entity (Body_Decl);
4926 Spec_Id := Unique_Defining_Entity (Body_Decl);
4928 -- The pragma must apply to the second declaration of a subprogram.
4929 -- In other words, the body [stub] cannot acts as a spec.
4931 if No (Spec_Id) then
4932 Error_Pragma ("pragma % cannot apply to a stand alone body");
4935 -- Catch the case where the subprogram body is a subunit and acts as
4936 -- the third declaration of the subprogram.
4938 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4939 Error_Pragma ("pragma % cannot apply to a subunit");
4943 -- A refined pragma can only apply to the body [stub] of a subprogram
4944 -- declared in the visible part of a package. Retrieve the context of
4945 -- the subprogram declaration.
4947 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4949 -- When dealing with protected entries or protected subprograms, use
4950 -- the enclosing protected type as the proper context.
4952 if Ekind_In (Spec_Id, E_Entry,
4956 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4958 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4961 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4963 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4964 & "subprogram declared in a package specification"));
4968 -- If we get here, then the pragma is legal
4972 -- A pragma that applies to a Ghost entity becomes Ghost for the
4973 -- purposes of legality checks and removal of ignored Ghost code.
4975 Mark_Ghost_Pragma (N, Spec_Id);
4977 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4978 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4980 end Analyze_Refined_Depends_Global_Post;
4982 ----------------------------------
4983 -- Analyze_Unmodified_Or_Unused --
4984 ----------------------------------
4986 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4991 Ghost_Error_Posted : Boolean := False;
4992 -- Flag set when an error concerning the illegal mix of Ghost and
4993 -- non-Ghost variables is emitted.
4995 Ghost_Id : Entity_Id := Empty;
4996 -- The entity of the first Ghost variable encountered while
4997 -- processing the arguments of the pragma.
5001 Check_At_Least_N_Arguments (1);
5003 -- Loop through arguments
5006 while Present (Arg) loop
5007 Check_No_Identifier (Arg);
5009 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5010 -- in fact generate reference, so that the entity will have a
5011 -- reference, which will inhibit any warnings about it not
5012 -- being referenced, and also properly show up in the ali file
5013 -- as a reference. But this reference is recorded before the
5014 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5015 -- generated for this reference.
5017 Check_Arg_Is_Local_Name (Arg);
5018 Arg_Expr := Get_Pragma_Arg (Arg);
5020 if Is_Entity_Name (Arg_Expr) then
5021 Arg_Id := Entity (Arg_Expr);
5023 -- Skip processing the argument if already flagged
5025 if Is_Assignable (Arg_Id)
5026 and then not Has_Pragma_Unmodified (Arg_Id)
5027 and then not Has_Pragma_Unused (Arg_Id)
5029 Set_Has_Pragma_Unmodified (Arg_Id);
5032 Set_Has_Pragma_Unused (Arg_Id);
5035 -- A pragma that applies to a Ghost entity becomes Ghost for
5036 -- the purposes of legality checks and removal of ignored
5039 Mark_Ghost_Pragma (N, Arg_Id);
5041 -- Capture the entity of the first Ghost variable being
5042 -- processed for error detection purposes.
5044 if Is_Ghost_Entity (Arg_Id) then
5045 if No (Ghost_Id) then
5049 -- Otherwise the variable is non-Ghost. It is illegal to mix
5050 -- references to Ghost and non-Ghost entities
5053 elsif Present (Ghost_Id)
5054 and then not Ghost_Error_Posted
5056 Ghost_Error_Posted := True;
5058 Error_Msg_Name_1 := Pname;
5060 ("pragma % cannot mention ghost and non-ghost "
5063 Error_Msg_Sloc := Sloc (Ghost_Id);
5064 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5066 Error_Msg_Sloc := Sloc (Arg_Id);
5067 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5070 -- Warn if already flagged as Unused or Unmodified
5072 elsif Has_Pragma_Unmodified (Arg_Id) then
5073 if Has_Pragma_Unused (Arg_Id) then
5075 ("??pragma Unused already given for &!", Arg_Expr,
5079 ("??pragma Unmodified already given for &!", Arg_Expr,
5083 -- Otherwise the pragma referenced an illegal entity
5087 ("pragma% can only be applied to a variable", Arg_Expr);
5093 end Analyze_Unmodified_Or_Unused;
5095 ------------------------------------
5096 -- Analyze_Unreferenced_Or_Unused --
5097 ------------------------------------
5099 procedure Analyze_Unreferenced_Or_Unused
5100 (Is_Unused : Boolean := False)
5107 Ghost_Error_Posted : Boolean := False;
5108 -- Flag set when an error concerning the illegal mix of Ghost and
5109 -- non-Ghost names is emitted.
5111 Ghost_Id : Entity_Id := Empty;
5112 -- The entity of the first Ghost name encountered while processing
5113 -- the arguments of the pragma.
5117 Check_At_Least_N_Arguments (1);
5119 -- Check case of appearing within context clause
5121 if not Is_Unused and then Is_In_Context_Clause then
5123 -- The arguments must all be units mentioned in a with clause in
5124 -- the same context clause. Note that Par.Prag already checked
5125 -- that the arguments are either identifiers or selected
5129 while Present (Arg) loop
5130 Citem := First (List_Containing (N));
5131 while Citem /= N loop
5132 Arg_Expr := Get_Pragma_Arg (Arg);
5134 if Nkind (Citem) = N_With_Clause
5135 and then Same_Name (Name (Citem), Arg_Expr)
5137 Set_Has_Pragma_Unreferenced
5140 (Library_Unit (Citem))));
5141 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5150 ("argument of pragma% is not withed unit", Arg);
5156 -- Case of not in list of context items
5160 while Present (Arg) loop
5161 Check_No_Identifier (Arg);
5163 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5164 -- in fact generate reference, so that the entity will have a
5165 -- reference, which will inhibit any warnings about it not
5166 -- being referenced, and also properly show up in the ali file
5167 -- as a reference. But this reference is recorded before the
5168 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5169 -- generated for this reference.
5171 Check_Arg_Is_Local_Name (Arg);
5172 Arg_Expr := Get_Pragma_Arg (Arg);
5174 if Is_Entity_Name (Arg_Expr) then
5175 Arg_Id := Entity (Arg_Expr);
5177 -- Warn if already flagged as Unused or Unreferenced and
5178 -- skip processing the argument.
5180 if Has_Pragma_Unreferenced (Arg_Id) then
5181 if Has_Pragma_Unused (Arg_Id) then
5183 ("??pragma Unused already given for &!", Arg_Expr,
5187 ("??pragma Unreferenced already given for &!",
5191 -- Apply Unreferenced to the entity
5194 -- If the entity is overloaded, the pragma applies to the
5195 -- most recent overloading, as documented. In this case,
5196 -- name resolution does not generate a reference, so it
5197 -- must be done here explicitly.
5199 if Is_Overloaded (Arg_Expr) then
5200 Generate_Reference (Arg_Id, N);
5203 Set_Has_Pragma_Unreferenced (Arg_Id);
5206 Set_Has_Pragma_Unused (Arg_Id);
5209 -- A pragma that applies to a Ghost entity becomes Ghost
5210 -- for the purposes of legality checks and removal of
5211 -- ignored Ghost code.
5213 Mark_Ghost_Pragma (N, Arg_Id);
5215 -- Capture the entity of the first Ghost name being
5216 -- processed for error detection purposes.
5218 if Is_Ghost_Entity (Arg_Id) then
5219 if No (Ghost_Id) then
5223 -- Otherwise the name is non-Ghost. It is illegal to mix
5224 -- references to Ghost and non-Ghost entities
5227 elsif Present (Ghost_Id)
5228 and then not Ghost_Error_Posted
5230 Ghost_Error_Posted := True;
5232 Error_Msg_Name_1 := Pname;
5234 ("pragma % cannot mention ghost and non-ghost "
5237 Error_Msg_Sloc := Sloc (Ghost_Id);
5239 ("\& # declared as ghost", N, Ghost_Id);
5241 Error_Msg_Sloc := Sloc (Arg_Id);
5243 ("\& # declared as non-ghost", N, Arg_Id);
5251 end Analyze_Unreferenced_Or_Unused;
5253 --------------------------
5254 -- Check_Ada_83_Warning --
5255 --------------------------
5257 procedure Check_Ada_83_Warning is
5259 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5260 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5262 end Check_Ada_83_Warning;
5264 ---------------------
5265 -- Check_Arg_Count --
5266 ---------------------
5268 procedure Check_Arg_Count (Required : Nat) is
5270 if Arg_Count /= Required then
5271 Error_Pragma ("wrong number of arguments for pragma%");
5273 end Check_Arg_Count;
5275 --------------------------------
5276 -- Check_Arg_Is_External_Name --
5277 --------------------------------
5279 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5280 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5283 if Nkind (Argx) = N_Identifier then
5287 Analyze_And_Resolve (Argx, Standard_String);
5289 if Is_OK_Static_Expression (Argx) then
5292 elsif Etype (Argx) = Any_Type then
5295 -- An interesting special case, if we have a string literal and
5296 -- we are in Ada 83 mode, then we allow it even though it will
5297 -- not be flagged as static. This allows expected Ada 83 mode
5298 -- use of external names which are string literals, even though
5299 -- technically these are not static in Ada 83.
5301 elsif Ada_Version = Ada_83
5302 and then Nkind (Argx) = N_String_Literal
5306 -- Here we have a real error (non-static expression)
5309 Error_Msg_Name_1 := Pname;
5310 Flag_Non_Static_Expr
5311 (Fix_Error ("argument for pragma% must be a identifier or "
5312 & "static string expression!"), Argx);
5317 end Check_Arg_Is_External_Name;
5319 -----------------------------
5320 -- Check_Arg_Is_Identifier --
5321 -----------------------------
5323 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5324 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5326 if Nkind (Argx) /= N_Identifier then
5327 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5329 end Check_Arg_Is_Identifier;
5331 ----------------------------------
5332 -- Check_Arg_Is_Integer_Literal --
5333 ----------------------------------
5335 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5336 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5338 if Nkind (Argx) /= N_Integer_Literal then
5340 ("argument for pragma% must be integer literal", Argx);
5342 end Check_Arg_Is_Integer_Literal;
5344 -------------------------------------------
5345 -- Check_Arg_Is_Library_Level_Local_Name --
5346 -------------------------------------------
5350 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5351 -- | library_unit_NAME
5353 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5355 Check_Arg_Is_Local_Name (Arg);
5357 -- If it came from an aspect, we want to give the error just as if it
5358 -- came from source.
5360 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5361 and then (Comes_From_Source (N)
5362 or else Present (Corresponding_Aspect (Parent (Arg))))
5365 ("argument for pragma% must be library level entity", Arg);
5367 end Check_Arg_Is_Library_Level_Local_Name;
5369 -----------------------------
5370 -- Check_Arg_Is_Local_Name --
5371 -----------------------------
5375 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5376 -- | library_unit_NAME
5378 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5379 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5382 -- If this pragma came from an aspect specification, we don't want to
5383 -- check for this error, because that would cause spurious errors, in
5384 -- case a type is frozen in a scope more nested than the type. The
5385 -- aspect itself of course can't be anywhere but on the declaration
5388 if Nkind (Arg) = N_Pragma_Argument_Association then
5389 if From_Aspect_Specification (Parent (Arg)) then
5393 -- Arg is the Expression of an N_Pragma_Argument_Association
5396 if From_Aspect_Specification (Parent (Parent (Arg))) then
5403 if Nkind (Argx) not in N_Direct_Name
5404 and then (Nkind (Argx) /= N_Attribute_Reference
5405 or else Present (Expressions (Argx))
5406 or else Nkind (Prefix (Argx)) /= N_Identifier)
5407 and then (not Is_Entity_Name (Argx)
5408 or else not Is_Compilation_Unit (Entity (Argx)))
5410 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5413 -- No further check required if not an entity name
5415 if not Is_Entity_Name (Argx) then
5421 Ent : constant Entity_Id := Entity (Argx);
5422 Scop : constant Entity_Id := Scope (Ent);
5425 -- Case of a pragma applied to a compilation unit: pragma must
5426 -- occur immediately after the program unit in the compilation.
5428 if Is_Compilation_Unit (Ent) then
5430 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5433 -- Case of pragma placed immediately after spec
5435 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5438 -- Case of pragma placed immediately after body
5440 elsif Nkind (Decl) = N_Subprogram_Declaration
5441 and then Present (Corresponding_Body (Decl))
5445 (Parent (Unit_Declaration_Node
5446 (Corresponding_Body (Decl))));
5448 -- All other cases are illegal
5455 -- Special restricted placement rule from 10.2.1(11.8/2)
5457 elsif Is_Generic_Formal (Ent)
5458 and then Prag_Id = Pragma_Preelaborable_Initialization
5460 OK := List_Containing (N) =
5461 Generic_Formal_Declarations
5462 (Unit_Declaration_Node (Scop));
5464 -- If this is an aspect applied to a subprogram body, the
5465 -- pragma is inserted in its declarative part.
5467 elsif From_Aspect_Specification (N)
5468 and then Ent = Current_Scope
5470 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5474 -- If the aspect is a predicate (possibly others ???) and the
5475 -- context is a record type, this is a discriminant expression
5476 -- within a type declaration, that freezes the predicated
5479 elsif From_Aspect_Specification (N)
5480 and then Prag_Id = Pragma_Predicate
5481 and then Ekind (Current_Scope) = E_Record_Type
5482 and then Scop = Scope (Current_Scope)
5486 -- Default case, just check that the pragma occurs in the scope
5487 -- of the entity denoted by the name.
5490 OK := Current_Scope = Scop;
5495 ("pragma% argument must be in same declarative part", Arg);
5499 end Check_Arg_Is_Local_Name;
5501 ---------------------------------
5502 -- Check_Arg_Is_Locking_Policy --
5503 ---------------------------------
5505 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5506 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5509 Check_Arg_Is_Identifier (Argx);
5511 if not Is_Locking_Policy_Name (Chars (Argx)) then
5512 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5514 end Check_Arg_Is_Locking_Policy;
5516 -----------------------------------------------
5517 -- Check_Arg_Is_Partition_Elaboration_Policy --
5518 -----------------------------------------------
5520 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5521 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5524 Check_Arg_Is_Identifier (Argx);
5526 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5528 ("& is not a valid partition elaboration policy name", Argx);
5530 end Check_Arg_Is_Partition_Elaboration_Policy;
5532 -------------------------
5533 -- Check_Arg_Is_One_Of --
5534 -------------------------
5536 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5537 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5540 Check_Arg_Is_Identifier (Argx);
5542 if not Nam_In (Chars (Argx), N1, N2) then
5543 Error_Msg_Name_2 := N1;
5544 Error_Msg_Name_3 := N2;
5545 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5547 end Check_Arg_Is_One_Of;
5549 procedure Check_Arg_Is_One_Of
5551 N1, N2, N3 : Name_Id)
5553 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5556 Check_Arg_Is_Identifier (Argx);
5558 if not Nam_In (Chars (Argx), N1, N2, N3) then
5559 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5561 end Check_Arg_Is_One_Of;
5563 procedure Check_Arg_Is_One_Of
5565 N1, N2, N3, N4 : Name_Id)
5567 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5570 Check_Arg_Is_Identifier (Argx);
5572 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5573 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5575 end Check_Arg_Is_One_Of;
5577 procedure Check_Arg_Is_One_Of
5579 N1, N2, N3, N4, N5 : Name_Id)
5581 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5584 Check_Arg_Is_Identifier (Argx);
5586 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5587 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5589 end Check_Arg_Is_One_Of;
5591 ---------------------------------
5592 -- Check_Arg_Is_Queuing_Policy --
5593 ---------------------------------
5595 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5596 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5599 Check_Arg_Is_Identifier (Argx);
5601 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5602 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5604 end Check_Arg_Is_Queuing_Policy;
5606 ---------------------------------------
5607 -- Check_Arg_Is_OK_Static_Expression --
5608 ---------------------------------------
5610 procedure Check_Arg_Is_OK_Static_Expression
5612 Typ : Entity_Id := Empty)
5615 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5616 end Check_Arg_Is_OK_Static_Expression;
5618 ------------------------------------------
5619 -- Check_Arg_Is_Task_Dispatching_Policy --
5620 ------------------------------------------
5622 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5623 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5626 Check_Arg_Is_Identifier (Argx);
5628 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5630 ("& is not an allowed task dispatching policy name", Argx);
5632 end Check_Arg_Is_Task_Dispatching_Policy;
5634 ---------------------
5635 -- Check_Arg_Order --
5636 ---------------------
5638 procedure Check_Arg_Order (Names : Name_List) is
5641 Highest_So_Far : Natural := 0;
5642 -- Highest index in Names seen do far
5646 for J in 1 .. Arg_Count loop
5647 if Chars (Arg) /= No_Name then
5648 for K in Names'Range loop
5649 if Chars (Arg) = Names (K) then
5650 if K < Highest_So_Far then
5651 Error_Msg_Name_1 := Pname;
5653 ("parameters out of order for pragma%", Arg);
5654 Error_Msg_Name_1 := Names (K);
5655 Error_Msg_Name_2 := Names (Highest_So_Far);
5656 Error_Msg_N ("\% must appear before %", Arg);
5660 Highest_So_Far := K;
5668 end Check_Arg_Order;
5670 --------------------------------
5671 -- Check_At_Least_N_Arguments --
5672 --------------------------------
5674 procedure Check_At_Least_N_Arguments (N : Nat) is
5676 if Arg_Count < N then
5677 Error_Pragma ("too few arguments for pragma%");
5679 end Check_At_Least_N_Arguments;
5681 -------------------------------
5682 -- Check_At_Most_N_Arguments --
5683 -------------------------------
5685 procedure Check_At_Most_N_Arguments (N : Nat) is
5688 if Arg_Count > N then
5690 for J in 1 .. N loop
5692 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5695 end Check_At_Most_N_Arguments;
5697 ---------------------
5698 -- Check_Component --
5699 ---------------------
5701 procedure Check_Component
5704 In_Variant_Part : Boolean := False)
5706 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5707 Sindic : constant Node_Id :=
5708 Subtype_Indication (Component_Definition (Comp));
5709 Typ : constant Entity_Id := Etype (Comp_Id);
5712 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5713 -- object constraint, then the component type shall be an Unchecked_
5716 if Nkind (Sindic) = N_Subtype_Indication
5717 and then Has_Per_Object_Constraint (Comp_Id)
5718 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5721 ("component subtype subject to per-object constraint "
5722 & "must be an Unchecked_Union", Comp);
5724 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5725 -- the body of a generic unit, or within the body of any of its
5726 -- descendant library units, no part of the type of a component
5727 -- declared in a variant_part of the unchecked union type shall be of
5728 -- a formal private type or formal private extension declared within
5729 -- the formal part of the generic unit.
5731 elsif Ada_Version >= Ada_2012
5732 and then In_Generic_Body (UU_Typ)
5733 and then In_Variant_Part
5734 and then Is_Private_Type (Typ)
5735 and then Is_Generic_Type (Typ)
5738 ("component of unchecked union cannot be of generic type", Comp);
5740 elsif Needs_Finalization (Typ) then
5742 ("component of unchecked union cannot be controlled", Comp);
5744 elsif Has_Task (Typ) then
5746 ("component of unchecked union cannot have tasks", Comp);
5748 end Check_Component;
5750 ----------------------------
5751 -- Check_Duplicate_Pragma --
5752 ----------------------------
5754 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5755 Id : Entity_Id := E;
5759 -- Nothing to do if this pragma comes from an aspect specification,
5760 -- since we could not be duplicating a pragma, and we dealt with the
5761 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5763 if From_Aspect_Specification (N) then
5767 -- Otherwise current pragma may duplicate previous pragma or a
5768 -- previously given aspect specification or attribute definition
5769 -- clause for the same pragma.
5771 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5775 -- If the entity is a type, then we have to make sure that the
5776 -- ostensible duplicate is not for a parent type from which this
5780 if Nkind (P) = N_Pragma then
5782 Args : constant List_Id :=
5783 Pragma_Argument_Associations (P);
5786 and then Is_Entity_Name (Expression (First (Args)))
5787 and then Is_Type (Entity (Expression (First (Args))))
5788 and then Entity (Expression (First (Args))) /= E
5794 elsif Nkind (P) = N_Aspect_Specification
5795 and then Is_Type (Entity (P))
5796 and then Entity (P) /= E
5802 -- Here we have a definite duplicate
5804 Error_Msg_Name_1 := Pragma_Name (N);
5805 Error_Msg_Sloc := Sloc (P);
5807 -- For a single protected or a single task object, the error is
5808 -- issued on the original entity.
5810 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5811 Id := Defining_Identifier (Original_Node (Parent (Id)));
5814 if Nkind (P) = N_Aspect_Specification
5815 or else From_Aspect_Specification (P)
5817 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5819 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5824 end Check_Duplicate_Pragma;
5826 ----------------------------------
5827 -- Check_Duplicated_Export_Name --
5828 ----------------------------------
5830 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5831 String_Val : constant String_Id := Strval (Nam);
5834 -- We are only interested in the export case, and in the case of
5835 -- generics, it is the instance, not the template, that is the
5836 -- problem (the template will generate a warning in any case).
5838 if not Inside_A_Generic
5839 and then (Prag_Id = Pragma_Export
5841 Prag_Id = Pragma_Export_Procedure
5843 Prag_Id = Pragma_Export_Valued_Procedure
5845 Prag_Id = Pragma_Export_Function)
5847 for J in Externals.First .. Externals.Last loop
5848 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5849 Error_Msg_Sloc := Sloc (Externals.Table (J));
5850 Error_Msg_N ("external name duplicates name given#", Nam);
5855 Externals.Append (Nam);
5857 end Check_Duplicated_Export_Name;
5859 ----------------------------------------
5860 -- Check_Expr_Is_OK_Static_Expression --
5861 ----------------------------------------
5863 procedure Check_Expr_Is_OK_Static_Expression
5865 Typ : Entity_Id := Empty)
5868 if Present (Typ) then
5869 Analyze_And_Resolve (Expr, Typ);
5871 Analyze_And_Resolve (Expr);
5874 -- An expression cannot be considered static if its resolution failed
5875 -- or if it's erroneous. Stop the analysis of the related pragma.
5877 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5880 elsif Is_OK_Static_Expression (Expr) then
5883 -- An interesting special case, if we have a string literal and we
5884 -- are in Ada 83 mode, then we allow it even though it will not be
5885 -- flagged as static. This allows the use of Ada 95 pragmas like
5886 -- Import in Ada 83 mode. They will of course be flagged with
5887 -- warnings as usual, but will not cause errors.
5889 elsif Ada_Version = Ada_83
5890 and then Nkind (Expr) = N_String_Literal
5894 -- Finally, we have a real error
5897 Error_Msg_Name_1 := Pname;
5898 Flag_Non_Static_Expr
5899 (Fix_Error ("argument for pragma% must be a static expression!"),
5903 end Check_Expr_Is_OK_Static_Expression;
5905 -------------------------
5906 -- Check_First_Subtype --
5907 -------------------------
5909 procedure Check_First_Subtype (Arg : Node_Id) is
5910 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5911 Ent : constant Entity_Id := Entity (Argx);
5914 if Is_First_Subtype (Ent) then
5917 elsif Is_Type (Ent) then
5919 ("pragma% cannot apply to subtype", Argx);
5921 elsif Is_Object (Ent) then
5923 ("pragma% cannot apply to object, requires a type", Argx);
5927 ("pragma% cannot apply to&, requires a type", Argx);
5929 end Check_First_Subtype;
5931 ----------------------
5932 -- Check_Identifier --
5933 ----------------------
5935 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5938 and then Nkind (Arg) = N_Pragma_Argument_Association
5940 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5941 Error_Msg_Name_1 := Pname;
5942 Error_Msg_Name_2 := Id;
5943 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5947 end Check_Identifier;
5949 --------------------------------
5950 -- Check_Identifier_Is_One_Of --
5951 --------------------------------
5953 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5956 and then Nkind (Arg) = N_Pragma_Argument_Association
5958 if Chars (Arg) = No_Name then
5959 Error_Msg_Name_1 := Pname;
5960 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5963 elsif Chars (Arg) /= N1
5964 and then Chars (Arg) /= N2
5966 Error_Msg_Name_1 := Pname;
5967 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5971 end Check_Identifier_Is_One_Of;
5973 ---------------------------
5974 -- Check_In_Main_Program --
5975 ---------------------------
5977 procedure Check_In_Main_Program is
5978 P : constant Node_Id := Parent (N);
5981 -- Must be in subprogram body
5983 if Nkind (P) /= N_Subprogram_Body then
5984 Error_Pragma ("% pragma allowed only in subprogram");
5986 -- Otherwise warn if obviously not main program
5988 elsif Present (Parameter_Specifications (Specification (P)))
5989 or else not Is_Compilation_Unit (Defining_Entity (P))
5991 Error_Msg_Name_1 := Pname;
5993 ("??pragma% is only effective in main program", N);
5995 end Check_In_Main_Program;
5997 ---------------------------------------
5998 -- Check_Interrupt_Or_Attach_Handler --
5999 ---------------------------------------
6001 procedure Check_Interrupt_Or_Attach_Handler is
6002 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6003 Handler_Proc, Proc_Scope : Entity_Id;
6008 if Prag_Id = Pragma_Interrupt_Handler then
6009 Check_Restriction (No_Dynamic_Attachment, N);
6012 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6013 Proc_Scope := Scope (Handler_Proc);
6015 if Ekind (Proc_Scope) /= E_Protected_Type then
6017 ("argument of pragma% must be protected procedure", Arg1);
6020 -- For pragma case (as opposed to access case), check placement.
6021 -- We don't need to do that for aspects, because we have the
6022 -- check that they aspect applies an appropriate procedure.
6024 if not From_Aspect_Specification (N)
6025 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6027 Error_Pragma ("pragma% must be in protected definition");
6030 if not Is_Library_Level_Entity (Proc_Scope) then
6032 ("argument for pragma% must be library level entity", Arg1);
6035 -- AI05-0033: A pragma cannot appear within a generic body, because
6036 -- instance can be in a nested scope. The check that protected type
6037 -- is itself a library-level declaration is done elsewhere.
6039 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6040 -- handle code prior to AI-0033. Analysis tools typically are not
6041 -- interested in this pragma in any case, so no need to worry too
6042 -- much about its placement.
6044 if Inside_A_Generic then
6045 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6046 and then In_Package_Body (Scope (Current_Scope))
6047 and then not Relaxed_RM_Semantics
6049 Error_Pragma ("pragma% cannot be used inside a generic");
6052 end Check_Interrupt_Or_Attach_Handler;
6054 ---------------------------------
6055 -- Check_Loop_Pragma_Placement --
6056 ---------------------------------
6058 procedure Check_Loop_Pragma_Placement is
6059 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6060 -- Verify whether the current pragma is properly grouped with other
6061 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6062 -- related loop where the pragma appears.
6064 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6065 -- Determine whether an arbitrary statement Stmt denotes pragma
6066 -- Loop_Invariant or Loop_Variant.
6068 procedure Placement_Error (Constr : Node_Id);
6069 pragma No_Return (Placement_Error);
6070 -- Node Constr denotes the last loop restricted construct before we
6071 -- encountered an illegal relation between enclosing constructs. Emit
6072 -- an error depending on what Constr was.
6074 --------------------------------
6075 -- Check_Loop_Pragma_Grouping --
6076 --------------------------------
6078 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6079 Stop_Search : exception;
6080 -- This exception is used to terminate the recursive descent of
6081 -- routine Check_Grouping.
6083 procedure Check_Grouping (L : List_Id);
6084 -- Find the first group of pragmas in list L and if successful,
6085 -- ensure that the current pragma is part of that group. The
6086 -- routine raises Stop_Search once such a check is performed to
6087 -- halt the recursive descent.
6089 procedure Grouping_Error (Prag : Node_Id);
6090 pragma No_Return (Grouping_Error);
6091 -- Emit an error concerning the current pragma indicating that it
6092 -- should be placed after pragma Prag.
6094 --------------------
6095 -- Check_Grouping --
6096 --------------------
6098 procedure Check_Grouping (L : List_Id) is
6101 Prag : Node_Id := Empty; -- init to avoid warning
6104 -- Inspect the list of declarations or statements looking for
6105 -- the first grouping of pragmas:
6108 -- pragma Loop_Invariant ...;
6109 -- pragma Loop_Variant ...;
6111 -- pragma Loop_Variant ...; -- current pragma
6113 -- If the current pragma is not in the grouping, then it must
6114 -- either appear in a different declarative or statement list
6115 -- or the construct at (1) is separating the pragma from the
6119 while Present (Stmt) loop
6121 -- First pragma of the first topmost grouping has been found
6123 if Is_Loop_Pragma (Stmt) then
6125 -- The group and the current pragma are not in the same
6126 -- declarative or statement list.
6128 if List_Containing (Stmt) /= List_Containing (N) then
6129 Grouping_Error (Stmt);
6131 -- Try to reach the current pragma from the first pragma
6132 -- of the grouping while skipping other members:
6134 -- pragma Loop_Invariant ...; -- first pragma
6135 -- pragma Loop_Variant ...; -- member
6137 -- pragma Loop_Variant ...; -- current pragma
6140 while Present (Stmt) loop
6141 -- The current pragma is either the first pragma
6142 -- of the group or is a member of the group.
6143 -- Stop the search as the placement is legal.
6148 -- Skip group members, but keep track of the
6149 -- last pragma in the group.
6151 elsif Is_Loop_Pragma (Stmt) then
6154 -- Skip declarations and statements generated by
6155 -- the compiler during expansion. Note that some
6156 -- source statements (e.g. pragma Assert) may have
6157 -- been transformed so that they do not appear as
6158 -- coming from source anymore, so we instead look
6159 -- at their Original_Node.
6161 elsif not Comes_From_Source (Original_Node (Stmt))
6165 -- A non-pragma is separating the group from the
6166 -- current pragma, the placement is illegal.
6169 Grouping_Error (Prag);
6175 -- If the traversal did not reach the current pragma,
6176 -- then the list must be malformed.
6178 raise Program_Error;
6181 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6182 -- inside a loop or a block housed inside a loop. Inspect
6183 -- the declarations and statements of the block as they may
6184 -- contain the first grouping. This case follows the one for
6185 -- loop pragmas, as block statements which originate in a
6186 -- loop pragma (and so Is_Loop_Pragma will return True on
6187 -- that block statement) should be treated in the previous
6190 elsif Nkind (Stmt) = N_Block_Statement then
6191 HSS := Handled_Statement_Sequence (Stmt);
6193 Check_Grouping (Declarations (Stmt));
6195 if Present (HSS) then
6196 Check_Grouping (Statements (HSS));
6204 --------------------
6205 -- Grouping_Error --
6206 --------------------
6208 procedure Grouping_Error (Prag : Node_Id) is
6210 Error_Msg_Sloc := Sloc (Prag);
6211 Error_Pragma ("pragma% must appear next to pragma#");
6214 -- Start of processing for Check_Loop_Pragma_Grouping
6217 -- Inspect the statements of the loop or nested blocks housed
6218 -- within to determine whether the current pragma is part of the
6219 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6221 Check_Grouping (Statements (Loop_Stmt));
6224 when Stop_Search => null;
6225 end Check_Loop_Pragma_Grouping;
6227 --------------------
6228 -- Is_Loop_Pragma --
6229 --------------------
6231 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6233 -- Inspect the original node as Loop_Invariant and Loop_Variant
6234 -- pragmas are rewritten to null when assertions are disabled.
6236 if Nkind (Original_Node (Stmt)) = N_Pragma then
6238 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
6239 Name_Loop_Invariant,
6246 ---------------------
6247 -- Placement_Error --
6248 ---------------------
6250 procedure Placement_Error (Constr : Node_Id) is
6251 LA : constant String := " with Loop_Entry";
6254 if Prag_Id = Pragma_Assert then
6255 Error_Msg_String (1 .. LA'Length) := LA;
6256 Error_Msg_Strlen := LA'Length;
6258 Error_Msg_Strlen := 0;
6261 if Nkind (Constr) = N_Pragma then
6263 ("pragma %~ must appear immediately within the statements "
6267 ("block containing pragma %~ must appear immediately within "
6268 & "the statements of a loop", Constr);
6270 end Placement_Error;
6272 -- Local declarations
6277 -- Start of processing for Check_Loop_Pragma_Placement
6280 -- Check that pragma appears immediately within a loop statement,
6281 -- ignoring intervening block statements.
6285 while Present (Stmt) loop
6287 -- The pragma or previous block must appear immediately within the
6288 -- current block's declarative or statement part.
6290 if Nkind (Stmt) = N_Block_Statement then
6291 if (No (Declarations (Stmt))
6292 or else List_Containing (Prev) /= Declarations (Stmt))
6294 List_Containing (Prev) /=
6295 Statements (Handled_Statement_Sequence (Stmt))
6297 Placement_Error (Prev);
6300 -- Keep inspecting the parents because we are now within a
6301 -- chain of nested blocks.
6305 Stmt := Parent (Stmt);
6308 -- The pragma or previous block must appear immediately within the
6309 -- statements of the loop.
6311 elsif Nkind (Stmt) = N_Loop_Statement then
6312 if List_Containing (Prev) /= Statements (Stmt) then
6313 Placement_Error (Prev);
6316 -- Stop the traversal because we reached the innermost loop
6317 -- regardless of whether we encountered an error or not.
6321 -- Ignore a handled statement sequence. Note that this node may
6322 -- be related to a subprogram body in which case we will emit an
6323 -- error on the next iteration of the search.
6325 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6326 Stmt := Parent (Stmt);
6328 -- Any other statement breaks the chain from the pragma to the
6332 Placement_Error (Prev);
6337 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6338 -- grouped together with other such pragmas.
6340 if Is_Loop_Pragma (N) then
6342 -- The previous check should have located the related loop
6344 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6345 Check_Loop_Pragma_Grouping (Stmt);
6347 end Check_Loop_Pragma_Placement;
6349 -------------------------------------------
6350 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6351 -------------------------------------------
6353 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6362 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6365 elsif Nkind_In (P, N_Package_Specification,
6370 -- Note: the following tests seem a little peculiar, because
6371 -- they test for bodies, but if we were in the statement part
6372 -- of the body, we would already have hit the handled statement
6373 -- sequence, so the only way we get here is by being in the
6374 -- declarative part of the body.
6376 elsif Nkind_In (P, N_Subprogram_Body,
6387 Error_Pragma ("pragma% is not in declarative part or package spec");
6388 end Check_Is_In_Decl_Part_Or_Package_Spec;
6390 -------------------------
6391 -- Check_No_Identifier --
6392 -------------------------
6394 procedure Check_No_Identifier (Arg : Node_Id) is
6396 if Nkind (Arg) = N_Pragma_Argument_Association
6397 and then Chars (Arg) /= No_Name
6399 Error_Pragma_Arg_Ident
6400 ("pragma% does not permit identifier& here", Arg);
6402 end Check_No_Identifier;
6404 --------------------------
6405 -- Check_No_Identifiers --
6406 --------------------------
6408 procedure Check_No_Identifiers is
6412 for J in 1 .. Arg_Count loop
6413 Check_No_Identifier (Arg_Node);
6416 end Check_No_Identifiers;
6418 ------------------------
6419 -- Check_No_Link_Name --
6420 ------------------------
6422 procedure Check_No_Link_Name is
6424 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6428 if Present (Arg4) then
6430 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6432 end Check_No_Link_Name;
6434 -------------------------------
6435 -- Check_Optional_Identifier --
6436 -------------------------------
6438 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6441 and then Nkind (Arg) = N_Pragma_Argument_Association
6442 and then Chars (Arg) /= No_Name
6444 if Chars (Arg) /= Id then
6445 Error_Msg_Name_1 := Pname;
6446 Error_Msg_Name_2 := Id;
6447 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6451 end Check_Optional_Identifier;
6453 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6455 Check_Optional_Identifier (Arg, Name_Find (Id));
6456 end Check_Optional_Identifier;
6458 -------------------------------------
6459 -- Check_Static_Boolean_Expression --
6460 -------------------------------------
6462 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6464 if Present (Expr) then
6465 Analyze_And_Resolve (Expr, Standard_Boolean);
6467 if not Is_OK_Static_Expression (Expr) then
6469 ("expression of pragma % must be static", Expr);
6472 end Check_Static_Boolean_Expression;
6474 -----------------------------
6475 -- Check_Static_Constraint --
6476 -----------------------------
6478 -- Note: for convenience in writing this procedure, in addition to
6479 -- the officially (i.e. by spec) allowed argument which is always a
6480 -- constraint, it also allows ranges and discriminant associations.
6481 -- Above is not clear ???
6483 procedure Check_Static_Constraint (Constr : Node_Id) is
6485 procedure Require_Static (E : Node_Id);
6486 -- Require given expression to be static expression
6488 --------------------
6489 -- Require_Static --
6490 --------------------
6492 procedure Require_Static (E : Node_Id) is
6494 if not Is_OK_Static_Expression (E) then
6495 Flag_Non_Static_Expr
6496 ("non-static constraint not allowed in Unchecked_Union!", E);
6501 -- Start of processing for Check_Static_Constraint
6504 case Nkind (Constr) is
6505 when N_Discriminant_Association =>
6506 Require_Static (Expression (Constr));
6509 Require_Static (Low_Bound (Constr));
6510 Require_Static (High_Bound (Constr));
6512 when N_Attribute_Reference =>
6513 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6514 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6516 when N_Range_Constraint =>
6517 Check_Static_Constraint (Range_Expression (Constr));
6519 when N_Index_Or_Discriminant_Constraint =>
6523 IDC := First (Constraints (Constr));
6524 while Present (IDC) loop
6525 Check_Static_Constraint (IDC);
6533 end Check_Static_Constraint;
6535 --------------------------------------
6536 -- Check_Valid_Configuration_Pragma --
6537 --------------------------------------
6539 -- A configuration pragma must appear in the context clause of a
6540 -- compilation unit, and only other pragmas may precede it. Note that
6541 -- the test also allows use in a configuration pragma file.
6543 procedure Check_Valid_Configuration_Pragma is
6545 if not Is_Configuration_Pragma then
6546 Error_Pragma ("incorrect placement for configuration pragma%");
6548 end Check_Valid_Configuration_Pragma;
6550 -------------------------------------
6551 -- Check_Valid_Library_Unit_Pragma --
6552 -------------------------------------
6554 procedure Check_Valid_Library_Unit_Pragma is
6556 Parent_Node : Node_Id;
6557 Unit_Name : Entity_Id;
6558 Unit_Kind : Node_Kind;
6559 Unit_Node : Node_Id;
6560 Sindex : Source_File_Index;
6563 if not Is_List_Member (N) then
6567 Plist := List_Containing (N);
6568 Parent_Node := Parent (Plist);
6570 if Parent_Node = Empty then
6573 -- Case of pragma appearing after a compilation unit. In this case
6574 -- it must have an argument with the corresponding name and must
6575 -- be part of the following pragmas of its parent.
6577 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6578 if Plist /= Pragmas_After (Parent_Node) then
6581 elsif Arg_Count = 0 then
6583 ("argument required if outside compilation unit");
6586 Check_No_Identifiers;
6587 Check_Arg_Count (1);
6588 Unit_Node := Unit (Parent (Parent_Node));
6589 Unit_Kind := Nkind (Unit_Node);
6591 Analyze (Get_Pragma_Arg (Arg1));
6593 if Unit_Kind = N_Generic_Subprogram_Declaration
6594 or else Unit_Kind = N_Subprogram_Declaration
6596 Unit_Name := Defining_Entity (Unit_Node);
6598 elsif Unit_Kind in N_Generic_Instantiation then
6599 Unit_Name := Defining_Entity (Unit_Node);
6602 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6605 if Chars (Unit_Name) /=
6606 Chars (Entity (Get_Pragma_Arg (Arg1)))
6609 ("pragma% argument is not current unit name", Arg1);
6612 if Ekind (Unit_Name) = E_Package
6613 and then Present (Renamed_Entity (Unit_Name))
6615 Error_Pragma ("pragma% not allowed for renamed package");
6619 -- Pragma appears other than after a compilation unit
6622 -- Here we check for the generic instantiation case and also
6623 -- for the case of processing a generic formal package. We
6624 -- detect these cases by noting that the Sloc on the node
6625 -- does not belong to the current compilation unit.
6627 Sindex := Source_Index (Current_Sem_Unit);
6629 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6630 Rewrite (N, Make_Null_Statement (Loc));
6633 -- If before first declaration, the pragma applies to the
6634 -- enclosing unit, and the name if present must be this name.
6636 elsif Is_Before_First_Decl (N, Plist) then
6637 Unit_Node := Unit_Declaration_Node (Current_Scope);
6638 Unit_Kind := Nkind (Unit_Node);
6640 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6643 elsif Unit_Kind = N_Subprogram_Body
6644 and then not Acts_As_Spec (Unit_Node)
6648 elsif Nkind (Parent_Node) = N_Package_Body then
6651 elsif Nkind (Parent_Node) = N_Package_Specification
6652 and then Plist = Private_Declarations (Parent_Node)
6656 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6657 or else Nkind (Parent_Node) =
6658 N_Generic_Subprogram_Declaration)
6659 and then Plist = Generic_Formal_Declarations (Parent_Node)
6663 elsif Arg_Count > 0 then
6664 Analyze (Get_Pragma_Arg (Arg1));
6666 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6668 ("name in pragma% must be enclosing unit", Arg1);
6671 -- It is legal to have no argument in this context
6677 -- Error if not before first declaration. This is because a
6678 -- library unit pragma argument must be the name of a library
6679 -- unit (RM 10.1.5(7)), but the only names permitted in this
6680 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6681 -- generic subprogram declarations or generic instantiations.
6685 ("pragma% misplaced, must be before first declaration");
6689 end Check_Valid_Library_Unit_Pragma;
6695 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6696 Clist : constant Node_Id := Component_List (Variant);
6700 Comp := First_Non_Pragma (Component_Items (Clist));
6701 while Present (Comp) loop
6702 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6703 Next_Non_Pragma (Comp);
6707 ---------------------------
6708 -- Ensure_Aggregate_Form --
6709 ---------------------------
6711 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6712 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6713 Expr : constant Node_Id := Expression (Arg);
6714 Loc : constant Source_Ptr := Sloc (Expr);
6715 Comps : List_Id := No_List;
6716 Exprs : List_Id := No_List;
6717 Nam : Name_Id := No_Name;
6718 Nam_Loc : Source_Ptr;
6721 -- The pragma argument is in positional form:
6723 -- pragma Depends (Nam => ...)
6727 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6728 -- argument association.
6730 if Nkind (Arg) = N_Pragma_Argument_Association then
6732 Nam_Loc := Sloc (Arg);
6734 -- Remove the pragma argument name as this will be captured in the
6737 Set_Chars (Arg, No_Name);
6740 -- The argument is already in aggregate form, but the presence of a
6741 -- name causes this to be interpreted as named association which in
6742 -- turn must be converted into an aggregate.
6744 -- pragma Global (In_Out => (A, B, C))
6748 -- pragma Global ((In_Out => (A, B, C)))
6750 -- aggregate aggregate
6752 if Nkind (Expr) = N_Aggregate then
6753 if Nam = No_Name then
6757 -- Do not transform a null argument into an aggregate as N_Null has
6758 -- special meaning in formal verification pragmas.
6760 elsif Nkind (Expr) = N_Null then
6764 -- Everything comes from source if the original comes from source
6766 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6768 -- Positional argument is transformed into an aggregate with an
6769 -- Expressions list.
6771 if Nam = No_Name then
6772 Exprs := New_List (Relocate_Node (Expr));
6774 -- An associative argument is transformed into an aggregate with
6775 -- Component_Associations.
6779 Make_Component_Association (Loc,
6780 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6781 Expression => Relocate_Node (Expr)));
6784 Set_Expression (Arg,
6785 Make_Aggregate (Loc,
6786 Component_Associations => Comps,
6787 Expressions => Exprs));
6789 -- Restore Comes_From_Source default
6791 Set_Comes_From_Source_Default (CFSD);
6792 end Ensure_Aggregate_Form;
6798 procedure Error_Pragma (Msg : String) is
6800 Error_Msg_Name_1 := Pname;
6801 Error_Msg_N (Fix_Error (Msg), N);
6805 ----------------------
6806 -- Error_Pragma_Arg --
6807 ----------------------
6809 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6811 Error_Msg_Name_1 := Pname;
6812 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6814 end Error_Pragma_Arg;
6816 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6818 Error_Msg_Name_1 := Pname;
6819 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6820 Error_Pragma_Arg (Msg2, Arg);
6821 end Error_Pragma_Arg;
6823 ----------------------------
6824 -- Error_Pragma_Arg_Ident --
6825 ----------------------------
6827 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6829 Error_Msg_Name_1 := Pname;
6830 Error_Msg_N (Fix_Error (Msg), Arg);
6832 end Error_Pragma_Arg_Ident;
6834 ----------------------
6835 -- Error_Pragma_Ref --
6836 ----------------------
6838 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6840 Error_Msg_Name_1 := Pname;
6841 Error_Msg_Sloc := Sloc (Ref);
6842 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6844 end Error_Pragma_Ref;
6846 ------------------------
6847 -- Find_Lib_Unit_Name --
6848 ------------------------
6850 function Find_Lib_Unit_Name return Entity_Id is
6852 -- Return inner compilation unit entity, for case of nested
6853 -- categorization pragmas. This happens in generic unit.
6855 if Nkind (Parent (N)) = N_Package_Specification
6856 and then Defining_Entity (Parent (N)) /= Current_Scope
6858 return Defining_Entity (Parent (N));
6860 return Current_Scope;
6862 end Find_Lib_Unit_Name;
6864 ----------------------------
6865 -- Find_Program_Unit_Name --
6866 ----------------------------
6868 procedure Find_Program_Unit_Name (Id : Node_Id) is
6869 Unit_Name : Entity_Id;
6870 Unit_Kind : Node_Kind;
6871 P : constant Node_Id := Parent (N);
6874 if Nkind (P) = N_Compilation_Unit then
6875 Unit_Kind := Nkind (Unit (P));
6877 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6878 N_Package_Declaration)
6879 or else Unit_Kind in N_Generic_Declaration
6881 Unit_Name := Defining_Entity (Unit (P));
6883 if Chars (Id) = Chars (Unit_Name) then
6884 Set_Entity (Id, Unit_Name);
6885 Set_Etype (Id, Etype (Unit_Name));
6887 Set_Etype (Id, Any_Type);
6889 ("cannot find program unit referenced by pragma%");
6893 Set_Etype (Id, Any_Type);
6894 Error_Pragma ("pragma% inapplicable to this unit");
6900 end Find_Program_Unit_Name;
6902 -----------------------------------------
6903 -- Find_Unique_Parameterless_Procedure --
6904 -----------------------------------------
6906 function Find_Unique_Parameterless_Procedure
6908 Arg : Node_Id) return Entity_Id
6910 Proc : Entity_Id := Empty;
6913 -- The body of this procedure needs some comments ???
6915 if not Is_Entity_Name (Name) then
6917 ("argument of pragma% must be entity name", Arg);
6919 elsif not Is_Overloaded (Name) then
6920 Proc := Entity (Name);
6922 if Ekind (Proc) /= E_Procedure
6923 or else Present (First_Formal (Proc))
6926 ("argument of pragma% must be parameterless procedure", Arg);
6931 Found : Boolean := False;
6933 Index : Interp_Index;
6936 Get_First_Interp (Name, Index, It);
6937 while Present (It.Nam) loop
6940 if Ekind (Proc) = E_Procedure
6941 and then No (First_Formal (Proc))
6945 Set_Entity (Name, Proc);
6946 Set_Is_Overloaded (Name, False);
6949 ("ambiguous handler name for pragma% ", Arg);
6953 Get_Next_Interp (Index, It);
6958 ("argument of pragma% must be parameterless procedure",
6961 Proc := Entity (Name);
6967 end Find_Unique_Parameterless_Procedure;
6973 function Fix_Error (Msg : String) return String is
6974 Res : String (Msg'Range) := Msg;
6975 Res_Last : Natural := Msg'Last;
6979 -- If we have a rewriting of another pragma, go to that pragma
6981 if Is_Rewrite_Substitution (N)
6982 and then Nkind (Original_Node (N)) = N_Pragma
6984 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6987 -- Case where pragma comes from an aspect specification
6989 if From_Aspect_Specification (N) then
6991 -- Change appearence of "pragma" in message to "aspect"
6994 while J <= Res_Last - 5 loop
6995 if Res (J .. J + 5) = "pragma" then
6996 Res (J .. J + 5) := "aspect";
7004 -- Change "argument of" at start of message to "entity for"
7007 and then Res (Res'First .. Res'First + 10) = "argument of"
7009 Res (Res'First .. Res'First + 9) := "entity for";
7010 Res (Res'First + 10 .. Res_Last - 1) :=
7011 Res (Res'First + 11 .. Res_Last);
7012 Res_Last := Res_Last - 1;
7015 -- Change "argument" at start of message to "entity"
7018 and then Res (Res'First .. Res'First + 7) = "argument"
7020 Res (Res'First .. Res'First + 5) := "entity";
7021 Res (Res'First + 6 .. Res_Last - 2) :=
7022 Res (Res'First + 8 .. Res_Last);
7023 Res_Last := Res_Last - 2;
7026 -- Get name from corresponding aspect
7028 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7031 -- Return possibly modified message
7033 return Res (Res'First .. Res_Last);
7036 -------------------------
7037 -- Gather_Associations --
7038 -------------------------
7040 procedure Gather_Associations
7042 Args : out Args_List)
7047 -- Initialize all parameters to Empty
7049 for J in Args'Range loop
7053 -- That's all we have to do if there are no argument associations
7055 if No (Pragma_Argument_Associations (N)) then
7059 -- Otherwise first deal with any positional parameters present
7061 Arg := First (Pragma_Argument_Associations (N));
7062 for Index in Args'Range loop
7063 exit when No (Arg) or else Chars (Arg) /= No_Name;
7064 Args (Index) := Get_Pragma_Arg (Arg);
7068 -- Positional parameters all processed, if any left, then we
7069 -- have too many positional parameters.
7071 if Present (Arg) and then Chars (Arg) = No_Name then
7073 ("too many positional associations for pragma%", Arg);
7076 -- Process named parameters if any are present
7078 while Present (Arg) loop
7079 if Chars (Arg) = No_Name then
7081 ("positional association cannot follow named association",
7085 for Index in Names'Range loop
7086 if Names (Index) = Chars (Arg) then
7087 if Present (Args (Index)) then
7089 ("duplicate argument association for pragma%", Arg);
7091 Args (Index) := Get_Pragma_Arg (Arg);
7096 if Index = Names'Last then
7097 Error_Msg_Name_1 := Pname;
7098 Error_Msg_N ("pragma% does not allow & argument", Arg);
7100 -- Check for possible misspelling
7102 for Index1 in Names'Range loop
7103 if Is_Bad_Spelling_Of
7104 (Chars (Arg), Names (Index1))
7106 Error_Msg_Name_1 := Names (Index1);
7107 Error_Msg_N -- CODEFIX
7108 ("\possible misspelling of%", Arg);
7120 end Gather_Associations;
7126 procedure GNAT_Pragma is
7128 -- We need to check the No_Implementation_Pragmas restriction for
7129 -- the case of a pragma from source. Note that the case of aspects
7130 -- generating corresponding pragmas marks these pragmas as not being
7131 -- from source, so this test also catches that case.
7133 if Comes_From_Source (N) then
7134 Check_Restriction (No_Implementation_Pragmas, N);
7138 --------------------------
7139 -- Is_Before_First_Decl --
7140 --------------------------
7142 function Is_Before_First_Decl
7143 (Pragma_Node : Node_Id;
7144 Decls : List_Id) return Boolean
7146 Item : Node_Id := First (Decls);
7149 -- Only other pragmas can come before this pragma
7152 if No (Item) or else Nkind (Item) /= N_Pragma then
7155 elsif Item = Pragma_Node then
7161 end Is_Before_First_Decl;
7163 -----------------------------
7164 -- Is_Configuration_Pragma --
7165 -----------------------------
7167 -- A configuration pragma must appear in the context clause of a
7168 -- compilation unit, and only other pragmas may precede it. Note that
7169 -- the test below also permits use in a configuration pragma file.
7171 function Is_Configuration_Pragma return Boolean is
7172 Lis : constant List_Id := List_Containing (N);
7173 Par : constant Node_Id := Parent (N);
7177 -- If no parent, then we are in the configuration pragma file,
7178 -- so the placement is definitely appropriate.
7183 -- Otherwise we must be in the context clause of a compilation unit
7184 -- and the only thing allowed before us in the context list is more
7185 -- configuration pragmas.
7187 elsif Nkind (Par) = N_Compilation_Unit
7188 and then Context_Items (Par) = Lis
7195 elsif Nkind (Prg) /= N_Pragma then
7205 end Is_Configuration_Pragma;
7207 --------------------------
7208 -- Is_In_Context_Clause --
7209 --------------------------
7211 function Is_In_Context_Clause return Boolean is
7213 Parent_Node : Node_Id;
7216 if not Is_List_Member (N) then
7220 Plist := List_Containing (N);
7221 Parent_Node := Parent (Plist);
7223 if Parent_Node = Empty
7224 or else Nkind (Parent_Node) /= N_Compilation_Unit
7225 or else Context_Items (Parent_Node) /= Plist
7232 end Is_In_Context_Clause;
7234 ---------------------------------
7235 -- Is_Static_String_Expression --
7236 ---------------------------------
7238 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7239 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7240 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7243 Analyze_And_Resolve (Argx);
7245 -- Special case Ada 83, where the expression will never be static,
7246 -- but we will return true if we had a string literal to start with.
7248 if Ada_Version = Ada_83 then
7251 -- Normal case, true only if we end up with a string literal that
7252 -- is marked as being the result of evaluating a static expression.
7255 return Is_OK_Static_Expression (Argx)
7256 and then Nkind (Argx) = N_String_Literal;
7259 end Is_Static_String_Expression;
7261 ----------------------
7262 -- Pragma_Misplaced --
7263 ----------------------
7265 procedure Pragma_Misplaced is
7267 Error_Pragma ("incorrect placement of pragma%");
7268 end Pragma_Misplaced;
7270 ------------------------------------------------
7271 -- Process_Atomic_Independent_Shared_Volatile --
7272 ------------------------------------------------
7274 procedure Process_Atomic_Independent_Shared_Volatile is
7275 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7276 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7278 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7279 -- Appropriately set flags on the given entity (either an array or
7280 -- record component, or an object declaration) according to the
7283 procedure Set_Atomic_VFA (Ent : Entity_Id);
7284 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7285 -- no explicit alignment was given, set alignment to unknown, since
7286 -- back end knows what the alignment requirements are for atomic and
7287 -- full access arrays. Note: this is necessary for derived types.
7289 -------------------------
7290 -- Check_VFA_Conflicts --
7291 -------------------------
7293 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7297 VFA_And_Atomic : Boolean := False;
7298 -- Set True if atomic component present
7300 VFA_And_Aliased : Boolean := False;
7301 -- Set True if aliased component present
7304 -- Fetch the type in case we are dealing with an object or
7307 if Is_Type (Ent) then
7310 pragma Assert (Is_Object (Ent)
7312 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7317 -- Check Atomic and VFA used together
7319 if Prag_Id = Pragma_Volatile_Full_Access
7320 or else Is_Volatile_Full_Access (Ent)
7322 if Prag_Id = Pragma_Atomic
7323 or else Prag_Id = Pragma_Shared
7324 or else Is_Atomic (Ent)
7326 VFA_And_Atomic := True;
7328 elsif Is_Array_Type (Typ) then
7329 VFA_And_Atomic := Has_Atomic_Components (Typ);
7331 -- Note: Has_Atomic_Components is not used below, as this flag
7332 -- represents the pragma of the same name, Atomic_Components,
7333 -- which only applies to arrays.
7335 elsif Is_Record_Type (Typ) then
7336 -- Attributes cannot be applied to discriminants, only
7337 -- regular record components.
7339 Comp := First_Component (Typ);
7340 while Present (Comp) loop
7342 or else Is_Atomic (Typ)
7344 VFA_And_Atomic := True;
7349 Next_Component (Comp);
7353 if VFA_And_Atomic then
7355 ("cannot have Volatile_Full_Access and Atomic for same "
7360 -- Check for the application of VFA to an entity that has aliased
7363 if Prag_Id = Pragma_Volatile_Full_Access then
7364 if Is_Array_Type (Typ)
7365 and then Has_Aliased_Components (Typ)
7367 VFA_And_Aliased := True;
7369 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7370 -- and Has_Independent_Components, applies only to arrays.
7371 -- However, this flag does not have a corresponding pragma, so
7372 -- perhaps it should be possible to apply it to record types as
7373 -- well. Should this be done ???
7375 elsif Is_Record_Type (Typ) then
7376 -- It is possible to have an aliased discriminant, so they
7377 -- must be checked along with normal components.
7379 Comp := First_Component_Or_Discriminant (Typ);
7380 while Present (Comp) loop
7381 if Is_Aliased (Comp)
7382 or else Is_Aliased (Etype (Comp))
7384 VFA_And_Aliased := True;
7385 Check_SPARK_05_Restriction
7386 ("aliased is not allowed", Comp);
7391 Next_Component_Or_Discriminant (Comp);
7395 if VFA_And_Aliased then
7397 ("cannot apply Volatile_Full_Access (aliased component "
7401 end Check_VFA_Conflicts;
7403 ------------------------------
7404 -- Mark_Component_Or_Object --
7405 ------------------------------
7407 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7409 if Prag_Id = Pragma_Atomic
7410 or else Prag_Id = Pragma_Shared
7411 or else Prag_Id = Pragma_Volatile_Full_Access
7413 if Prag_Id = Pragma_Volatile_Full_Access then
7414 Set_Is_Volatile_Full_Access (Ent);
7416 Set_Is_Atomic (Ent);
7419 -- If the object declaration has an explicit initialization, a
7420 -- temporary may have to be created to hold the expression, to
7421 -- ensure that access to the object remains atomic.
7423 if Nkind (Parent (Ent)) = N_Object_Declaration
7424 and then Present (Expression (Parent (Ent)))
7426 Set_Has_Delayed_Freeze (Ent);
7430 -- Atomic/Shared/Volatile_Full_Access imply Independent
7432 if Prag_Id /= Pragma_Volatile then
7433 Set_Is_Independent (Ent);
7435 if Prag_Id = Pragma_Independent then
7436 Record_Independence_Check (N, Ent);
7440 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7442 if Prag_Id /= Pragma_Independent then
7443 Set_Is_Volatile (Ent);
7444 Set_Treat_As_Volatile (Ent);
7446 end Mark_Component_Or_Object;
7448 --------------------
7449 -- Set_Atomic_VFA --
7450 --------------------
7452 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7454 if Prag_Id = Pragma_Volatile_Full_Access then
7455 Set_Is_Volatile_Full_Access (Ent);
7457 Set_Is_Atomic (Ent);
7460 if not Has_Alignment_Clause (Ent) then
7461 Set_Alignment (Ent, Uint_0);
7471 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7474 Check_Ada_83_Warning;
7475 Check_No_Identifiers;
7476 Check_Arg_Count (1);
7477 Check_Arg_Is_Local_Name (Arg1);
7478 E_Arg := Get_Pragma_Arg (Arg1);
7480 if Etype (E_Arg) = Any_Type then
7484 E := Entity (E_Arg);
7486 -- A pragma that applies to a Ghost entity becomes Ghost for the
7487 -- purposes of legality checks and removal of ignored Ghost code.
7489 Mark_Ghost_Pragma (N, E);
7491 -- Check duplicate before we chain ourselves
7493 Check_Duplicate_Pragma (E);
7495 -- Check appropriateness of the entity
7497 Decl := Declaration_Node (E);
7499 -- Deal with the case where the pragma/attribute is applied to a type
7502 if Rep_Item_Too_Early (E, N)
7503 or else Rep_Item_Too_Late (E, N)
7507 Check_First_Subtype (Arg1);
7510 -- Attribute belongs on the base type. If the view of the type is
7511 -- currently private, it also belongs on the underlying type.
7513 if Prag_Id = Pragma_Atomic
7514 or else Prag_Id = Pragma_Shared
7515 or else Prag_Id = Pragma_Volatile_Full_Access
7518 Set_Atomic_VFA (Base_Type (E));
7519 Set_Atomic_VFA (Underlying_Type (E));
7522 -- Atomic/Shared/Volatile_Full_Access imply Independent
7524 if Prag_Id /= Pragma_Volatile then
7525 Set_Is_Independent (E);
7526 Set_Is_Independent (Base_Type (E));
7527 Set_Is_Independent (Underlying_Type (E));
7529 if Prag_Id = Pragma_Independent then
7530 Record_Independence_Check (N, Base_Type (E));
7534 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7536 if Prag_Id /= Pragma_Independent then
7537 Set_Is_Volatile (E);
7538 Set_Is_Volatile (Base_Type (E));
7539 Set_Is_Volatile (Underlying_Type (E));
7541 Set_Treat_As_Volatile (E);
7542 Set_Treat_As_Volatile (Underlying_Type (E));
7545 -- Apply Volatile to the composite type's individual components,
7548 if Prag_Id = Pragma_Volatile
7549 and then Is_Record_Type (Etype (E))
7554 Comp := First_Component (E);
7555 while Present (Comp) loop
7556 Mark_Component_Or_Object (Comp);
7558 Next_Component (Comp);
7563 -- Deal with the case where the pragma/attribute applies to a
7564 -- component or object declaration.
7566 elsif Nkind (Decl) = N_Object_Declaration
7567 or else (Nkind (Decl) = N_Component_Declaration
7568 and then Original_Record_Component (E) = E)
7570 if Rep_Item_Too_Late (E, N) then
7574 Mark_Component_Or_Object (E);
7576 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7579 -- Perform the checks needed to assure the proper use of the GNAT
7580 -- pragma Volatile_Full_Access.
7582 Check_VFA_Conflicts (E);
7584 -- The following check is only relevant when SPARK_Mode is on as
7585 -- this is not a standard Ada legality rule. Pragma Volatile can
7586 -- only apply to a full type declaration or an object declaration
7587 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7588 -- untagged derived types that are rewritten as subtypes of their
7589 -- respective root types.
7592 and then Prag_Id = Pragma_Volatile
7593 and then not Nkind_In (Original_Node (Decl),
7594 N_Full_Type_Declaration,
7595 N_Object_Declaration,
7596 N_Single_Protected_Declaration,
7597 N_Single_Task_Declaration)
7600 ("argument of pragma % must denote a full type or object "
7601 & "declaration", Arg1);
7603 end Process_Atomic_Independent_Shared_Volatile;
7605 -------------------------------------------
7606 -- Process_Compile_Time_Warning_Or_Error --
7607 -------------------------------------------
7609 procedure Process_Compile_Time_Warning_Or_Error is
7610 P : Node_Id := Parent (N);
7611 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7613 -- In GNATprove mode, pragmas Compile_Time_Error and
7614 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7615 -- same information as the compiler (in particular regarding size of
7616 -- objects decided in gigi) so it makes no sense to issue an error or
7617 -- warning in GNATprove.
7619 if GNATprove_Mode then
7620 Rewrite (N, Make_Null_Statement (Loc));
7624 Check_Arg_Count (2);
7625 Check_No_Identifiers;
7626 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7627 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7629 -- If the condition is known at compile time (now), validate it now.
7630 -- Otherwise, register the expression for validation after the back
7631 -- end has been called, because it might be known at compile time
7632 -- then. For example, if the expression is "Record_Type'Size /= 32"
7633 -- it might be known after the back end has determined the size of
7634 -- Record_Type. We do not defer validation if we're inside a generic
7635 -- unit, because we will have more information in the instances.
7637 if Compile_Time_Known_Value (Arg1x) then
7638 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7640 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7642 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
7643 P := Corresponding_Spec (P);
7650 Defer_Compile_Time_Warning_Error_To_BE (N);
7653 end Process_Compile_Time_Warning_Or_Error;
7655 ------------------------
7656 -- Process_Convention --
7657 ------------------------
7659 procedure Process_Convention
7660 (C : out Convention_Id;
7661 Ent : out Entity_Id)
7665 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7666 -- Called if we have more than one Export/Import/Convention pragma.
7667 -- This is generally illegal, but we have a special case of allowing
7668 -- Import and Interface to coexist if they specify the convention in
7669 -- a consistent manner. We are allowed to do this, since Interface is
7670 -- an implementation defined pragma, and we choose to do it since we
7671 -- know Rational allows this combination. S is the entity id of the
7672 -- subprogram in question. This procedure also sets the special flag
7673 -- Import_Interface_Present in both pragmas in the case where we do
7674 -- have matching Import and Interface pragmas.
7676 procedure Set_Convention_From_Pragma (E : Entity_Id);
7677 -- Set convention in entity E, and also flag that the entity has a
7678 -- convention pragma. If entity is for a private or incomplete type,
7679 -- also set convention and flag on underlying type. This procedure
7680 -- also deals with the special case of C_Pass_By_Copy convention,
7681 -- and error checks for inappropriate convention specification.
7683 -------------------------------
7684 -- Diagnose_Multiple_Pragmas --
7685 -------------------------------
7687 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7688 Pdec : constant Node_Id := Declaration_Node (S);
7692 function Same_Convention (Decl : Node_Id) return Boolean;
7693 -- Decl is a pragma node. This function returns True if this
7694 -- pragma has a first argument that is an identifier with a
7695 -- Chars field corresponding to the Convention_Id C.
7697 function Same_Name (Decl : Node_Id) return Boolean;
7698 -- Decl is a pragma node. This function returns True if this
7699 -- pragma has a second argument that is an identifier with a
7700 -- Chars field that matches the Chars of the current subprogram.
7702 ---------------------
7703 -- Same_Convention --
7704 ---------------------
7706 function Same_Convention (Decl : Node_Id) return Boolean is
7707 Arg1 : constant Node_Id :=
7708 First (Pragma_Argument_Associations (Decl));
7711 if Present (Arg1) then
7713 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7715 if Nkind (Arg) = N_Identifier
7716 and then Is_Convention_Name (Chars (Arg))
7717 and then Get_Convention_Id (Chars (Arg)) = C
7725 end Same_Convention;
7731 function Same_Name (Decl : Node_Id) return Boolean is
7732 Arg1 : constant Node_Id :=
7733 First (Pragma_Argument_Associations (Decl));
7741 Arg2 := Next (Arg1);
7748 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7750 if Nkind (Arg) = N_Identifier
7751 and then Chars (Arg) = Chars (S)
7760 -- Start of processing for Diagnose_Multiple_Pragmas
7765 -- Definitely give message if we have Convention/Export here
7767 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7770 -- If we have an Import or Export, scan back from pragma to
7771 -- find any previous pragma applying to the same procedure.
7772 -- The scan will be terminated by the start of the list, or
7773 -- hitting the subprogram declaration. This won't allow one
7774 -- pragma to appear in the public part and one in the private
7775 -- part, but that seems very unlikely in practice.
7779 while Present (Decl) and then Decl /= Pdec loop
7781 -- Look for pragma with same name as us
7783 if Nkind (Decl) = N_Pragma
7784 and then Same_Name (Decl)
7786 -- Give error if same as our pragma or Export/Convention
7788 if Nam_In (Pragma_Name_Unmapped (Decl),
7791 Pragma_Name_Unmapped (N))
7795 -- Case of Import/Interface or the other way round
7797 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7798 Name_Interface, Name_Import)
7800 -- Here we know that we have Import and Interface. It
7801 -- doesn't matter which way round they are. See if
7802 -- they specify the same convention. If so, all OK,
7803 -- and set special flags to stop other messages
7805 if Same_Convention (Decl) then
7806 Set_Import_Interface_Present (N);
7807 Set_Import_Interface_Present (Decl);
7810 -- If different conventions, special message
7813 Error_Msg_Sloc := Sloc (Decl);
7815 ("convention differs from that given#", Arg1);
7825 -- Give message if needed if we fall through those tests
7826 -- except on Relaxed_RM_Semantics where we let go: either this
7827 -- is a case accepted/ignored by other Ada compilers (e.g.
7828 -- a mix of Convention and Import), or another error will be
7829 -- generated later (e.g. using both Import and Export).
7831 if Err and not Relaxed_RM_Semantics then
7833 ("at most one Convention/Export/Import pragma is allowed",
7836 end Diagnose_Multiple_Pragmas;
7838 --------------------------------
7839 -- Set_Convention_From_Pragma --
7840 --------------------------------
7842 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7844 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7845 -- for an overridden dispatching operation. Technically this is
7846 -- an amendment and should only be done in Ada 2005 mode. However,
7847 -- this is clearly a mistake, since the problem that is addressed
7848 -- by this AI is that there is a clear gap in the RM.
7850 if Is_Dispatching_Operation (E)
7851 and then Present (Overridden_Operation (E))
7852 and then C /= Convention (Overridden_Operation (E))
7855 ("cannot change convention for overridden dispatching "
7856 & "operation", Arg1);
7859 -- Special checks for Convention_Stdcall
7861 if C = Convention_Stdcall then
7863 -- A dispatching call is not allowed. A dispatching subprogram
7864 -- cannot be used to interface to the Win32 API, so in fact
7865 -- this check does not impose any effective restriction.
7867 if Is_Dispatching_Operation (E) then
7868 Error_Msg_Sloc := Sloc (E);
7870 -- Note: make this unconditional so that if there is more
7871 -- than one call to which the pragma applies, we get a
7872 -- message for each call. Also don't use Error_Pragma,
7873 -- so that we get multiple messages.
7876 ("dispatching subprogram# cannot use Stdcall convention!",
7879 -- Several allowed cases
7881 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7885 or else Ekind (E) = E_Variable
7887 -- A component as well. The entity does not have its Ekind
7888 -- set until the enclosing record declaration is fully
7891 or else Nkind (Parent (E)) = N_Component_Declaration
7893 -- An access to subprogram is also allowed
7897 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7899 -- Allow internal call to set convention of subprogram type
7901 or else Ekind (E) = E_Subprogram_Type
7907 ("second argument of pragma% must be subprogram (type)",
7912 -- Set the convention
7914 Set_Convention (E, C);
7915 Set_Has_Convention_Pragma (E);
7917 -- For the case of a record base type, also set the convention of
7918 -- any anonymous access types declared in the record which do not
7919 -- currently have a specified convention.
7921 if Is_Record_Type (E) and then Is_Base_Type (E) then
7926 Comp := First_Component (E);
7927 while Present (Comp) loop
7928 if Present (Etype (Comp))
7929 and then Ekind_In (Etype (Comp),
7930 E_Anonymous_Access_Type,
7931 E_Anonymous_Access_Subprogram_Type)
7932 and then not Has_Convention_Pragma (Comp)
7934 Set_Convention (Comp, C);
7937 Next_Component (Comp);
7942 -- Deal with incomplete/private type case, where underlying type
7943 -- is available, so set convention of that underlying type.
7945 if Is_Incomplete_Or_Private_Type (E)
7946 and then Present (Underlying_Type (E))
7948 Set_Convention (Underlying_Type (E), C);
7949 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7952 -- A class-wide type should inherit the convention of the specific
7953 -- root type (although this isn't specified clearly by the RM).
7955 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7956 Set_Convention (Class_Wide_Type (E), C);
7959 -- If the entity is a record type, then check for special case of
7960 -- C_Pass_By_Copy, which is treated the same as C except that the
7961 -- special record flag is set. This convention is only permitted
7962 -- on record types (see AI95-00131).
7964 if Cname = Name_C_Pass_By_Copy then
7965 if Is_Record_Type (E) then
7966 Set_C_Pass_By_Copy (Base_Type (E));
7967 elsif Is_Incomplete_Or_Private_Type (E)
7968 and then Is_Record_Type (Underlying_Type (E))
7970 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7973 ("C_Pass_By_Copy convention allowed only for record type",
7978 -- If the entity is a derived boolean type, check for the special
7979 -- case of convention C, C++, or Fortran, where we consider any
7980 -- nonzero value to represent true.
7982 if Is_Discrete_Type (E)
7983 and then Root_Type (Etype (E)) = Standard_Boolean
7989 C = Convention_Fortran)
7991 Set_Nonzero_Is_True (Base_Type (E));
7993 end Set_Convention_From_Pragma;
7997 Comp_Unit : Unit_Number_Type;
8002 -- Start of processing for Process_Convention
8005 Check_At_Least_N_Arguments (2);
8006 Check_Optional_Identifier (Arg1, Name_Convention);
8007 Check_Arg_Is_Identifier (Arg1);
8008 Cname := Chars (Get_Pragma_Arg (Arg1));
8010 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8011 -- tested again below to set the critical flag).
8013 if Cname = Name_C_Pass_By_Copy then
8016 -- Otherwise we must have something in the standard convention list
8018 elsif Is_Convention_Name (Cname) then
8019 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8021 -- Otherwise warn on unrecognized convention
8024 if Warn_On_Export_Import then
8026 ("??unrecognized convention name, C assumed",
8027 Get_Pragma_Arg (Arg1));
8033 Check_Optional_Identifier (Arg2, Name_Entity);
8034 Check_Arg_Is_Local_Name (Arg2);
8036 Id := Get_Pragma_Arg (Arg2);
8039 if not Is_Entity_Name (Id) then
8040 Error_Pragma_Arg ("entity name required", Arg2);
8045 -- Set entity to return
8049 -- Ada_Pass_By_Copy special checking
8051 if C = Convention_Ada_Pass_By_Copy then
8052 if not Is_First_Subtype (E) then
8054 ("convention `Ada_Pass_By_Copy` only allowed for types",
8058 if Is_By_Reference_Type (E) then
8060 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8064 -- Ada_Pass_By_Reference special checking
8066 elsif C = Convention_Ada_Pass_By_Reference then
8067 if not Is_First_Subtype (E) then
8069 ("convention `Ada_Pass_By_Reference` only allowed for types",
8073 if Is_By_Copy_Type (E) then
8075 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8080 -- Go to renamed subprogram if present, since convention applies to
8081 -- the actual renamed entity, not to the renaming entity. If the
8082 -- subprogram is inherited, go to parent subprogram.
8084 if Is_Subprogram (E)
8085 and then Present (Alias (E))
8087 if Nkind (Parent (Declaration_Node (E))) =
8088 N_Subprogram_Renaming_Declaration
8090 if Scope (E) /= Scope (Alias (E)) then
8092 ("cannot apply pragma% to non-local entity&#", E);
8097 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
8098 N_Private_Extension_Declaration)
8099 and then Scope (E) = Scope (Alias (E))
8103 -- Return the parent subprogram the entity was inherited from
8109 -- Check that we are not applying this to a specless body. Relax this
8110 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8112 if Is_Subprogram (E)
8113 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8114 and then not Relaxed_RM_Semantics
8117 ("pragma% requires separate spec and must come before body");
8120 -- Check that we are not applying this to a named constant
8122 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
8123 Error_Msg_Name_1 := Pname;
8125 ("cannot apply pragma% to named constant!",
8126 Get_Pragma_Arg (Arg2));
8128 ("\supply appropriate type for&!", Arg2);
8131 if Ekind (E) = E_Enumeration_Literal then
8132 Error_Pragma ("enumeration literal not allowed for pragma%");
8135 -- Check for rep item appearing too early or too late
8137 if Etype (E) = Any_Type
8138 or else Rep_Item_Too_Early (E, N)
8142 elsif Present (Underlying_Type (E)) then
8143 E := Underlying_Type (E);
8146 if Rep_Item_Too_Late (E, N) then
8150 if Has_Convention_Pragma (E) then
8151 Diagnose_Multiple_Pragmas (E);
8153 elsif Convention (E) = Convention_Protected
8154 or else Ekind (Scope (E)) = E_Protected_Type
8157 ("a protected operation cannot be given a different convention",
8161 -- For Intrinsic, a subprogram is required
8163 if C = Convention_Intrinsic
8164 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8166 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8168 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8170 ("second argument of pragma% must be a subprogram", Arg2);
8174 -- Deal with non-subprogram cases
8176 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8177 Set_Convention_From_Pragma (E);
8181 -- The pragma must apply to a first subtype, but it can also
8182 -- apply to a generic type in a generic formal part, in which
8183 -- case it will also appear in the corresponding instance.
8185 if Is_Generic_Type (E) or else In_Instance then
8188 Check_First_Subtype (Arg2);
8191 Set_Convention_From_Pragma (Base_Type (E));
8193 -- For access subprograms, we must set the convention on the
8194 -- internally generated directly designated type as well.
8196 if Ekind (E) = E_Access_Subprogram_Type then
8197 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8201 -- For the subprogram case, set proper convention for all homonyms
8202 -- in same scope and the same declarative part, i.e. the same
8203 -- compilation unit.
8206 Comp_Unit := Get_Source_Unit (E);
8207 Set_Convention_From_Pragma (E);
8209 -- Treat a pragma Import as an implicit body, and pragma import
8210 -- as implicit reference (for navigation in GPS).
8212 if Prag_Id = Pragma_Import then
8213 Generate_Reference (E, Id, 'b');
8215 -- For exported entities we restrict the generation of references
8216 -- to entities exported to foreign languages since entities
8217 -- exported to Ada do not provide further information to GPS and
8218 -- add undesired references to the output of the gnatxref tool.
8220 elsif Prag_Id = Pragma_Export
8221 and then Convention (E) /= Convention_Ada
8223 Generate_Reference (E, Id, 'i');
8226 -- If the pragma comes from an aspect, it only applies to the
8227 -- given entity, not its homonyms.
8229 if From_Aspect_Specification (N) then
8230 if C = Convention_Intrinsic
8231 and then Nkind (Ent) = N_Defining_Operator_Symbol
8233 if Is_Fixed_Point_Type (Etype (Ent))
8234 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8235 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8238 ("no intrinsic operator available for this fixed-point "
8241 ("\use expression functions with the desired "
8242 & "conversions made explicit", N);
8249 -- Otherwise Loop through the homonyms of the pragma argument's
8250 -- entity, an apply convention to those in the current scope.
8256 exit when No (E1) or else Scope (E1) /= Current_Scope;
8258 -- Ignore entry for which convention is already set
8260 if Has_Convention_Pragma (E1) then
8264 if Is_Subprogram (E1)
8265 and then Nkind (Parent (Declaration_Node (E1))) =
8267 and then not Relaxed_RM_Semantics
8269 Set_Has_Completion (E); -- to prevent cascaded error
8271 ("pragma% requires separate spec and must come before "
8275 -- Do not set the pragma on inherited operations or on formal
8278 if Comes_From_Source (E1)
8279 and then Comp_Unit = Get_Source_Unit (E1)
8280 and then not Is_Formal_Subprogram (E1)
8281 and then Nkind (Original_Node (Parent (E1))) /=
8282 N_Full_Type_Declaration
8284 if Present (Alias (E1))
8285 and then Scope (E1) /= Scope (Alias (E1))
8288 ("cannot apply pragma% to non-local entity& declared#",
8292 Set_Convention_From_Pragma (E1);
8294 if Prag_Id = Pragma_Import then
8295 Generate_Reference (E1, Id, 'b');
8303 end Process_Convention;
8305 ----------------------------------------
8306 -- Process_Disable_Enable_Atomic_Sync --
8307 ----------------------------------------
8309 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8311 Check_No_Identifiers;
8312 Check_At_Most_N_Arguments (1);
8314 -- Modeled internally as
8315 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8320 Pragma_Argument_Associations => New_List (
8321 Make_Pragma_Argument_Association (Loc,
8323 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8325 if Present (Arg1) then
8326 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8330 end Process_Disable_Enable_Atomic_Sync;
8332 -------------------------------------------------
8333 -- Process_Extended_Import_Export_Internal_Arg --
8334 -------------------------------------------------
8336 procedure Process_Extended_Import_Export_Internal_Arg
8337 (Arg_Internal : Node_Id := Empty)
8340 if No (Arg_Internal) then
8341 Error_Pragma ("Internal parameter required for pragma%");
8344 if Nkind (Arg_Internal) = N_Identifier then
8347 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8348 and then (Prag_Id = Pragma_Import_Function
8350 Prag_Id = Pragma_Export_Function)
8356 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8359 Check_Arg_Is_Local_Name (Arg_Internal);
8360 end Process_Extended_Import_Export_Internal_Arg;
8362 --------------------------------------------------
8363 -- Process_Extended_Import_Export_Object_Pragma --
8364 --------------------------------------------------
8366 procedure Process_Extended_Import_Export_Object_Pragma
8367 (Arg_Internal : Node_Id;
8368 Arg_External : Node_Id;
8374 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8375 Def_Id := Entity (Arg_Internal);
8377 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
8379 ("pragma% must designate an object", Arg_Internal);
8382 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8384 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8387 ("previous Common/Psect_Object applies, pragma % not permitted",
8391 if Rep_Item_Too_Late (Def_Id, N) then
8395 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8397 if Present (Arg_Size) then
8398 Check_Arg_Is_External_Name (Arg_Size);
8401 -- Export_Object case
8403 if Prag_Id = Pragma_Export_Object then
8404 if not Is_Library_Level_Entity (Def_Id) then
8406 ("argument for pragma% must be library level entity",
8410 if Ekind (Current_Scope) = E_Generic_Package then
8411 Error_Pragma ("pragma& cannot appear in a generic unit");
8414 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8416 ("exported object must have compile time known size",
8420 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8421 Error_Msg_N ("??duplicate Export_Object pragma", N);
8423 Set_Exported (Def_Id, Arg_Internal);
8426 -- Import_Object case
8429 if Is_Concurrent_Type (Etype (Def_Id)) then
8431 ("cannot use pragma% for task/protected object",
8435 if Ekind (Def_Id) = E_Constant then
8437 ("cannot import a constant", Arg_Internal);
8440 if Warn_On_Export_Import
8441 and then Has_Discriminants (Etype (Def_Id))
8444 ("imported value must be initialized??", Arg_Internal);
8447 if Warn_On_Export_Import
8448 and then Is_Access_Type (Etype (Def_Id))
8451 ("cannot import object of an access type??", Arg_Internal);
8454 if Warn_On_Export_Import
8455 and then Is_Imported (Def_Id)
8457 Error_Msg_N ("??duplicate Import_Object pragma", N);
8459 -- Check for explicit initialization present. Note that an
8460 -- initialization generated by the code generator, e.g. for an
8461 -- access type, does not count here.
8463 elsif Present (Expression (Parent (Def_Id)))
8466 (Original_Node (Expression (Parent (Def_Id))))
8468 Error_Msg_Sloc := Sloc (Def_Id);
8470 ("imported entities cannot be initialized (RM B.1(24))",
8471 "\no initialization allowed for & declared#", Arg1);
8473 Set_Imported (Def_Id);
8474 Note_Possible_Modification (Arg_Internal, Sure => False);
8477 end Process_Extended_Import_Export_Object_Pragma;
8479 ------------------------------------------------------
8480 -- Process_Extended_Import_Export_Subprogram_Pragma --
8481 ------------------------------------------------------
8483 procedure Process_Extended_Import_Export_Subprogram_Pragma
8484 (Arg_Internal : Node_Id;
8485 Arg_External : Node_Id;
8486 Arg_Parameter_Types : Node_Id;
8487 Arg_Result_Type : Node_Id := Empty;
8488 Arg_Mechanism : Node_Id;
8489 Arg_Result_Mechanism : Node_Id := Empty)
8495 Ambiguous : Boolean;
8498 function Same_Base_Type
8500 Formal : Entity_Id) return Boolean;
8501 -- Determines if Ptype references the type of Formal. Note that only
8502 -- the base types need to match according to the spec. Ptype here is
8503 -- the argument from the pragma, which is either a type name, or an
8504 -- access attribute.
8506 --------------------
8507 -- Same_Base_Type --
8508 --------------------
8510 function Same_Base_Type
8512 Formal : Entity_Id) return Boolean
8514 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8518 -- Case where pragma argument is typ'Access
8520 if Nkind (Ptype) = N_Attribute_Reference
8521 and then Attribute_Name (Ptype) = Name_Access
8523 Pref := Prefix (Ptype);
8526 if not Is_Entity_Name (Pref)
8527 or else Entity (Pref) = Any_Type
8532 -- We have a match if the corresponding argument is of an
8533 -- anonymous access type, and its designated type matches the
8534 -- type of the prefix of the access attribute
8536 return Ekind (Ftyp) = E_Anonymous_Access_Type
8537 and then Base_Type (Entity (Pref)) =
8538 Base_Type (Etype (Designated_Type (Ftyp)));
8540 -- Case where pragma argument is a type name
8545 if not Is_Entity_Name (Ptype)
8546 or else Entity (Ptype) = Any_Type
8551 -- We have a match if the corresponding argument is of the type
8552 -- given in the pragma (comparing base types)
8554 return Base_Type (Entity (Ptype)) = Ftyp;
8558 -- Start of processing for
8559 -- Process_Extended_Import_Export_Subprogram_Pragma
8562 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8566 -- Loop through homonyms (overloadings) of the entity
8568 Hom_Id := Entity (Arg_Internal);
8569 while Present (Hom_Id) loop
8570 Def_Id := Get_Base_Subprogram (Hom_Id);
8572 -- We need a subprogram in the current scope
8574 if not Is_Subprogram (Def_Id)
8575 or else Scope (Def_Id) /= Current_Scope
8582 -- Pragma cannot apply to subprogram body
8584 if Is_Subprogram (Def_Id)
8585 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8589 ("pragma% requires separate spec and must come before "
8593 -- Test result type if given, note that the result type
8594 -- parameter can only be present for the function cases.
8596 if Present (Arg_Result_Type)
8597 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8601 elsif Etype (Def_Id) /= Standard_Void_Type
8602 and then Nam_In (Pname, Name_Export_Procedure,
8603 Name_Import_Procedure)
8607 -- Test parameter types if given. Note that this parameter has
8608 -- not been analyzed (and must not be, since it is semantic
8609 -- nonsense), so we get it as the parser left it.
8611 elsif Present (Arg_Parameter_Types) then
8612 Check_Matching_Types : declare
8617 Formal := First_Formal (Def_Id);
8619 if Nkind (Arg_Parameter_Types) = N_Null then
8620 if Present (Formal) then
8624 -- A list of one type, e.g. (List) is parsed as a
8625 -- parenthesized expression.
8627 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8628 and then Paren_Count (Arg_Parameter_Types) = 1
8631 or else Present (Next_Formal (Formal))
8636 Same_Base_Type (Arg_Parameter_Types, Formal);
8639 -- A list of more than one type is parsed as a aggregate
8641 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8642 and then Paren_Count (Arg_Parameter_Types) = 0
8644 Ptype := First (Expressions (Arg_Parameter_Types));
8645 while Present (Ptype) or else Present (Formal) loop
8648 or else not Same_Base_Type (Ptype, Formal)
8653 Next_Formal (Formal);
8658 -- Anything else is of the wrong form
8662 ("wrong form for Parameter_Types parameter",
8663 Arg_Parameter_Types);
8665 end Check_Matching_Types;
8668 -- Match is now False if the entry we found did not match
8669 -- either a supplied Parameter_Types or Result_Types argument
8675 -- Ambiguous case, the flag Ambiguous shows if we already
8676 -- detected this and output the initial messages.
8679 if not Ambiguous then
8681 Error_Msg_Name_1 := Pname;
8683 ("pragma% does not uniquely identify subprogram!",
8685 Error_Msg_Sloc := Sloc (Ent);
8686 Error_Msg_N ("matching subprogram #!", N);
8690 Error_Msg_Sloc := Sloc (Def_Id);
8691 Error_Msg_N ("matching subprogram #!", N);
8696 Hom_Id := Homonym (Hom_Id);
8699 -- See if we found an entry
8702 if not Ambiguous then
8703 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8705 ("pragma% cannot be given for generic subprogram");
8708 ("pragma% does not identify local subprogram");
8715 -- Import pragmas must be for imported entities
8717 if Prag_Id = Pragma_Import_Function
8719 Prag_Id = Pragma_Import_Procedure
8721 Prag_Id = Pragma_Import_Valued_Procedure
8723 if not Is_Imported (Ent) then
8725 ("pragma Import or Interface must precede pragma%");
8728 -- Here we have the Export case which can set the entity as exported
8730 -- But does not do so if the specified external name is null, since
8731 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8732 -- compatible) to request no external name.
8734 elsif Nkind (Arg_External) = N_String_Literal
8735 and then String_Length (Strval (Arg_External)) = 0
8739 -- In all other cases, set entity as exported
8742 Set_Exported (Ent, Arg_Internal);
8745 -- Special processing for Valued_Procedure cases
8747 if Prag_Id = Pragma_Import_Valued_Procedure
8749 Prag_Id = Pragma_Export_Valued_Procedure
8751 Formal := First_Formal (Ent);
8754 Error_Pragma ("at least one parameter required for pragma%");
8756 elsif Ekind (Formal) /= E_Out_Parameter then
8757 Error_Pragma ("first parameter must have mode out for pragma%");
8760 Set_Is_Valued_Procedure (Ent);
8764 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8766 -- Process Result_Mechanism argument if present. We have already
8767 -- checked that this is only allowed for the function case.
8769 if Present (Arg_Result_Mechanism) then
8770 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8773 -- Process Mechanism parameter if present. Note that this parameter
8774 -- is not analyzed, and must not be analyzed since it is semantic
8775 -- nonsense, so we get it in exactly as the parser left it.
8777 if Present (Arg_Mechanism) then
8785 -- A single mechanism association without a formal parameter
8786 -- name is parsed as a parenthesized expression. All other
8787 -- cases are parsed as aggregates, so we rewrite the single
8788 -- parameter case as an aggregate for consistency.
8790 if Nkind (Arg_Mechanism) /= N_Aggregate
8791 and then Paren_Count (Arg_Mechanism) = 1
8793 Rewrite (Arg_Mechanism,
8794 Make_Aggregate (Sloc (Arg_Mechanism),
8795 Expressions => New_List (
8796 Relocate_Node (Arg_Mechanism))));
8799 -- Case of only mechanism name given, applies to all formals
8801 if Nkind (Arg_Mechanism) /= N_Aggregate then
8802 Formal := First_Formal (Ent);
8803 while Present (Formal) loop
8804 Set_Mechanism_Value (Formal, Arg_Mechanism);
8805 Next_Formal (Formal);
8808 -- Case of list of mechanism associations given
8811 if Null_Record_Present (Arg_Mechanism) then
8813 ("inappropriate form for Mechanism parameter",
8817 -- Deal with positional ones first
8819 Formal := First_Formal (Ent);
8821 if Present (Expressions (Arg_Mechanism)) then
8822 Mname := First (Expressions (Arg_Mechanism));
8823 while Present (Mname) loop
8826 ("too many mechanism associations", Mname);
8829 Set_Mechanism_Value (Formal, Mname);
8830 Next_Formal (Formal);
8835 -- Deal with named entries
8837 if Present (Component_Associations (Arg_Mechanism)) then
8838 Massoc := First (Component_Associations (Arg_Mechanism));
8839 while Present (Massoc) loop
8840 Choice := First (Choices (Massoc));
8842 if Nkind (Choice) /= N_Identifier
8843 or else Present (Next (Choice))
8846 ("incorrect form for mechanism association",
8850 Formal := First_Formal (Ent);
8854 ("parameter name & not present", Choice);
8857 if Chars (Choice) = Chars (Formal) then
8859 (Formal, Expression (Massoc));
8861 -- Set entity on identifier (needed by ASIS)
8863 Set_Entity (Choice, Formal);
8868 Next_Formal (Formal);
8877 end Process_Extended_Import_Export_Subprogram_Pragma;
8879 --------------------------
8880 -- Process_Generic_List --
8881 --------------------------
8883 procedure Process_Generic_List is
8888 Check_No_Identifiers;
8889 Check_At_Least_N_Arguments (1);
8891 -- Check all arguments are names of generic units or instances
8894 while Present (Arg) loop
8895 Exp := Get_Pragma_Arg (Arg);
8898 if not Is_Entity_Name (Exp)
8900 (not Is_Generic_Instance (Entity (Exp))
8902 not Is_Generic_Unit (Entity (Exp)))
8905 ("pragma% argument must be name of generic unit/instance",
8911 end Process_Generic_List;
8913 ------------------------------------
8914 -- Process_Import_Predefined_Type --
8915 ------------------------------------
8917 procedure Process_Import_Predefined_Type is
8918 Loc : constant Source_Ptr := Sloc (N);
8920 Ftyp : Node_Id := Empty;
8926 Nam := String_To_Name (Strval (Expression (Arg3)));
8928 Elmt := First_Elmt (Predefined_Float_Types);
8929 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8933 Ftyp := Node (Elmt);
8935 if Present (Ftyp) then
8937 -- Don't build a derived type declaration, because predefined C
8938 -- types have no declaration anywhere, so cannot really be named.
8939 -- Instead build a full type declaration, starting with an
8940 -- appropriate type definition is built
8942 if Is_Floating_Point_Type (Ftyp) then
8943 Def := Make_Floating_Point_Definition (Loc,
8944 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8945 Make_Real_Range_Specification (Loc,
8946 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8947 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8949 -- Should never have a predefined type we cannot handle
8952 raise Program_Error;
8955 -- Build and insert a Full_Type_Declaration, which will be
8956 -- analyzed as soon as this list entry has been analyzed.
8958 Decl := Make_Full_Type_Declaration (Loc,
8959 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8960 Type_Definition => Def);
8962 Insert_After (N, Decl);
8963 Mark_Rewrite_Insertion (Decl);
8966 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
8968 end Process_Import_Predefined_Type;
8970 ---------------------------------
8971 -- Process_Import_Or_Interface --
8972 ---------------------------------
8974 procedure Process_Import_Or_Interface is
8980 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8981 -- pragma Import (Entity, "external name");
8983 if Relaxed_RM_Semantics
8984 and then Arg_Count = 2
8985 and then Prag_Id = Pragma_Import
8986 and then Nkind (Expression (Arg2)) = N_String_Literal
8989 Def_Id := Get_Pragma_Arg (Arg1);
8992 if not Is_Entity_Name (Def_Id) then
8993 Error_Pragma_Arg ("entity name required", Arg1);
8996 Def_Id := Entity (Def_Id);
8997 Kill_Size_Check_Code (Def_Id);
8998 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9001 Process_Convention (C, Def_Id);
9003 -- A pragma that applies to a Ghost entity becomes Ghost for the
9004 -- purposes of legality checks and removal of ignored Ghost code.
9006 Mark_Ghost_Pragma (N, Def_Id);
9007 Kill_Size_Check_Code (Def_Id);
9008 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9011 -- Various error checks
9013 if Ekind_In (Def_Id, E_Variable, E_Constant) then
9015 -- We do not permit Import to apply to a renaming declaration
9017 if Present (Renamed_Object (Def_Id)) then
9019 ("pragma% not allowed for object renaming", Arg2);
9021 -- User initialization is not allowed for imported object, but
9022 -- the object declaration may contain a default initialization,
9023 -- that will be discarded. Note that an explicit initialization
9024 -- only counts if it comes from source, otherwise it is simply
9025 -- the code generator making an implicit initialization explicit.
9027 elsif Present (Expression (Parent (Def_Id)))
9028 and then Comes_From_Source
9029 (Original_Node (Expression (Parent (Def_Id))))
9031 -- Set imported flag to prevent cascaded errors
9033 Set_Is_Imported (Def_Id);
9035 Error_Msg_Sloc := Sloc (Def_Id);
9037 ("no initialization allowed for declaration of& #",
9038 "\imported entities cannot be initialized (RM B.1(24))",
9042 -- If the pragma comes from an aspect specification the
9043 -- Is_Imported flag has already been set.
9045 if not From_Aspect_Specification (N) then
9046 Set_Imported (Def_Id);
9049 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9051 -- Note that we do not set Is_Public here. That's because we
9052 -- only want to set it if there is no address clause, and we
9053 -- don't know that yet, so we delay that processing till
9056 -- pragma Import completes deferred constants
9058 if Ekind (Def_Id) = E_Constant then
9059 Set_Has_Completion (Def_Id);
9062 -- It is not possible to import a constant of an unconstrained
9063 -- array type (e.g. string) because there is no simple way to
9064 -- write a meaningful subtype for it.
9066 if Is_Array_Type (Etype (Def_Id))
9067 and then not Is_Constrained (Etype (Def_Id))
9070 ("imported constant& must have a constrained subtype",
9075 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9077 -- If the name is overloaded, pragma applies to all of the denoted
9078 -- entities in the same declarative part, unless the pragma comes
9079 -- from an aspect specification or was generated by the compiler
9080 -- (such as for pragma Provide_Shift_Operators).
9083 while Present (Hom_Id) loop
9085 Def_Id := Get_Base_Subprogram (Hom_Id);
9087 -- Ignore inherited subprograms because the pragma will apply
9088 -- to the parent operation, which is the one called.
9090 if Is_Overloadable (Def_Id)
9091 and then Present (Alias (Def_Id))
9095 -- If it is not a subprogram, it must be in an outer scope and
9096 -- pragma does not apply.
9098 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9101 -- The pragma does not apply to primitives of interfaces
9103 elsif Is_Dispatching_Operation (Def_Id)
9104 and then Present (Find_Dispatching_Type (Def_Id))
9105 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9109 -- Verify that the homonym is in the same declarative part (not
9110 -- just the same scope). If the pragma comes from an aspect
9111 -- specification we know that it is part of the declaration.
9113 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9114 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9115 and then not From_Aspect_Specification (N)
9120 -- If the pragma comes from an aspect specification the
9121 -- Is_Imported flag has already been set.
9123 if not From_Aspect_Specification (N) then
9124 Set_Imported (Def_Id);
9127 -- Reject an Import applied to an abstract subprogram
9129 if Is_Subprogram (Def_Id)
9130 and then Is_Abstract_Subprogram (Def_Id)
9132 Error_Msg_Sloc := Sloc (Def_Id);
9134 ("cannot import abstract subprogram& declared#",
9138 -- Special processing for Convention_Intrinsic
9140 if C = Convention_Intrinsic then
9142 -- Link_Name argument not allowed for intrinsic
9146 Set_Is_Intrinsic_Subprogram (Def_Id);
9148 -- If no external name is present, then check that this
9149 -- is a valid intrinsic subprogram. If an external name
9150 -- is present, then this is handled by the back end.
9153 Check_Intrinsic_Subprogram
9154 (Def_Id, Get_Pragma_Arg (Arg2));
9158 -- Verify that the subprogram does not have a completion
9159 -- through a renaming declaration. For other completions the
9160 -- pragma appears as a too late representation.
9163 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9167 and then Nkind (Decl) = N_Subprogram_Declaration
9168 and then Present (Corresponding_Body (Decl))
9169 and then Nkind (Unit_Declaration_Node
9170 (Corresponding_Body (Decl))) =
9171 N_Subprogram_Renaming_Declaration
9173 Error_Msg_Sloc := Sloc (Def_Id);
9175 ("cannot import&, renaming already provided for "
9176 & "declaration #", N, Def_Id);
9180 -- If the pragma comes from an aspect specification, there
9181 -- must be an Import aspect specified as well. In the rare
9182 -- case where Import is set to False, the suprogram needs to
9183 -- have a local completion.
9186 Imp_Aspect : constant Node_Id :=
9187 Find_Aspect (Def_Id, Aspect_Import);
9191 if Present (Imp_Aspect)
9192 and then Present (Expression (Imp_Aspect))
9194 Expr := Expression (Imp_Aspect);
9195 Analyze_And_Resolve (Expr, Standard_Boolean);
9197 if Is_Entity_Name (Expr)
9198 and then Entity (Expr) = Standard_True
9200 Set_Has_Completion (Def_Id);
9203 -- If there is no expression, the default is True, as for
9204 -- all boolean aspects. Same for the older pragma.
9207 Set_Has_Completion (Def_Id);
9211 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9214 if Is_Compilation_Unit (Hom_Id) then
9216 -- Its possible homonyms are not affected by the pragma.
9217 -- Such homonyms might be present in the context of other
9218 -- units being compiled.
9222 elsif From_Aspect_Specification (N) then
9225 -- If the pragma was created by the compiler, then we don't
9226 -- want it to apply to other homonyms. This kind of case can
9227 -- occur when using pragma Provide_Shift_Operators, which
9228 -- generates implicit shift and rotate operators with Import
9229 -- pragmas that might apply to earlier explicit or implicit
9230 -- declarations marked with Import (for example, coming from
9231 -- an earlier pragma Provide_Shift_Operators for another type),
9232 -- and we don't generally want other homonyms being treated
9233 -- as imported or the pragma flagged as an illegal duplicate.
9235 elsif not Comes_From_Source (N) then
9239 Hom_Id := Homonym (Hom_Id);
9243 -- Import a CPP class
9245 elsif C = Convention_CPP
9246 and then (Is_Record_Type (Def_Id)
9247 or else Ekind (Def_Id) = E_Incomplete_Type)
9249 if Ekind (Def_Id) = E_Incomplete_Type then
9250 if Present (Full_View (Def_Id)) then
9251 Def_Id := Full_View (Def_Id);
9255 ("cannot import 'C'P'P type before full declaration seen",
9256 Get_Pragma_Arg (Arg2));
9258 -- Although we have reported the error we decorate it as
9259 -- CPP_Class to avoid reporting spurious errors
9261 Set_Is_CPP_Class (Def_Id);
9266 -- Types treated as CPP classes must be declared limited (note:
9267 -- this used to be a warning but there is no real benefit to it
9268 -- since we did effectively intend to treat the type as limited
9271 if not Is_Limited_Type (Def_Id) then
9273 ("imported 'C'P'P type must be limited",
9274 Get_Pragma_Arg (Arg2));
9277 if Etype (Def_Id) /= Def_Id
9278 and then not Is_CPP_Class (Root_Type (Def_Id))
9280 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9283 Set_Is_CPP_Class (Def_Id);
9285 -- Imported CPP types must not have discriminants (because C++
9286 -- classes do not have discriminants).
9288 if Has_Discriminants (Def_Id) then
9290 ("imported 'C'P'P type cannot have discriminants",
9291 First (Discriminant_Specifications
9292 (Declaration_Node (Def_Id))));
9295 -- Check that components of imported CPP types do not have default
9296 -- expressions. For private types this check is performed when the
9297 -- full view is analyzed (see Process_Full_View).
9299 if not Is_Private_Type (Def_Id) then
9300 Check_CPP_Type_Has_No_Defaults (Def_Id);
9303 -- Import a CPP exception
9305 elsif C = Convention_CPP
9306 and then Ekind (Def_Id) = E_Exception
9310 ("'External_'Name arguments is required for 'Cpp exception",
9313 -- As only a string is allowed, Check_Arg_Is_External_Name
9316 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9319 if Present (Arg4) then
9321 ("Link_Name argument not allowed for imported Cpp exception",
9325 -- Do not call Set_Interface_Name as the name of the exception
9326 -- shouldn't be modified (and in particular it shouldn't be
9327 -- the External_Name). For exceptions, the External_Name is the
9328 -- name of the RTTI structure.
9330 -- ??? Emit an error if pragma Import/Export_Exception is present
9332 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9334 Check_Arg_Count (3);
9335 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9337 Process_Import_Predefined_Type;
9341 ("second argument of pragma% must be object, subprogram "
9342 & "or incomplete type",
9346 -- If this pragma applies to a compilation unit, then the unit, which
9347 -- is a subprogram, does not require (or allow) a body. We also do
9348 -- not need to elaborate imported procedures.
9350 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9352 Cunit : constant Node_Id := Parent (Parent (N));
9354 Set_Body_Required (Cunit, False);
9357 end Process_Import_Or_Interface;
9359 --------------------
9360 -- Process_Inline --
9361 --------------------
9363 procedure Process_Inline (Status : Inline_Status) is
9370 Ghost_Error_Posted : Boolean := False;
9371 -- Flag set when an error concerning the illegal mix of Ghost and
9372 -- non-Ghost subprograms is emitted.
9374 Ghost_Id : Entity_Id := Empty;
9375 -- The entity of the first Ghost subprogram encountered while
9376 -- processing the arguments of the pragma.
9378 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9379 -- Verify the placement of pragma Inline_Always with respect to the
9380 -- initial declaration of subprogram Spec_Id.
9382 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9383 -- Returns True if it can be determined at this stage that inlining
9384 -- is not possible, for example if the body is available and contains
9385 -- exception handlers, we prevent inlining, since otherwise we can
9386 -- get undefined symbols at link time. This function also emits a
9387 -- warning if the pragma appears too late.
9389 -- ??? is business with link symbols still valid, or does it relate
9390 -- to front end ZCX which is being phased out ???
9392 procedure Make_Inline (Subp : Entity_Id);
9393 -- Subp is the defining unit name of the subprogram declaration. If
9394 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9395 -- the corresponding body, if there is one present.
9397 procedure Set_Inline_Flags (Subp : Entity_Id);
9398 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9399 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9401 -----------------------------------
9402 -- Check_Inline_Always_Placement --
9403 -----------------------------------
9405 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9406 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9408 function Compilation_Unit_OK return Boolean;
9409 pragma Inline (Compilation_Unit_OK);
9410 -- Determine whether pragma Inline_Always applies to a compatible
9411 -- compilation unit denoted by Spec_Id.
9413 function Declarative_List_OK return Boolean;
9414 pragma Inline (Declarative_List_OK);
9415 -- Determine whether the initial declaration of subprogram Spec_Id
9416 -- and the pragma appear in compatible declarative lists.
9418 function Subprogram_Body_OK return Boolean;
9419 pragma Inline (Subprogram_Body_OK);
9420 -- Determine whether pragma Inline_Always applies to a compatible
9421 -- subprogram body denoted by Spec_Id.
9423 -------------------------
9424 -- Compilation_Unit_OK --
9425 -------------------------
9427 function Compilation_Unit_OK return Boolean is
9428 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9431 -- The pragma appears after the initial declaration of a
9432 -- compilation unit.
9434 -- procedure Comp_Unit;
9435 -- pragma Inline_Always (Comp_Unit);
9437 -- Note that for compatibility reasons, the following case is
9440 -- procedure Stand_Alone_Body_Comp_Unit is
9442 -- end Stand_Alone_Body_Comp_Unit;
9443 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9446 Nkind (Comp_Unit) = N_Compilation_Unit
9447 and then Present (Aux_Decls_Node (Comp_Unit))
9448 and then Is_List_Member (N)
9449 and then List_Containing (N) =
9450 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9451 end Compilation_Unit_OK;
9453 -------------------------
9454 -- Declarative_List_OK --
9455 -------------------------
9457 function Declarative_List_OK return Boolean is
9458 Context : constant Node_Id := Parent (Spec_Decl);
9460 Init_Decl : Node_Id;
9461 Init_List : List_Id;
9462 Prag_List : List_Id;
9465 -- Determine the proper initial declaration. In general this is
9466 -- the declaration node of the subprogram except when the input
9467 -- denotes a generic instantiation.
9469 -- procedure Inst is new Gen;
9470 -- pragma Inline_Always (Inst);
9472 -- In this case the original subprogram is moved inside an
9473 -- anonymous package while pragma Inline_Always remains at the
9474 -- level of the anonymous package. Use the declaration of the
9475 -- package because it reflects the placement of the original
9478 -- package Anon_Pack is
9479 -- procedure Inst is ... end Inst; -- original
9482 -- procedure Inst renames Anon_Pack.Inst;
9483 -- pragma Inline_Always (Inst);
9485 if Is_Generic_Instance (Spec_Id) then
9486 Init_Decl := Parent (Parent (Spec_Decl));
9487 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9489 Init_Decl := Spec_Decl;
9492 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9493 Init_List := List_Containing (Init_Decl);
9494 Prag_List := List_Containing (N);
9496 -- The pragma and then initial declaration appear within the
9497 -- same declarative list.
9499 if Init_List = Prag_List then
9502 -- A special case of the above is when both the pragma and
9503 -- the initial declaration appear in different lists of a
9504 -- package spec, protected definition, or a task definition.
9509 -- pragma Inline_Always (Proc);
9512 elsif Nkind_In (Context, N_Package_Specification,
9513 N_Protected_Definition,
9515 and then Init_List = Visible_Declarations (Context)
9516 and then Prag_List = Private_Declarations (Context)
9523 end Declarative_List_OK;
9525 ------------------------
9526 -- Subprogram_Body_OK --
9527 ------------------------
9529 function Subprogram_Body_OK return Boolean is
9530 Body_Decl : Node_Id;
9533 -- The pragma appears within the declarative list of a stand-
9534 -- alone subprogram body.
9536 -- procedure Stand_Alone_Body is
9537 -- pragma Inline_Always (Stand_Alone_Body);
9540 -- end Stand_Alone_Body;
9542 -- The compiler creates a dummy spec in this case, however the
9543 -- pragma remains within the declarative list of the body.
9545 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9546 and then not Comes_From_Source (Spec_Decl)
9547 and then Present (Corresponding_Body (Spec_Decl))
9550 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9552 if Present (Declarations (Body_Decl))
9553 and then Is_List_Member (N)
9554 and then List_Containing (N) = Declarations (Body_Decl)
9561 end Subprogram_Body_OK;
9563 -- Start of processing for Check_Inline_Always_Placement
9566 -- This check is relevant only for pragma Inline_Always
9568 if Pname /= Name_Inline_Always then
9571 -- Nothing to do when the pragma is internally generated on the
9572 -- assumption that it is properly placed.
9574 elsif not Comes_From_Source (N) then
9577 -- Nothing to do for internally generated subprograms that act
9578 -- as accidental homonyms of a source subprogram being inlined.
9580 elsif not Comes_From_Source (Spec_Id) then
9583 -- Nothing to do for generic formal subprograms that act as
9584 -- homonyms of another source subprogram being inlined.
9586 elsif Is_Formal_Subprogram (Spec_Id) then
9589 elsif Compilation_Unit_OK
9590 or else Declarative_List_OK
9591 or else Subprogram_Body_OK
9596 -- At this point it is known that the pragma applies to or appears
9597 -- within a completing body, a completing stub, or a subunit.
9599 Error_Msg_Name_1 := Pname;
9600 Error_Msg_Name_2 := Chars (Spec_Id);
9601 Error_Msg_Sloc := Sloc (Spec_Id);
9604 ("pragma % must appear on initial declaration of subprogram "
9605 & "% defined #", N);
9606 end Check_Inline_Always_Placement;
9608 ---------------------------
9609 -- Inlining_Not_Possible --
9610 ---------------------------
9612 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9613 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9617 if Nkind (Decl) = N_Subprogram_Body then
9618 Stats := Handled_Statement_Sequence (Decl);
9619 return Present (Exception_Handlers (Stats))
9620 or else Present (At_End_Proc (Stats));
9622 elsif Nkind (Decl) = N_Subprogram_Declaration
9623 and then Present (Corresponding_Body (Decl))
9625 if Analyzed (Corresponding_Body (Decl)) then
9626 Error_Msg_N ("pragma appears too late, ignored??", N);
9629 -- If the subprogram is a renaming as body, the body is just a
9630 -- call to the renamed subprogram, and inlining is trivially
9634 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9635 N_Subprogram_Renaming_Declaration
9641 Handled_Statement_Sequence
9642 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9645 Present (Exception_Handlers (Stats))
9646 or else Present (At_End_Proc (Stats));
9650 -- If body is not available, assume the best, the check is
9651 -- performed again when compiling enclosing package bodies.
9655 end Inlining_Not_Possible;
9661 procedure Make_Inline (Subp : Entity_Id) is
9662 Kind : constant Entity_Kind := Ekind (Subp);
9663 Inner_Subp : Entity_Id := Subp;
9666 -- Ignore if bad type, avoid cascaded error
9668 if Etype (Subp) = Any_Type then
9672 -- If inlining is not possible, for now do not treat as an error
9674 elsif Status /= Suppressed
9675 and then Front_End_Inlining
9676 and then Inlining_Not_Possible (Subp)
9681 -- Here we have a candidate for inlining, but we must exclude
9682 -- derived operations. Otherwise we would end up trying to inline
9683 -- a phantom declaration, and the result would be to drag in a
9684 -- body which has no direct inlining associated with it. That
9685 -- would not only be inefficient but would also result in the
9686 -- backend doing cross-unit inlining in cases where it was
9687 -- definitely inappropriate to do so.
9689 -- However, a simple Comes_From_Source test is insufficient, since
9690 -- we do want to allow inlining of generic instances which also do
9691 -- not come from source. We also need to recognize specs generated
9692 -- by the front-end for bodies that carry the pragma. Finally,
9693 -- predefined operators do not come from source but are not
9694 -- inlineable either.
9696 elsif Is_Generic_Instance (Subp)
9697 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9701 elsif not Comes_From_Source (Subp)
9702 and then Scope (Subp) /= Standard_Standard
9708 -- The referenced entity must either be the enclosing entity, or
9709 -- an entity declared within the current open scope.
9711 if Present (Scope (Subp))
9712 and then Scope (Subp) /= Current_Scope
9713 and then Subp /= Current_Scope
9716 ("argument of% must be entity in current scope", Assoc);
9720 -- Processing for procedure, operator or function. If subprogram
9721 -- is aliased (as for an instance) indicate that the renamed
9722 -- entity (if declared in the same unit) is inlined.
9723 -- If this is the anonymous subprogram created for a subprogram
9724 -- instance, the inlining applies to it directly. Otherwise we
9725 -- retrieve it as the alias of the visible subprogram instance.
9727 if Is_Subprogram (Subp) then
9729 -- Ensure that pragma Inline_Always is associated with the
9730 -- initial declaration of the subprogram.
9732 Check_Inline_Always_Placement (Subp);
9734 if Is_Wrapper_Package (Scope (Subp)) then
9737 Inner_Subp := Ultimate_Alias (Inner_Subp);
9740 if In_Same_Source_Unit (Subp, Inner_Subp) then
9741 Set_Inline_Flags (Inner_Subp);
9743 Decl := Parent (Parent (Inner_Subp));
9745 if Nkind (Decl) = N_Subprogram_Declaration
9746 and then Present (Corresponding_Body (Decl))
9748 Set_Inline_Flags (Corresponding_Body (Decl));
9750 elsif Is_Generic_Instance (Subp)
9751 and then Comes_From_Source (Subp)
9753 -- Indicate that the body needs to be created for
9754 -- inlining subsequent calls. The instantiation node
9755 -- follows the declaration of the wrapper package
9756 -- created for it. The subprogram that requires the
9757 -- body is the anonymous one in the wrapper package.
9759 if Scope (Subp) /= Standard_Standard
9761 Need_Subprogram_Instance_Body
9762 (Next (Unit_Declaration_Node
9763 (Scope (Alias (Subp)))), Subp)
9768 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9769 -- appear in a formal part to apply to a formal subprogram.
9770 -- Do not apply check within an instance or a formal package
9771 -- the test will have been applied to the original generic.
9773 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9774 and then List_Containing (Decl) = List_Containing (N)
9775 and then not In_Instance
9778 ("Inline cannot apply to a formal subprogram", N);
9780 -- If Subp is a renaming, it is the renamed entity that
9781 -- will appear in any call, and be inlined. However, for
9782 -- ASIS uses it is convenient to indicate that the renaming
9783 -- itself is an inlined subprogram, so that some gnatcheck
9784 -- rules can be applied in the absence of expansion.
9786 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9787 Set_Inline_Flags (Subp);
9793 -- For a generic subprogram set flag as well, for use at the point
9794 -- of instantiation, to determine whether the body should be
9797 elsif Is_Generic_Subprogram (Subp) then
9798 Set_Inline_Flags (Subp);
9801 -- Literals are by definition inlined
9803 elsif Kind = E_Enumeration_Literal then
9806 -- Anything else is an error
9810 ("expect subprogram name for pragma%", Assoc);
9814 ----------------------
9815 -- Set_Inline_Flags --
9816 ----------------------
9818 procedure Set_Inline_Flags (Subp : Entity_Id) is
9820 -- First set the Has_Pragma_XXX flags and issue the appropriate
9821 -- errors and warnings for suspicious combinations.
9823 if Prag_Id = Pragma_No_Inline then
9824 if Has_Pragma_Inline_Always (Subp) then
9826 ("Inline_Always and No_Inline are mutually exclusive", N);
9827 elsif Has_Pragma_Inline (Subp) then
9829 ("Inline and No_Inline both specified for& ??",
9830 N, Entity (Subp_Id));
9833 Set_Has_Pragma_No_Inline (Subp);
9835 if Prag_Id = Pragma_Inline_Always then
9836 if Has_Pragma_No_Inline (Subp) then
9838 ("Inline_Always and No_Inline are mutually exclusive",
9842 Set_Has_Pragma_Inline_Always (Subp);
9844 if Has_Pragma_No_Inline (Subp) then
9846 ("Inline and No_Inline both specified for& ??",
9847 N, Entity (Subp_Id));
9851 Set_Has_Pragma_Inline (Subp);
9854 -- Then adjust the Is_Inlined flag. It can never be set if the
9855 -- subprogram is subject to pragma No_Inline.
9859 Set_Is_Inlined (Subp, False);
9865 if not Has_Pragma_No_Inline (Subp) then
9866 Set_Is_Inlined (Subp, True);
9870 -- A pragma that applies to a Ghost entity becomes Ghost for the
9871 -- purposes of legality checks and removal of ignored Ghost code.
9873 Mark_Ghost_Pragma (N, Subp);
9875 -- Capture the entity of the first Ghost subprogram being
9876 -- processed for error detection purposes.
9878 if Is_Ghost_Entity (Subp) then
9879 if No (Ghost_Id) then
9883 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9884 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9886 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9887 Ghost_Error_Posted := True;
9889 Error_Msg_Name_1 := Pname;
9891 ("pragma % cannot mention ghost and non-ghost subprograms",
9894 Error_Msg_Sloc := Sloc (Ghost_Id);
9895 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9897 Error_Msg_Sloc := Sloc (Subp);
9898 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9900 end Set_Inline_Flags;
9902 -- Start of processing for Process_Inline
9905 -- An inlined subprogram may grant access to its private enclosing
9906 -- context depending on the placement of its body. From elaboration
9907 -- point of view, the flow of execution may enter this private
9908 -- context, and then reach an external unit, thus producing a
9909 -- dependency on that external unit. For such a path to be properly
9910 -- discovered and encoded in the ALI file of the main unit, let the
9911 -- ABE mechanism process the body of the main unit, and encode all
9912 -- relevant invocation constructs and the relations between them.
9914 Mark_Save_Invocation_Graph_Of_Body;
9916 Check_No_Identifiers;
9917 Check_At_Least_N_Arguments (1);
9919 if Status = Enabled then
9920 Inline_Processing_Required := True;
9924 while Present (Assoc) loop
9925 Subp_Id := Get_Pragma_Arg (Assoc);
9929 if Is_Entity_Name (Subp_Id) then
9930 Subp := Entity (Subp_Id);
9932 if Subp = Any_Id then
9934 -- If previous error, avoid cascaded errors
9936 Check_Error_Detected;
9942 -- For the pragma case, climb homonym chain. This is
9943 -- what implements allowing the pragma in the renaming
9944 -- case, with the result applying to the ancestors, and
9945 -- also allows Inline to apply to all previous homonyms.
9947 if not From_Aspect_Specification (N) then
9948 while Present (Homonym (Subp))
9949 and then Scope (Homonym (Subp)) = Current_Scope
9951 Make_Inline (Homonym (Subp));
9952 Subp := Homonym (Subp);
9959 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9965 -- If the context is a package declaration, the pragma indicates
9966 -- that inlining will require the presence of the corresponding
9967 -- body. (this may be further refined).
9970 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9971 N_Package_Declaration
9973 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
9977 ----------------------------
9978 -- Process_Interface_Name --
9979 ----------------------------
9981 procedure Process_Interface_Name
9982 (Subprogram_Def : Entity_Id;
9989 String_Val : String_Id;
9991 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9992 -- SN is a string literal node for an interface name. This routine
9993 -- performs some minimal checks that the name is reasonable. In
9994 -- particular that no spaces or other obviously incorrect characters
9995 -- appear. This is only a warning, since any characters are allowed.
9997 ----------------------------------
9998 -- Check_Form_Of_Interface_Name --
9999 ----------------------------------
10001 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10002 S : constant String_Id := Strval (Expr_Value_S (SN));
10003 SL : constant Nat := String_Length (S);
10008 Error_Msg_N ("interface name cannot be null string", SN);
10011 for J in 1 .. SL loop
10012 C := Get_String_Char (S, J);
10014 -- Look for dubious character and issue unconditional warning.
10015 -- Definitely dubious if not in character range.
10017 if not In_Character_Range (C)
10019 -- Commas, spaces and (back)slashes are dubious
10021 or else Get_Character (C) = ','
10022 or else Get_Character (C) = '\'
10023 or else Get_Character (C) = ' '
10024 or else Get_Character (C) = '/'
10027 ("??interface name contains illegal character",
10028 Sloc (SN) + Source_Ptr (J));
10031 end Check_Form_Of_Interface_Name;
10033 -- Start of processing for Process_Interface_Name
10036 -- If we are looking at a pragma that comes from an aspect then it
10037 -- needs to have its corresponding aspect argument expressions
10038 -- analyzed in addition to the generated pragma so that aspects
10039 -- within generic units get properly resolved.
10041 if Present (Prag) and then From_Aspect_Specification (Prag) then
10043 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10051 -- Obtain all interfacing aspects used to construct the pragma
10053 Get_Interfacing_Aspects
10054 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10056 -- Analyze the expression of aspect External_Name
10058 if Present (EN) then
10059 Analyze (Expression (EN));
10062 -- Analyze the expressio of aspect Link_Name
10064 if Present (LN) then
10065 Analyze (Expression (LN));
10070 if No (Link_Arg) then
10071 if No (Ext_Arg) then
10074 elsif Chars (Ext_Arg) = Name_Link_Name then
10076 Link_Nam := Expression (Ext_Arg);
10079 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10080 Ext_Nam := Expression (Ext_Arg);
10085 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10086 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10087 Ext_Nam := Expression (Ext_Arg);
10088 Link_Nam := Expression (Link_Arg);
10091 -- Check expressions for external name and link name are static
10093 if Present (Ext_Nam) then
10094 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10095 Check_Form_Of_Interface_Name (Ext_Nam);
10097 -- Verify that external name is not the name of a local entity,
10098 -- which would hide the imported one and could lead to run-time
10099 -- surprises. The problem can only arise for entities declared in
10100 -- a package body (otherwise the external name is fully qualified
10101 -- and will not conflict).
10109 if Prag_Id = Pragma_Import then
10110 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10111 E := Entity_Id (Get_Name_Table_Int (Nam));
10113 if Nam /= Chars (Subprogram_Def)
10114 and then Present (E)
10115 and then not Is_Overloadable (E)
10116 and then Is_Immediately_Visible (E)
10117 and then not Is_Imported (E)
10118 and then Ekind (Scope (E)) = E_Package
10121 while Present (Par) loop
10122 if Nkind (Par) = N_Package_Body then
10123 Error_Msg_Sloc := Sloc (E);
10125 ("imported entity is hidden by & declared#",
10130 Par := Parent (Par);
10137 if Present (Link_Nam) then
10138 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10139 Check_Form_Of_Interface_Name (Link_Nam);
10142 -- If there is no link name, just set the external name
10144 if No (Link_Nam) then
10145 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10147 -- For the Link_Name case, the given literal is preceded by an
10148 -- asterisk, which indicates to GCC that the given name should be
10149 -- taken literally, and in particular that no prepending of
10150 -- underlines should occur, even in systems where this is the
10155 Store_String_Char (Get_Char_Code ('*'));
10156 String_Val := Strval (Expr_Value_S (Link_Nam));
10157 Store_String_Chars (String_Val);
10159 Make_String_Literal (Sloc (Link_Nam),
10160 Strval => End_String);
10163 -- Set the interface name. If the entity is a generic instance, use
10164 -- its alias, which is the callable entity.
10166 if Is_Generic_Instance (Subprogram_Def) then
10167 Set_Encoded_Interface_Name
10168 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10170 Set_Encoded_Interface_Name
10171 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10174 Check_Duplicated_Export_Name (Link_Nam);
10175 end Process_Interface_Name;
10177 -----------------------------------------
10178 -- Process_Interrupt_Or_Attach_Handler --
10179 -----------------------------------------
10181 procedure Process_Interrupt_Or_Attach_Handler is
10182 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10183 Prot_Typ : constant Entity_Id := Scope (Handler);
10186 -- A pragma that applies to a Ghost entity becomes Ghost for the
10187 -- purposes of legality checks and removal of ignored Ghost code.
10189 Mark_Ghost_Pragma (N, Handler);
10190 Set_Is_Interrupt_Handler (Handler);
10192 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10194 Record_Rep_Item (Prot_Typ, N);
10196 -- Chain the pragma on the contract for completeness
10198 Add_Contract_Item (N, Handler);
10199 end Process_Interrupt_Or_Attach_Handler;
10201 --------------------------------------------------
10202 -- Process_Restrictions_Or_Restriction_Warnings --
10203 --------------------------------------------------
10205 -- Note: some of the simple identifier cases were handled in par-prag,
10206 -- but it is harmless (and more straightforward) to simply handle all
10207 -- cases here, even if it means we repeat a bit of work in some cases.
10209 procedure Process_Restrictions_Or_Restriction_Warnings
10213 R_Id : Restriction_Id;
10219 -- Ignore all Restrictions pragmas in CodePeer mode
10221 if CodePeer_Mode then
10225 Check_Ada_83_Warning;
10226 Check_At_Least_N_Arguments (1);
10227 Check_Valid_Configuration_Pragma;
10230 while Present (Arg) loop
10232 Expr := Get_Pragma_Arg (Arg);
10234 -- Case of no restriction identifier present
10236 if Id = No_Name then
10237 if Nkind (Expr) /= N_Identifier then
10239 ("invalid form for restriction", Arg);
10244 (Process_Restriction_Synonyms (Expr));
10246 if R_Id not in All_Boolean_Restrictions then
10247 Error_Msg_Name_1 := Pname;
10249 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10251 -- Check for possible misspelling
10253 for J in Restriction_Id loop
10255 Rnm : constant String := Restriction_Id'Image (J);
10258 Name_Buffer (1 .. Rnm'Length) := Rnm;
10259 Name_Len := Rnm'Length;
10260 Set_Casing (All_Lower_Case);
10262 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10265 (Source_Index (Current_Sem_Unit)));
10266 Error_Msg_String (1 .. Rnm'Length) :=
10267 Name_Buffer (1 .. Name_Len);
10268 Error_Msg_Strlen := Rnm'Length;
10269 Error_Msg_N -- CODEFIX
10270 ("\possible misspelling of ""~""",
10271 Get_Pragma_Arg (Arg));
10280 if Implementation_Restriction (R_Id) then
10281 Check_Restriction (No_Implementation_Restrictions, Arg);
10284 -- Special processing for No_Elaboration_Code restriction
10286 if R_Id = No_Elaboration_Code then
10288 -- Restriction is only recognized within a configuration
10289 -- pragma file, or within a unit of the main extended
10290 -- program. Note: the test for Main_Unit is needed to
10291 -- properly include the case of configuration pragma files.
10293 if not (Current_Sem_Unit = Main_Unit
10294 or else In_Extended_Main_Source_Unit (N))
10298 -- Don't allow in a subunit unless already specified in
10301 elsif Nkind (Parent (N)) = N_Compilation_Unit
10302 and then Nkind (Unit (Parent (N))) = N_Subunit
10303 and then not Restriction_Active (No_Elaboration_Code)
10306 ("invalid specification of ""No_Elaboration_Code""",
10309 ("\restriction cannot be specified in a subunit", N);
10311 ("\unless also specified in body or spec", N);
10314 -- If we accept a No_Elaboration_Code restriction, then it
10315 -- needs to be added to the configuration restriction set so
10316 -- that we get proper application to other units in the main
10317 -- extended source as required.
10320 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10324 -- If this is a warning, then set the warning unless we already
10325 -- have a real restriction active (we never want a warning to
10326 -- override a real restriction).
10329 if not Restriction_Active (R_Id) then
10330 Set_Restriction (R_Id, N);
10331 Restriction_Warnings (R_Id) := True;
10334 -- If real restriction case, then set it and make sure that the
10335 -- restriction warning flag is off, since a real restriction
10336 -- always overrides a warning.
10339 Set_Restriction (R_Id, N);
10340 Restriction_Warnings (R_Id) := False;
10343 -- Check for obsolescent restrictions in Ada 2005 mode
10346 and then Ada_Version >= Ada_2005
10347 and then (R_Id = No_Asynchronous_Control
10349 R_Id = No_Unchecked_Deallocation
10351 R_Id = No_Unchecked_Conversion)
10353 Check_Restriction (No_Obsolescent_Features, N);
10356 -- A very special case that must be processed here: pragma
10357 -- Restrictions (No_Exceptions) turns off all run-time
10358 -- checking. This is a bit dubious in terms of the formal
10359 -- language definition, but it is what is intended by RM
10360 -- H.4(12). Restriction_Warnings never affects generated code
10361 -- so this is done only in the real restriction case.
10363 -- Atomic_Synchronization is not a real check, so it is not
10364 -- affected by this processing).
10366 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10367 -- run-time checks in CodePeer and GNATprove modes: we want to
10368 -- generate checks for analysis purposes, as set respectively
10369 -- by -gnatC and -gnatd.F
10372 and then not (CodePeer_Mode or GNATprove_Mode)
10373 and then R_Id = No_Exceptions
10375 for J in Scope_Suppress.Suppress'Range loop
10376 if J /= Atomic_Synchronization then
10377 Scope_Suppress.Suppress (J) := True;
10382 -- Case of No_Dependence => unit-name. Note that the parser
10383 -- already made the necessary entry in the No_Dependence table.
10385 elsif Id = Name_No_Dependence then
10386 if not OK_No_Dependence_Unit_Name (Expr) then
10390 -- Case of No_Specification_Of_Aspect => aspect-identifier
10392 elsif Id = Name_No_Specification_Of_Aspect then
10397 if Nkind (Expr) /= N_Identifier then
10400 A_Id := Get_Aspect_Id (Chars (Expr));
10403 if A_Id = No_Aspect then
10404 Error_Pragma_Arg ("invalid restriction name", Arg);
10406 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10410 -- Case of No_Use_Of_Attribute => attribute-identifier
10412 elsif Id = Name_No_Use_Of_Attribute then
10413 if Nkind (Expr) /= N_Identifier
10414 or else not Is_Attribute_Name (Chars (Expr))
10416 Error_Msg_N ("unknown attribute name??", Expr);
10419 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10422 -- Case of No_Use_Of_Entity => fully-qualified-name
10424 elsif Id = Name_No_Use_Of_Entity then
10426 -- Restriction is only recognized within a configuration
10427 -- pragma file, or within a unit of the main extended
10428 -- program. Note: the test for Main_Unit is needed to
10429 -- properly include the case of configuration pragma files.
10431 if Current_Sem_Unit = Main_Unit
10432 or else In_Extended_Main_Source_Unit (N)
10434 if not OK_No_Dependence_Unit_Name (Expr) then
10435 Error_Msg_N ("wrong form for entity name", Expr);
10437 Set_Restriction_No_Use_Of_Entity
10438 (Expr, Warn, No_Profile);
10442 -- Case of No_Use_Of_Pragma => pragma-identifier
10444 elsif Id = Name_No_Use_Of_Pragma then
10445 if Nkind (Expr) /= N_Identifier
10446 or else not Is_Pragma_Name (Chars (Expr))
10448 Error_Msg_N ("unknown pragma name??", Expr);
10450 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10453 -- All other cases of restriction identifier present
10456 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10457 Analyze_And_Resolve (Expr, Any_Integer);
10459 if R_Id not in All_Parameter_Restrictions then
10461 ("invalid restriction parameter identifier", Arg);
10463 elsif not Is_OK_Static_Expression (Expr) then
10464 Flag_Non_Static_Expr
10465 ("value must be static expression!", Expr);
10468 elsif not Is_Integer_Type (Etype (Expr))
10469 or else Expr_Value (Expr) < 0
10472 ("value must be non-negative integer", Arg);
10475 -- Restriction pragma is active
10477 Val := Expr_Value (Expr);
10479 if not UI_Is_In_Int_Range (Val) then
10481 ("pragma ignored, value too large??", Arg);
10484 -- Warning case. If the real restriction is active, then we
10485 -- ignore the request, since warning never overrides a real
10486 -- restriction. Otherwise we set the proper warning. Note that
10487 -- this circuit sets the warning again if it is already set,
10488 -- which is what we want, since the constant may have changed.
10491 if not Restriction_Active (R_Id) then
10493 (R_Id, N, Integer (UI_To_Int (Val)));
10494 Restriction_Warnings (R_Id) := True;
10497 -- Real restriction case, set restriction and make sure warning
10498 -- flag is off since real restriction always overrides warning.
10501 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
10502 Restriction_Warnings (R_Id) := False;
10508 end Process_Restrictions_Or_Restriction_Warnings;
10510 ---------------------------------
10511 -- Process_Suppress_Unsuppress --
10512 ---------------------------------
10514 -- Note: this procedure makes entries in the check suppress data
10515 -- structures managed by Sem. See spec of package Sem for full
10516 -- details on how we handle recording of check suppression.
10518 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10523 In_Package_Spec : constant Boolean :=
10524 Is_Package_Or_Generic_Package (Current_Scope)
10525 and then not In_Package_Body (Current_Scope);
10527 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10528 -- Used to suppress a single check on the given entity
10530 --------------------------------
10531 -- Suppress_Unsuppress_Echeck --
10532 --------------------------------
10534 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10536 -- Check for error of trying to set atomic synchronization for
10537 -- a non-atomic variable.
10539 if C = Atomic_Synchronization
10540 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10543 ("pragma & requires atomic type or variable",
10544 Pragma_Identifier (Original_Node (N)));
10547 Set_Checks_May_Be_Suppressed (E);
10549 if In_Package_Spec then
10550 Push_Global_Suppress_Stack_Entry
10553 Suppress => Suppress_Case);
10555 Push_Local_Suppress_Stack_Entry
10558 Suppress => Suppress_Case);
10561 -- If this is a first subtype, and the base type is distinct,
10562 -- then also set the suppress flags on the base type.
10564 if Is_First_Subtype (E) and then Etype (E) /= E then
10565 Suppress_Unsuppress_Echeck (Etype (E), C);
10567 end Suppress_Unsuppress_Echeck;
10569 -- Start of processing for Process_Suppress_Unsuppress
10572 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10573 -- on user code: we want to generate checks for analysis purposes, as
10574 -- set respectively by -gnatC and -gnatd.F
10576 if Comes_From_Source (N)
10577 and then (CodePeer_Mode or GNATprove_Mode)
10582 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10583 -- declarative part or a package spec (RM 11.5(5)).
10585 if not Is_Configuration_Pragma then
10586 Check_Is_In_Decl_Part_Or_Package_Spec;
10589 Check_At_Least_N_Arguments (1);
10590 Check_At_Most_N_Arguments (2);
10591 Check_No_Identifier (Arg1);
10592 Check_Arg_Is_Identifier (Arg1);
10594 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10596 if C = No_Check_Id then
10598 ("argument of pragma% is not valid check name", Arg1);
10601 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10603 if C = Elaboration_Check and then SPARK_Mode = On then
10605 ("Suppress of Elaboration_Check ignored in SPARK??",
10606 "\elaboration checking rules are statically enforced "
10607 & "(SPARK RM 7.7)", Arg1);
10610 -- One-argument case
10612 if Arg_Count = 1 then
10614 -- Make an entry in the local scope suppress table. This is the
10615 -- table that directly shows the current value of the scope
10616 -- suppress check for any check id value.
10618 if C = All_Checks then
10620 -- For All_Checks, we set all specific predefined checks with
10621 -- the exception of Elaboration_Check, which is handled
10622 -- specially because of not wanting All_Checks to have the
10623 -- effect of deactivating static elaboration order processing.
10624 -- Atomic_Synchronization is also not affected, since this is
10625 -- not a real check.
10627 for J in Scope_Suppress.Suppress'Range loop
10628 if J /= Elaboration_Check
10630 J /= Atomic_Synchronization
10632 Scope_Suppress.Suppress (J) := Suppress_Case;
10636 -- If not All_Checks, and predefined check, then set appropriate
10637 -- scope entry. Note that we will set Elaboration_Check if this
10638 -- is explicitly specified. Atomic_Synchronization is allowed
10639 -- only if internally generated and entity is atomic.
10641 elsif C in Predefined_Check_Id
10642 and then (not Comes_From_Source (N)
10643 or else C /= Atomic_Synchronization)
10645 Scope_Suppress.Suppress (C) := Suppress_Case;
10648 -- Also make an entry in the Local_Entity_Suppress table
10650 Push_Local_Suppress_Stack_Entry
10653 Suppress => Suppress_Case);
10655 -- Case of two arguments present, where the check is suppressed for
10656 -- a specified entity (given as the second argument of the pragma)
10659 -- This is obsolescent in Ada 2005 mode
10661 if Ada_Version >= Ada_2005 then
10662 Check_Restriction (No_Obsolescent_Features, Arg2);
10665 Check_Optional_Identifier (Arg2, Name_On);
10666 E_Id := Get_Pragma_Arg (Arg2);
10669 if not Is_Entity_Name (E_Id) then
10671 ("second argument of pragma% must be entity name", Arg2);
10674 E := Entity (E_Id);
10680 -- A pragma that applies to a Ghost entity becomes Ghost for the
10681 -- purposes of legality checks and removal of ignored Ghost code.
10683 Mark_Ghost_Pragma (N, E);
10685 -- Enforce RM 11.5(7) which requires that for a pragma that
10686 -- appears within a package spec, the named entity must be
10687 -- within the package spec. We allow the package name itself
10688 -- to be mentioned since that makes sense, although it is not
10689 -- strictly allowed by 11.5(7).
10692 and then E /= Current_Scope
10693 and then Scope (E) /= Current_Scope
10696 ("entity in pragma% is not in package spec (RM 11.5(7))",
10700 -- Loop through homonyms. As noted below, in the case of a package
10701 -- spec, only homonyms within the package spec are considered.
10704 Suppress_Unsuppress_Echeck (E, C);
10706 if Is_Generic_Instance (E)
10707 and then Is_Subprogram (E)
10708 and then Present (Alias (E))
10710 Suppress_Unsuppress_Echeck (Alias (E), C);
10713 -- Move to next homonym if not aspect spec case
10715 exit when From_Aspect_Specification (N);
10719 -- If we are within a package specification, the pragma only
10720 -- applies to homonyms in the same scope.
10722 exit when In_Package_Spec
10723 and then Scope (E) /= Current_Scope;
10726 end Process_Suppress_Unsuppress;
10728 -------------------------------
10729 -- Record_Independence_Check --
10730 -------------------------------
10732 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10733 pragma Unreferenced (N, E);
10735 -- For GCC back ends the validation is done a priori
10736 -- ??? This code is dead, might be useful in the future
10738 -- if not AAMP_On_Target then
10742 -- Independence_Checks.Append ((N, E));
10745 end Record_Independence_Check;
10751 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10753 if Is_Imported (E) then
10755 ("cannot export entity& that was previously imported", Arg);
10757 elsif Present (Address_Clause (E))
10758 and then not Relaxed_RM_Semantics
10761 ("cannot export entity& that has an address clause", Arg);
10764 Set_Is_Exported (E);
10766 -- Generate a reference for entity explicitly, because the
10767 -- identifier may be overloaded and name resolution will not
10770 Generate_Reference (E, Arg);
10772 -- Deal with exporting non-library level entity
10774 if not Is_Library_Level_Entity (E) then
10776 -- Not allowed at all for subprograms
10778 if Is_Subprogram (E) then
10779 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10781 -- Otherwise set public and statically allocated
10785 Set_Is_Statically_Allocated (E);
10787 -- Warn if the corresponding W flag is set
10789 if Warn_On_Export_Import
10791 -- Only do this for something that was in the source. Not
10792 -- clear if this can be False now (there used for sure to be
10793 -- cases on some systems where it was False), but anyway the
10794 -- test is harmless if not needed, so it is retained.
10796 and then Comes_From_Source (Arg)
10799 ("?x?& has been made static as a result of Export",
10802 ("\?x?this usage is non-standard and non-portable",
10808 if Warn_On_Export_Import and then Is_Type (E) then
10809 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10812 if Warn_On_Export_Import and Inside_A_Generic then
10814 ("all instances of& will have the same external name?x?",
10819 ----------------------------------------------
10820 -- Set_Extended_Import_Export_External_Name --
10821 ----------------------------------------------
10823 procedure Set_Extended_Import_Export_External_Name
10824 (Internal_Ent : Entity_Id;
10825 Arg_External : Node_Id)
10827 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10828 New_Name : Node_Id;
10831 if No (Arg_External) then
10835 Check_Arg_Is_External_Name (Arg_External);
10837 if Nkind (Arg_External) = N_String_Literal then
10838 if String_Length (Strval (Arg_External)) = 0 then
10841 New_Name := Adjust_External_Name_Case (Arg_External);
10844 elsif Nkind (Arg_External) = N_Identifier then
10845 New_Name := Get_Default_External_Name (Arg_External);
10847 -- Check_Arg_Is_External_Name should let through only identifiers and
10848 -- string literals or static string expressions (which are folded to
10849 -- string literals).
10852 raise Program_Error;
10855 -- If we already have an external name set (by a prior normal Import
10856 -- or Export pragma), then the external names must match
10858 if Present (Interface_Name (Internal_Ent)) then
10860 -- Ignore mismatching names in CodePeer mode, to support some
10861 -- old compilers which would export the same procedure under
10862 -- different names, e.g:
10864 -- pragma Export_Procedure (P, "a");
10865 -- pragma Export_Procedure (P, "b");
10867 if CodePeer_Mode then
10871 Check_Matching_Internal_Names : declare
10872 S1 : constant String_Id := Strval (Old_Name);
10873 S2 : constant String_Id := Strval (New_Name);
10875 procedure Mismatch;
10876 pragma No_Return (Mismatch);
10877 -- Called if names do not match
10883 procedure Mismatch is
10885 Error_Msg_Sloc := Sloc (Old_Name);
10887 ("external name does not match that given #",
10891 -- Start of processing for Check_Matching_Internal_Names
10894 if String_Length (S1) /= String_Length (S2) then
10898 for J in 1 .. String_Length (S1) loop
10899 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10904 end Check_Matching_Internal_Names;
10906 -- Otherwise set the given name
10909 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10910 Check_Duplicated_Export_Name (New_Name);
10912 end Set_Extended_Import_Export_External_Name;
10918 procedure Set_Imported (E : Entity_Id) is
10920 -- Error message if already imported or exported
10922 if Is_Exported (E) or else Is_Imported (E) then
10924 -- Error if being set Exported twice
10926 if Is_Exported (E) then
10927 Error_Msg_NE ("entity& was previously exported", N, E);
10929 -- Ignore error in CodePeer mode where we treat all imported
10930 -- subprograms as unknown.
10932 elsif CodePeer_Mode then
10935 -- OK if Import/Interface case
10937 elsif Import_Interface_Present (N) then
10940 -- Error if being set Imported twice
10943 Error_Msg_NE ("entity& was previously imported", N, E);
10946 Error_Msg_Name_1 := Pname;
10948 ("\(pragma% applies to all previous entities)", N);
10950 Error_Msg_Sloc := Sloc (E);
10951 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10953 -- Here if not previously imported or exported, OK to import
10956 Set_Is_Imported (E);
10958 -- For subprogram, set Import_Pragma field
10960 if Is_Subprogram (E) then
10961 Set_Import_Pragma (E, N);
10964 -- If the entity is an object that is not at the library level,
10965 -- then it is statically allocated. We do not worry about objects
10966 -- with address clauses in this context since they are not really
10967 -- imported in the linker sense.
10970 and then not Is_Library_Level_Entity (E)
10971 and then No (Address_Clause (E))
10973 Set_Is_Statically_Allocated (E);
10980 -------------------------
10981 -- Set_Mechanism_Value --
10982 -------------------------
10984 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10985 -- analyzed, since it is semantic nonsense), so we get it in the exact
10986 -- form created by the parser.
10988 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10989 procedure Bad_Mechanism;
10990 pragma No_Return (Bad_Mechanism);
10991 -- Signal bad mechanism name
10993 -------------------
10994 -- Bad_Mechanism --
10995 -------------------
10997 procedure Bad_Mechanism is
10999 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11002 -- Start of processing for Set_Mechanism_Value
11005 if Mechanism (Ent) /= Default_Mechanism then
11007 ("mechanism for & has already been set", Mech_Name, Ent);
11010 -- MECHANISM_NAME ::= value | reference
11012 if Nkind (Mech_Name) = N_Identifier then
11013 if Chars (Mech_Name) = Name_Value then
11014 Set_Mechanism (Ent, By_Copy);
11017 elsif Chars (Mech_Name) = Name_Reference then
11018 Set_Mechanism (Ent, By_Reference);
11021 elsif Chars (Mech_Name) = Name_Copy then
11023 ("bad mechanism name, Value assumed", Mech_Name);
11032 end Set_Mechanism_Value;
11034 --------------------------
11035 -- Set_Rational_Profile --
11036 --------------------------
11038 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11039 -- extension to the semantics of renaming declarations.
11041 procedure Set_Rational_Profile is
11043 Implicit_Packing := True;
11044 Overriding_Renamings := True;
11045 Use_VADS_Size := True;
11046 end Set_Rational_Profile;
11048 ---------------------------
11049 -- Set_Ravenscar_Profile --
11050 ---------------------------
11052 -- The tasks to be done here are
11054 -- Set required policies
11056 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11057 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11058 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11059 -- (For GNAT_Ravenscar_EDF profile)
11060 -- pragma Locking_Policy (Ceiling_Locking)
11062 -- Set Detect_Blocking mode
11064 -- Set required restrictions (see System.Rident for detailed list)
11066 -- Set the No_Dependence rules
11067 -- No_Dependence => Ada.Asynchronous_Task_Control
11068 -- No_Dependence => Ada.Calendar
11069 -- No_Dependence => Ada.Execution_Time.Group_Budget
11070 -- No_Dependence => Ada.Execution_Time.Timers
11071 -- No_Dependence => Ada.Task_Attributes
11072 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11074 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11075 procedure Set_Error_Msg_To_Profile_Name;
11076 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11079 -----------------------------------
11080 -- Set_Error_Msg_To_Profile_Name --
11081 -----------------------------------
11083 procedure Set_Error_Msg_To_Profile_Name is
11084 Prof_Nam : constant Node_Id :=
11086 (First (Pragma_Argument_Associations (N)));
11089 Get_Name_String (Chars (Prof_Nam));
11090 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11091 Error_Msg_Strlen := Name_Len;
11092 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11093 end Set_Error_Msg_To_Profile_Name;
11102 Profile_Dispatching_Policy : Character;
11104 -- Start of processing for Set_Ravenscar_Profile
11107 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11109 if Profile = GNAT_Ravenscar_EDF then
11110 Profile_Dispatching_Policy := 'E';
11112 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11115 Profile_Dispatching_Policy := 'F';
11118 if Task_Dispatching_Policy /= ' '
11119 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11121 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11122 Set_Error_Msg_To_Profile_Name;
11123 Error_Pragma ("Profile (~) incompatible with policy#");
11125 -- Set the FIFO_Within_Priorities policy, but always preserve
11126 -- System_Location since we like the error message with the run time
11130 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11132 if Task_Dispatching_Policy_Sloc /= System_Location then
11133 Task_Dispatching_Policy_Sloc := Loc;
11137 -- pragma Locking_Policy (Ceiling_Locking)
11139 if Locking_Policy /= ' '
11140 and then Locking_Policy /= 'C'
11142 Error_Msg_Sloc := Locking_Policy_Sloc;
11143 Set_Error_Msg_To_Profile_Name;
11144 Error_Pragma ("Profile (~) incompatible with policy#");
11146 -- Set the Ceiling_Locking policy, but preserve System_Location since
11147 -- we like the error message with the run time name.
11150 Locking_Policy := 'C';
11152 if Locking_Policy_Sloc /= System_Location then
11153 Locking_Policy_Sloc := Loc;
11157 -- pragma Detect_Blocking
11159 Detect_Blocking := True;
11161 -- Set the corresponding restrictions
11163 Set_Profile_Restrictions
11164 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11166 -- Set the No_Dependence restrictions
11168 -- The following No_Dependence restrictions:
11169 -- No_Dependence => Ada.Asynchronous_Task_Control
11170 -- No_Dependence => Ada.Calendar
11171 -- No_Dependence => Ada.Task_Attributes
11172 -- are already set by previous call to Set_Profile_Restrictions.
11174 -- Set the following restrictions which were added to Ada 2005:
11175 -- No_Dependence => Ada.Execution_Time.Group_Budget
11176 -- No_Dependence => Ada.Execution_Time.Timers
11178 if Ada_Version >= Ada_2005 then
11179 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11180 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
11183 Make_Selected_Component
11186 Selector_Name => Sel_Id);
11188 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
11191 Make_Selected_Component
11194 Selector_Name => Sel_Id);
11196 Set_Restriction_No_Dependence
11198 Warn => Treat_Restrictions_As_Warnings,
11199 Profile => Ravenscar);
11201 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
11204 Make_Selected_Component
11207 Selector_Name => Sel_Id);
11209 Set_Restriction_No_Dependence
11211 Warn => Treat_Restrictions_As_Warnings,
11212 Profile => Ravenscar);
11215 -- Set the following restriction which was added to Ada 2012 (see
11217 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11219 if Ada_Version >= Ada_2012 then
11220 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
11221 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
11224 Make_Selected_Component
11227 Selector_Name => Sel_Id);
11229 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
11232 Make_Selected_Component
11235 Selector_Name => Sel_Id);
11237 Set_Restriction_No_Dependence
11239 Warn => Treat_Restrictions_As_Warnings,
11240 Profile => Ravenscar);
11242 end Set_Ravenscar_Profile;
11244 -----------------------------------
11245 -- Validate_Acc_Condition_Clause --
11246 -----------------------------------
11248 procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is
11250 Analyze_And_Resolve (Clause);
11252 if not Is_Boolean_Type (Etype (Clause)) then
11253 Error_Pragma ("expected a boolean");
11255 end Validate_Acc_Condition_Clause;
11257 ------------------------------
11258 -- Validate_Acc_Data_Clause --
11259 ------------------------------
11261 procedure Validate_Acc_Data_Clause (Clause : Node_Id) is
11265 Expr := Acc_First (Clause);
11266 while Present (Expr) loop
11267 if Nkind (Expr) /= N_Identifier then
11268 Error_Pragma ("expected an identifer");
11271 Analyze_And_Resolve (Expr);
11273 Expr := Acc_Next (Expr);
11275 end Validate_Acc_Data_Clause;
11277 ----------------------------------
11278 -- Validate_Acc_Int_Expr_Clause --
11279 ----------------------------------
11281 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is
11283 Analyze_And_Resolve (Clause);
11285 if not Is_Integer_Type (Etype (Clause)) then
11286 Error_Pragma_Arg ("expected an integer", Clause);
11288 end Validate_Acc_Int_Expr_Clause;
11290 ---------------------------------------
11291 -- Validate_Acc_Int_Expr_List_Clause --
11292 ---------------------------------------
11294 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is
11298 Expr := Acc_First (Clause);
11299 while Present (Expr) loop
11300 Analyze_And_Resolve (Expr);
11302 if not Is_Integer_Type (Etype (Expr)) then
11303 Error_Pragma ("expected an integer");
11306 Expr := Acc_Next (Expr);
11308 end Validate_Acc_Int_Expr_List_Clause;
11310 --------------------------------
11311 -- Validate_Acc_Loop_Collapse --
11312 --------------------------------
11314 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is
11316 Par_Loop : Node_Id;
11320 -- Make sure the argument is a positive integer
11322 Analyze_And_Resolve (Clause);
11324 Count := Static_Integer (Clause);
11325 if Count = No_Uint or else Count < 1 then
11326 Error_Pragma_Arg ("expected a positive integer", Clause);
11329 -- Then, make sure we have at least Count-1 tightly-nested loops
11330 -- (i.e. loops with no statements in between).
11332 Par_Loop := Parent (Parent (Parent (Clause)));
11333 Stmt := First (Statements (Par_Loop));
11335 -- Skip first pragmas in the parent loop
11337 while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop
11341 if not Present (Next (Stmt)) then
11342 while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop
11343 Stmt := First (Statements (Stmt));
11344 exit when Present (Next (Stmt));
11346 Count := Count - 1;
11352 ("Collapse argument too high or loops not tightly nested",
11355 end Validate_Acc_Loop_Collapse;
11357 ----------------------------
11358 -- Validate_Acc_Loop_Gang --
11359 ----------------------------
11361 procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is
11363 Error_Pragma_Arg ("Loop_Gang not implemented", Clause);
11364 end Validate_Acc_Loop_Gang;
11366 ------------------------------
11367 -- Validate_Acc_Loop_Vector --
11368 ------------------------------
11370 procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is
11372 Error_Pragma_Arg ("Loop_Vector not implemented", Clause);
11373 end Validate_Acc_Loop_Vector;
11375 -------------------------------
11376 -- Validate_Acc_Loop_Worker --
11377 -------------------------------
11379 procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is
11381 Error_Pragma_Arg ("Loop_Worker not implemented", Clause);
11382 end Validate_Acc_Loop_Worker;
11384 ---------------------------------
11385 -- Validate_Acc_Name_Reduction --
11386 ---------------------------------
11388 procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is
11390 -- ??? On top of the following operations, the OpenAcc spec adds the
11391 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11392 -- ".neqv" for Fortran. Can we, should we and how do we support them
11395 type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op);
11397 function To_Reduction_Op (Op : String) return Reduction_Op;
11398 -- Convert operator Op described by a String into its corresponding
11399 -- enumeration value.
11401 ---------------------
11402 -- To_Reduction_Op --
11403 ---------------------
11405 function To_Reduction_Op (Op : String) return Reduction_Op is
11410 elsif Op = "*" then
11413 elsif Op = "max" then
11416 elsif Op = "min" then
11419 elsif Op = "and" then
11422 elsif Op = "or" then
11426 Error_Pragma ("unsuported reduction operation");
11428 end To_Reduction_Op;
11432 Seen : constant Elist_Id := New_Elmt_List;
11435 Reduc_Op : Node_Id;
11436 Reduc_Var : Node_Id;
11438 -- Start of processing for Validate_Acc_Name_Reduction
11441 -- Reduction operations appear in the following form:
11442 -- ("+" => (a, b), "*" => c)
11444 Expr := First (Component_Associations (Clause));
11445 while Present (Expr) loop
11446 Reduc_Op := First (Choices (Expr));
11447 String_To_Name_Buffer (Strval (Reduc_Op));
11449 case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
11455 Reduc_Var := Acc_First (Expression (Expr));
11456 while Present (Reduc_Var) loop
11457 Analyze_And_Resolve (Reduc_Var);
11459 if Contains (Seen, Entity (Reduc_Var)) then
11460 Error_Pragma ("variable used in multiple reductions");
11463 if Nkind (Reduc_Var) /= N_Identifier
11464 or not Is_Numeric_Type (Etype (Reduc_Var))
11467 ("expected an identifier for a Numeric");
11470 Append_Elmt (Entity (Reduc_Var), Seen);
11473 Reduc_Var := Acc_Next (Reduc_Var);
11479 Reduc_Var := Acc_First (Expression (Expr));
11480 while Present (Reduc_Var) loop
11481 Analyze_And_Resolve (Reduc_Var);
11483 if Contains (Seen, Entity (Reduc_Var)) then
11484 Error_Pragma ("variable used in multiple reductions");
11487 if Nkind (Reduc_Var) /= N_Identifier
11488 or not Is_Boolean_Type (Etype (Reduc_Var))
11491 ("expected a variable of type boolean");
11494 Append_Elmt (Entity (Reduc_Var), Seen);
11497 Reduc_Var := Acc_Next (Reduc_Var);
11503 end Validate_Acc_Name_Reduction;
11505 -----------------------------------
11506 -- Validate_Acc_Size_Expressions --
11507 -----------------------------------
11509 procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is
11510 function Validate_Size_Expr (Expr : Node_Id) return Boolean;
11511 -- A size expr is either an integer expression or "*"
11513 ------------------------
11514 -- Validate_Size_Expr --
11515 ------------------------
11517 function Validate_Size_Expr (Expr : Node_Id) return Boolean is
11519 if Nkind (Expr) = N_Operator_Symbol then
11520 return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*');
11523 Analyze_And_Resolve (Expr);
11525 return Is_Integer_Type (Etype (Expr));
11526 end Validate_Size_Expr;
11532 -- Start of processing for Validate_Acc_Size_Expressions
11535 Expr := Acc_First (Clause);
11536 while Present (Expr) loop
11537 if not Validate_Size_Expr (Expr) then
11539 ("Size expressions should be either integers or '*'");
11542 Expr := Acc_Next (Expr);
11544 end Validate_Acc_Size_Expressions;
11546 -- Start of processing for Analyze_Pragma
11549 -- The following code is a defense against recursion. Not clear that
11550 -- this can happen legitimately, but perhaps some error situations can
11551 -- cause it, and we did see this recursion during testing.
11553 if Analyzed (N) then
11559 Check_Restriction_No_Use_Of_Pragma (N);
11561 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11562 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11564 if Should_Ignore_Pragma_Sem (N)
11565 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11566 and then Ignore_Rep_Clauses)
11571 -- Deal with unrecognized pragma
11573 if not Is_Pragma_Name (Pname) then
11574 if Warn_On_Unrecognized_Pragma then
11575 Error_Msg_Name_1 := Pname;
11576 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11578 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11579 if Is_Bad_Spelling_Of (Pname, PN) then
11580 Error_Msg_Name_1 := PN;
11581 Error_Msg_N -- CODEFIX
11582 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11591 -- Here to start processing for recognized pragma
11593 Pname := Original_Aspect_Pragma_Name (N);
11595 -- Capture setting of Opt.Uneval_Old
11597 case Opt.Uneval_Old is
11599 Set_Uneval_Old_Accept (N);
11605 Set_Uneval_Old_Warn (N);
11608 raise Program_Error;
11611 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11612 -- is already set, indicating that we have already checked the policy
11613 -- at the right point. This happens for example in the case of a pragma
11614 -- that is derived from an Aspect.
11616 if Is_Ignored (N) or else Is_Checked (N) then
11619 -- For a pragma that is a rewriting of another pragma, copy the
11620 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11622 elsif Is_Rewrite_Substitution (N)
11623 and then Nkind (Original_Node (N)) = N_Pragma
11625 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11626 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11628 -- Otherwise query the applicable policy at this point
11631 Check_Applicable_Policy (N);
11633 -- If pragma is disabled, rewrite as NULL and skip analysis
11635 if Is_Disabled (N) then
11636 Rewrite (N, Make_Null_Statement (Loc));
11642 -- Preset arguments
11650 if Present (Pragma_Argument_Associations (N)) then
11651 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11652 Arg1 := First (Pragma_Argument_Associations (N));
11654 if Present (Arg1) then
11655 Arg2 := Next (Arg1);
11657 if Present (Arg2) then
11658 Arg3 := Next (Arg2);
11660 if Present (Arg3) then
11661 Arg4 := Next (Arg3);
11667 -- An enumeration type defines the pragmas that are supported by the
11668 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11669 -- into the corresponding enumeration value for the following case.
11677 -- pragma Abort_Defer;
11679 when Pragma_Abort_Defer =>
11681 Check_Arg_Count (0);
11683 -- The only required semantic processing is to check the
11684 -- placement. This pragma must appear at the start of the
11685 -- statement sequence of a handled sequence of statements.
11687 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11688 or else N /= First (Statements (Parent (N)))
11693 --------------------
11694 -- Abstract_State --
11695 --------------------
11697 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11699 -- ABSTRACT_STATE_LIST ::=
11701 -- | STATE_NAME_WITH_OPTIONS
11702 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11704 -- STATE_NAME_WITH_OPTIONS ::=
11706 -- | (STATE_NAME with OPTION_LIST)
11708 -- OPTION_LIST ::= OPTION {, OPTION}
11712 -- | NAME_VALUE_OPTION
11714 -- SIMPLE_OPTION ::= Ghost | Synchronous
11716 -- NAME_VALUE_OPTION ::=
11717 -- Part_Of => ABSTRACT_STATE
11718 -- | External [=> EXTERNAL_PROPERTY_LIST]
11720 -- EXTERNAL_PROPERTY_LIST ::=
11721 -- EXTERNAL_PROPERTY
11722 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11724 -- EXTERNAL_PROPERTY ::=
11725 -- Async_Readers [=> boolean_EXPRESSION]
11726 -- | Async_Writers [=> boolean_EXPRESSION]
11727 -- | Effective_Reads [=> boolean_EXPRESSION]
11728 -- | Effective_Writes [=> boolean_EXPRESSION]
11729 -- others => boolean_EXPRESSION
11731 -- STATE_NAME ::= defining_identifier
11733 -- ABSTRACT_STATE ::= name
11735 -- Characteristics:
11737 -- * Analysis - The annotation is fully analyzed immediately upon
11738 -- elaboration as it cannot forward reference entities.
11740 -- * Expansion - None.
11742 -- * Template - The annotation utilizes the generic template of the
11743 -- related package declaration.
11745 -- * Globals - The annotation cannot reference global entities.
11747 -- * Instance - The annotation is instantiated automatically when
11748 -- the related generic package is instantiated.
11750 when Pragma_Abstract_State => Abstract_State : declare
11751 Missing_Parentheses : Boolean := False;
11752 -- Flag set when a state declaration with options is not properly
11755 -- Flags used to verify the consistency of states
11757 Non_Null_Seen : Boolean := False;
11758 Null_Seen : Boolean := False;
11760 procedure Analyze_Abstract_State
11762 Pack_Id : Entity_Id);
11763 -- Verify the legality of a single state declaration. Create and
11764 -- decorate a state abstraction entity and introduce it into the
11765 -- visibility chain. Pack_Id denotes the entity or the related
11766 -- package where pragma Abstract_State appears.
11768 procedure Malformed_State_Error (State : Node_Id);
11769 -- Emit an error concerning the illegal declaration of abstract
11770 -- state State. This routine diagnoses syntax errors that lead to
11771 -- a different parse tree. The error is issued regardless of the
11772 -- SPARK mode in effect.
11774 ----------------------------
11775 -- Analyze_Abstract_State --
11776 ----------------------------
11778 procedure Analyze_Abstract_State
11780 Pack_Id : Entity_Id)
11782 -- Flags used to verify the consistency of options
11784 AR_Seen : Boolean := False;
11785 AW_Seen : Boolean := False;
11786 ER_Seen : Boolean := False;
11787 EW_Seen : Boolean := False;
11788 External_Seen : Boolean := False;
11789 Ghost_Seen : Boolean := False;
11790 Others_Seen : Boolean := False;
11791 Part_Of_Seen : Boolean := False;
11792 Synchronous_Seen : Boolean := False;
11794 -- Flags used to store the static value of all external states'
11797 AR_Val : Boolean := False;
11798 AW_Val : Boolean := False;
11799 ER_Val : Boolean := False;
11800 EW_Val : Boolean := False;
11802 State_Id : Entity_Id := Empty;
11803 -- The entity to be generated for the current state declaration
11805 procedure Analyze_External_Option (Opt : Node_Id);
11806 -- Verify the legality of option External
11808 procedure Analyze_External_Property
11810 Expr : Node_Id := Empty);
11811 -- Verify the legailty of a single external property. Prop
11812 -- denotes the external property. Expr is the expression used
11813 -- to set the property.
11815 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11816 -- Verify the legality of option Part_Of
11818 procedure Check_Duplicate_Option
11820 Status : in out Boolean);
11821 -- Flag Status denotes whether a particular option has been
11822 -- seen while processing a state. This routine verifies that
11823 -- Opt is not a duplicate option and sets the flag Status
11824 -- (SPARK RM 7.1.4(1)).
11826 procedure Check_Duplicate_Property
11828 Status : in out Boolean);
11829 -- Flag Status denotes whether a particular property has been
11830 -- seen while processing option External. This routine verifies
11831 -- that Prop is not a duplicate property and sets flag Status.
11832 -- Opt is not a duplicate property and sets the flag Status.
11833 -- (SPARK RM 7.1.4(2))
11835 procedure Check_Ghost_Synchronous;
11836 -- Ensure that the abstract state is not subject to both Ghost
11837 -- and Synchronous simple options. Emit an error if this is the
11840 procedure Create_Abstract_State
11844 Is_Null : Boolean);
11845 -- Generate an abstract state entity with name Nam and enter it
11846 -- into visibility. Decl is the "declaration" of the state as
11847 -- it appears in pragma Abstract_State. Loc is the location of
11848 -- the related state "declaration". Flag Is_Null should be set
11849 -- when the associated Abstract_State pragma defines a null
11852 -----------------------------
11853 -- Analyze_External_Option --
11854 -----------------------------
11856 procedure Analyze_External_Option (Opt : Node_Id) is
11857 Errors : constant Nat := Serious_Errors_Detected;
11859 Props : Node_Id := Empty;
11862 if Nkind (Opt) = N_Component_Association then
11863 Props := Expression (Opt);
11866 -- External state with properties
11868 if Present (Props) then
11870 -- Multiple properties appear as an aggregate
11872 if Nkind (Props) = N_Aggregate then
11874 -- Simple property form
11876 Prop := First (Expressions (Props));
11877 while Present (Prop) loop
11878 Analyze_External_Property (Prop);
11882 -- Property with expression form
11884 Prop := First (Component_Associations (Props));
11885 while Present (Prop) loop
11886 Analyze_External_Property
11887 (Prop => First (Choices (Prop)),
11888 Expr => Expression (Prop));
11896 Analyze_External_Property (Props);
11899 -- An external state defined without any properties defaults
11900 -- all properties to True.
11909 -- Once all external properties have been processed, verify
11910 -- their mutual interaction. Do not perform the check when
11911 -- at least one of the properties is illegal as this will
11912 -- produce a bogus error.
11914 if Errors = Serious_Errors_Detected then
11915 Check_External_Properties
11916 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11918 end Analyze_External_Option;
11920 -------------------------------
11921 -- Analyze_External_Property --
11922 -------------------------------
11924 procedure Analyze_External_Property
11926 Expr : Node_Id := Empty)
11928 Expr_Val : Boolean;
11931 -- Check the placement of "others" (if available)
11933 if Nkind (Prop) = N_Others_Choice then
11934 if Others_Seen then
11936 ("only one others choice allowed in option External",
11939 Others_Seen := True;
11942 elsif Others_Seen then
11944 ("others must be the last property in option External",
11947 -- The only remaining legal options are the four predefined
11948 -- external properties.
11950 elsif Nkind (Prop) = N_Identifier
11951 and then Nam_In (Chars (Prop), Name_Async_Readers,
11952 Name_Async_Writers,
11953 Name_Effective_Reads,
11954 Name_Effective_Writes)
11958 -- Otherwise the construct is not a valid property
11961 SPARK_Msg_N ("invalid external state property", Prop);
11965 -- Ensure that the expression of the external state property
11966 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11968 if Present (Expr) then
11969 Analyze_And_Resolve (Expr, Standard_Boolean);
11971 if Is_OK_Static_Expression (Expr) then
11972 Expr_Val := Is_True (Expr_Value (Expr));
11975 ("expression of external state property must be "
11980 -- The lack of expression defaults the property to True
11986 -- Named properties
11988 if Nkind (Prop) = N_Identifier then
11989 if Chars (Prop) = Name_Async_Readers then
11990 Check_Duplicate_Property (Prop, AR_Seen);
11991 AR_Val := Expr_Val;
11993 elsif Chars (Prop) = Name_Async_Writers then
11994 Check_Duplicate_Property (Prop, AW_Seen);
11995 AW_Val := Expr_Val;
11997 elsif Chars (Prop) = Name_Effective_Reads then
11998 Check_Duplicate_Property (Prop, ER_Seen);
11999 ER_Val := Expr_Val;
12002 Check_Duplicate_Property (Prop, EW_Seen);
12003 EW_Val := Expr_Val;
12006 -- The handling of property "others" must take into account
12007 -- all other named properties that have been encountered so
12008 -- far. Only those that have not been seen are affected by
12012 if not AR_Seen then
12013 AR_Val := Expr_Val;
12016 if not AW_Seen then
12017 AW_Val := Expr_Val;
12020 if not ER_Seen then
12021 ER_Val := Expr_Val;
12024 if not EW_Seen then
12025 EW_Val := Expr_Val;
12028 end Analyze_External_Property;
12030 ----------------------------
12031 -- Analyze_Part_Of_Option --
12032 ----------------------------
12034 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
12035 Encap : constant Node_Id := Expression (Opt);
12036 Constits : Elist_Id;
12037 Encap_Id : Entity_Id;
12041 Check_Duplicate_Option (Opt, Part_Of_Seen);
12044 (Indic => First (Choices (Opt)),
12045 Item_Id => State_Id,
12047 Encap_Id => Encap_Id,
12050 -- The Part_Of indicator transforms the abstract state into
12051 -- a constituent of the encapsulating state or single
12052 -- concurrent type.
12055 pragma Assert (Present (Encap_Id));
12056 Constits := Part_Of_Constituents (Encap_Id);
12058 if No (Constits) then
12059 Constits := New_Elmt_List;
12060 Set_Part_Of_Constituents (Encap_Id, Constits);
12063 Append_Elmt (State_Id, Constits);
12064 Set_Encapsulating_State (State_Id, Encap_Id);
12066 end Analyze_Part_Of_Option;
12068 ----------------------------
12069 -- Check_Duplicate_Option --
12070 ----------------------------
12072 procedure Check_Duplicate_Option
12074 Status : in out Boolean)
12078 SPARK_Msg_N ("duplicate state option", Opt);
12082 end Check_Duplicate_Option;
12084 ------------------------------
12085 -- Check_Duplicate_Property --
12086 ------------------------------
12088 procedure Check_Duplicate_Property
12090 Status : in out Boolean)
12094 SPARK_Msg_N ("duplicate external property", Prop);
12098 end Check_Duplicate_Property;
12100 -----------------------------
12101 -- Check_Ghost_Synchronous --
12102 -----------------------------
12104 procedure Check_Ghost_Synchronous is
12106 -- A synchronized abstract state cannot be Ghost and vice
12107 -- versa (SPARK RM 6.9(19)).
12109 if Ghost_Seen and Synchronous_Seen then
12110 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12112 end Check_Ghost_Synchronous;
12114 ---------------------------
12115 -- Create_Abstract_State --
12116 ---------------------------
12118 procedure Create_Abstract_State
12125 -- The abstract state may be semi-declared when the related
12126 -- package was withed through a limited with clause. In that
12127 -- case reuse the entity to fully declare the state.
12129 if Present (Decl) and then Present (Entity (Decl)) then
12130 State_Id := Entity (Decl);
12132 -- Otherwise the elaboration of pragma Abstract_State
12133 -- declares the state.
12136 State_Id := Make_Defining_Identifier (Loc, Nam);
12138 if Present (Decl) then
12139 Set_Entity (Decl, State_Id);
12143 -- Null states never come from source
12145 Set_Comes_From_Source (State_Id, not Is_Null);
12146 Set_Parent (State_Id, State);
12147 Set_Ekind (State_Id, E_Abstract_State);
12148 Set_Etype (State_Id, Standard_Void_Type);
12149 Set_Encapsulating_State (State_Id, Empty);
12151 -- Set the SPARK mode from the current context
12153 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12154 Set_SPARK_Pragma_Inherited (State_Id);
12156 -- An abstract state declared within a Ghost region becomes
12157 -- Ghost (SPARK RM 6.9(2)).
12159 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12160 Set_Is_Ghost_Entity (State_Id);
12163 -- Establish a link between the state declaration and the
12164 -- abstract state entity. Note that a null state remains as
12165 -- N_Null and does not carry any linkages.
12167 if not Is_Null then
12168 if Present (Decl) then
12169 Set_Entity (Decl, State_Id);
12170 Set_Etype (Decl, Standard_Void_Type);
12173 -- Every non-null state must be defined, nameable and
12176 Push_Scope (Pack_Id);
12177 Generate_Definition (State_Id);
12178 Enter_Name (State_Id);
12181 end Create_Abstract_State;
12188 -- Start of processing for Analyze_Abstract_State
12191 -- A package with a null abstract state is not allowed to
12192 -- declare additional states.
12196 ("package & has null abstract state", State, Pack_Id);
12198 -- Null states appear as internally generated entities
12200 elsif Nkind (State) = N_Null then
12201 Create_Abstract_State
12202 (Nam => New_Internal_Name ('S'),
12204 Loc => Sloc (State),
12208 -- Catch a case where a null state appears in a list of
12209 -- non-null states.
12211 if Non_Null_Seen then
12213 ("package & has non-null abstract state",
12217 -- Simple state declaration
12219 elsif Nkind (State) = N_Identifier then
12220 Create_Abstract_State
12221 (Nam => Chars (State),
12223 Loc => Sloc (State),
12225 Non_Null_Seen := True;
12227 -- State declaration with various options. This construct
12228 -- appears as an extension aggregate in the tree.
12230 elsif Nkind (State) = N_Extension_Aggregate then
12231 if Nkind (Ancestor_Part (State)) = N_Identifier then
12232 Create_Abstract_State
12233 (Nam => Chars (Ancestor_Part (State)),
12234 Decl => Ancestor_Part (State),
12235 Loc => Sloc (Ancestor_Part (State)),
12237 Non_Null_Seen := True;
12240 ("state name must be an identifier",
12241 Ancestor_Part (State));
12244 -- Options External, Ghost and Synchronous appear as
12247 Opt := First (Expressions (State));
12248 while Present (Opt) loop
12249 if Nkind (Opt) = N_Identifier then
12253 if Chars (Opt) = Name_External then
12254 Check_Duplicate_Option (Opt, External_Seen);
12255 Analyze_External_Option (Opt);
12259 elsif Chars (Opt) = Name_Ghost then
12260 Check_Duplicate_Option (Opt, Ghost_Seen);
12261 Check_Ghost_Synchronous;
12263 if Present (State_Id) then
12264 Set_Is_Ghost_Entity (State_Id);
12269 elsif Chars (Opt) = Name_Synchronous then
12270 Check_Duplicate_Option (Opt, Synchronous_Seen);
12271 Check_Ghost_Synchronous;
12273 -- Option Part_Of without an encapsulating state is
12274 -- illegal (SPARK RM 7.1.4(8)).
12276 elsif Chars (Opt) = Name_Part_Of then
12278 ("indicator Part_Of must denote abstract state, "
12279 & "single protected type or single task type",
12282 -- Do not emit an error message when a previous state
12283 -- declaration with options was not parenthesized as
12284 -- the option is actually another state declaration.
12286 -- with Abstract_State
12287 -- (State_1 with ..., -- missing parentheses
12288 -- (State_2 with ...),
12289 -- State_3) -- ok state declaration
12291 elsif Missing_Parentheses then
12294 -- Otherwise the option is not allowed. Note that it
12295 -- is not possible to distinguish between an option
12296 -- and a state declaration when a previous state with
12297 -- options not properly parentheses.
12299 -- with Abstract_State
12300 -- (State_1 with ..., -- missing parentheses
12301 -- State_2); -- could be an option
12305 ("simple option not allowed in state declaration",
12309 -- Catch a case where missing parentheses around a state
12310 -- declaration with options cause a subsequent state
12311 -- declaration with options to be treated as an option.
12313 -- with Abstract_State
12314 -- (State_1 with ..., -- missing parentheses
12315 -- (State_2 with ...))
12317 elsif Nkind (Opt) = N_Extension_Aggregate then
12318 Missing_Parentheses := True;
12320 ("state declaration must be parenthesized",
12321 Ancestor_Part (State));
12323 -- Otherwise the option is malformed
12326 SPARK_Msg_N ("malformed option", Opt);
12332 -- Options External and Part_Of appear as component
12335 Opt := First (Component_Associations (State));
12336 while Present (Opt) loop
12337 Opt_Nam := First (Choices (Opt));
12339 if Nkind (Opt_Nam) = N_Identifier then
12340 if Chars (Opt_Nam) = Name_External then
12341 Analyze_External_Option (Opt);
12343 elsif Chars (Opt_Nam) = Name_Part_Of then
12344 Analyze_Part_Of_Option (Opt);
12347 SPARK_Msg_N ("invalid state option", Opt);
12350 SPARK_Msg_N ("invalid state option", Opt);
12356 -- Any other attempt to declare a state is illegal
12359 Malformed_State_Error (State);
12363 -- Guard against a junk state. In such cases no entity is
12364 -- generated and the subsequent checks cannot be applied.
12366 if Present (State_Id) then
12368 -- Verify whether the state does not introduce an illegal
12369 -- hidden state within a package subject to a null abstract
12372 Check_No_Hidden_State (State_Id);
12374 -- Check whether the lack of option Part_Of agrees with the
12375 -- placement of the abstract state with respect to the state
12378 if not Part_Of_Seen then
12379 Check_Missing_Part_Of (State_Id);
12382 -- Associate the state with its related package
12384 if No (Abstract_States (Pack_Id)) then
12385 Set_Abstract_States (Pack_Id, New_Elmt_List);
12388 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12390 end Analyze_Abstract_State;
12392 ---------------------------
12393 -- Malformed_State_Error --
12394 ---------------------------
12396 procedure Malformed_State_Error (State : Node_Id) is
12398 Error_Msg_N ("malformed abstract state declaration", State);
12400 -- An abstract state with a simple option is being declared
12401 -- with "=>" rather than the legal "with". The state appears
12402 -- as a component association.
12404 if Nkind (State) = N_Component_Association then
12405 Error_Msg_N ("\use WITH to specify simple option", State);
12407 end Malformed_State_Error;
12411 Pack_Decl : Node_Id;
12412 Pack_Id : Entity_Id;
12416 -- Start of processing for Abstract_State
12420 Check_No_Identifiers;
12421 Check_Arg_Count (1);
12423 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12425 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
12426 N_Package_Declaration)
12432 Pack_Id := Defining_Entity (Pack_Decl);
12434 -- A pragma that applies to a Ghost entity becomes Ghost for the
12435 -- purposes of legality checks and removal of ignored Ghost code.
12437 Mark_Ghost_Pragma (N, Pack_Id);
12438 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12440 -- Chain the pragma on the contract for completeness
12442 Add_Contract_Item (N, Pack_Id);
12444 -- The legality checks of pragmas Abstract_State, Initializes, and
12445 -- Initial_Condition are affected by the SPARK mode in effect. In
12446 -- addition, these three pragmas are subject to an inherent order:
12448 -- 1) Abstract_State
12450 -- 3) Initial_Condition
12452 -- Analyze all these pragmas in the order outlined above
12454 Analyze_If_Present (Pragma_SPARK_Mode);
12455 States := Expression (Get_Argument (N, Pack_Id));
12457 -- Multiple non-null abstract states appear as an aggregate
12459 if Nkind (States) = N_Aggregate then
12460 State := First (Expressions (States));
12461 while Present (State) loop
12462 Analyze_Abstract_State (State, Pack_Id);
12466 -- An abstract state with a simple option is being illegaly
12467 -- declared with "=>" rather than "with". In this case the
12468 -- state declaration appears as a component association.
12470 if Present (Component_Associations (States)) then
12471 State := First (Component_Associations (States));
12472 while Present (State) loop
12473 Malformed_State_Error (State);
12478 -- Various forms of a single abstract state. Note that these may
12479 -- include malformed state declarations.
12482 Analyze_Abstract_State (States, Pack_Id);
12485 Analyze_If_Present (Pragma_Initializes);
12486 Analyze_If_Present (Pragma_Initial_Condition);
12487 end Abstract_State;
12493 when Pragma_Acc_Data => Acc_Data : declare
12494 Clause_Names : constant Name_List :=
12507 Clauses : Args_List (Clause_Names'Range);
12510 if not OpenAcc_Enabled then
12516 if Nkind (Parent (N)) /= N_Loop_Statement then
12518 ("Acc_Data pragma should be placed in loop or block "
12522 Gather_Associations (Clause_Names, Clauses);
12524 for Id in Clause_Names'First .. Clause_Names'Last loop
12525 Clause := Clauses (Id);
12527 if Present (Clause) then
12528 case Clause_Names (Id) is
12536 Validate_Acc_Data_Clause (Clause);
12543 Error_Pragma ("unsupported pragma clause");
12546 raise Program_Error;
12551 Set_Is_OpenAcc_Environment (Parent (N));
12558 when Pragma_Acc_Loop => Acc_Loop : declare
12559 Clause_Names : constant Name_List :=
12572 Clauses : Args_List (Clause_Names'Range);
12576 if not OpenAcc_Enabled then
12582 -- Make sure the pragma is in an openacc construct
12584 Check_Loop_Pragma_Placement;
12587 while Present (Par)
12588 and then (Nkind (Par) /= N_Loop_Statement
12589 or else not Is_OpenAcc_Environment (Par))
12591 Par := Parent (Par);
12594 if not Is_OpenAcc_Environment (Par) then
12596 ("Acc_Loop directive must be associated with an OpenAcc "
12597 & "construct region");
12600 Gather_Associations (Clause_Names, Clauses);
12602 for Id in Clause_Names'First .. Clause_Names'Last loop
12603 Clause := Clauses (Id);
12605 if Present (Clause) then
12606 case Clause_Names (Id) is
12613 when Name_Collapse =>
12614 Validate_Acc_Loop_Collapse (Clause);
12617 Validate_Acc_Loop_Gang (Clause);
12619 when Name_Acc_Private =>
12620 Validate_Acc_Data_Clause (Clause);
12622 when Name_Reduction =>
12623 Validate_Acc_Name_Reduction (Clause);
12626 Validate_Acc_Size_Expressions (Clause);
12628 when Name_Vector =>
12629 Validate_Acc_Loop_Vector (Clause);
12631 when Name_Worker =>
12632 Validate_Acc_Loop_Worker (Clause);
12635 raise Program_Error;
12640 Set_Is_OpenAcc_Loop (Parent (N));
12643 ----------------------------------
12644 -- Acc_Parallel and Acc_Kernels --
12645 ----------------------------------
12647 when Pragma_Acc_Parallel
12648 | Pragma_Acc_Kernels
12650 Acc_Kernels_Or_Parallel : declare
12651 Clause_Names : constant Name_List :=
12664 Name_Vector_Length,
12670 Name_First_Private,
12679 Clauses : Args_List (Clause_Names'Range);
12682 if not OpenAcc_Enabled then
12687 Check_Loop_Pragma_Placement;
12689 if Nkind (Parent (N)) /= N_Loop_Statement then
12691 ("pragma should be placed in loop or block statements");
12694 Gather_Associations (Clause_Names, Clauses);
12696 for Id in Clause_Names'First .. Clause_Names'Last loop
12697 Clause := Clauses (Id);
12699 if Present (Clause) then
12700 if Chars (Parent (Clause)) = No_Name then
12701 Error_Pragma ("all arguments should be associations");
12703 case Clause_Names (Id) is
12705 -- Note: According to the OpenAcc Standard v2.6,
12706 -- Async's argument should be optional. Because this
12707 -- complicates parsing the clause, the argument is
12708 -- made mandatory. The standard defines two negative
12709 -- values, acc_async_noval and acc_async_sync. When
12710 -- given acc_async_noval as value, the clause should
12711 -- behave as if no argument was given. According to
12712 -- the standard, acc_async_noval is defined in header
12713 -- files for C and Fortran, thus this value should
12714 -- probably be defined in the OpenAcc Ada library once
12715 -- it is implemented.
12720 | Name_Vector_Length
12722 Validate_Acc_Int_Expr_Clause (Clause);
12724 when Name_Acc_If =>
12725 Validate_Acc_Condition_Clause (Clause);
12727 -- Unsupported by GCC
12732 Error_Pragma ("unsupported clause");
12734 when Name_Acc_Private
12735 | Name_First_Private
12737 if Prag_Id /= Pragma_Acc_Parallel then
12739 ("argument is only available for 'Parallel' "
12742 Validate_Acc_Data_Clause (Clause);
12752 Validate_Acc_Data_Clause (Clause);
12754 when Name_Reduction =>
12755 if Prag_Id /= Pragma_Acc_Parallel then
12757 ("argument is only available for 'Parallel' "
12760 Validate_Acc_Name_Reduction (Clause);
12763 when Name_Default =>
12764 if Chars (Clause) /= Name_None then
12765 Error_Pragma ("expected none");
12768 when Name_Device_Type =>
12769 Error_Pragma ("unsupported pragma clause");
12771 -- Similar to Name_Async, Name_Wait's arguments should
12772 -- be optional. However, this can be simulated using
12773 -- acc_async_noval, hence, we do not bother making the
12774 -- argument optional for now.
12777 Validate_Acc_Int_Expr_List_Clause (Clause);
12780 raise Program_Error;
12786 Set_Is_OpenAcc_Environment (Parent (N));
12787 end Acc_Kernels_Or_Parallel;
12795 -- Note: this pragma also has some specific processing in Par.Prag
12796 -- because we want to set the Ada version mode during parsing.
12798 when Pragma_Ada_83 =>
12800 Check_Arg_Count (0);
12802 -- We really should check unconditionally for proper configuration
12803 -- pragma placement, since we really don't want mixed Ada modes
12804 -- within a single unit, and the GNAT reference manual has always
12805 -- said this was a configuration pragma, but we did not check and
12806 -- are hesitant to add the check now.
12808 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12809 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12810 -- or Ada 2012 mode.
12812 if Ada_Version >= Ada_2005 then
12813 Check_Valid_Configuration_Pragma;
12816 -- Now set Ada 83 mode
12818 if Latest_Ada_Only then
12819 Error_Pragma ("??pragma% ignored");
12821 Ada_Version := Ada_83;
12822 Ada_Version_Explicit := Ada_83;
12823 Ada_Version_Pragma := N;
12832 -- Note: this pragma also has some specific processing in Par.Prag
12833 -- because we want to set the Ada 83 version mode during parsing.
12835 when Pragma_Ada_95 =>
12837 Check_Arg_Count (0);
12839 -- We really should check unconditionally for proper configuration
12840 -- pragma placement, since we really don't want mixed Ada modes
12841 -- within a single unit, and the GNAT reference manual has always
12842 -- said this was a configuration pragma, but we did not check and
12843 -- are hesitant to add the check now.
12845 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12846 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12848 if Ada_Version >= Ada_2005 then
12849 Check_Valid_Configuration_Pragma;
12852 -- Now set Ada 95 mode
12854 if Latest_Ada_Only then
12855 Error_Pragma ("??pragma% ignored");
12857 Ada_Version := Ada_95;
12858 Ada_Version_Explicit := Ada_95;
12859 Ada_Version_Pragma := N;
12862 ---------------------
12863 -- Ada_05/Ada_2005 --
12864 ---------------------
12867 -- pragma Ada_05 (LOCAL_NAME);
12869 -- pragma Ada_2005;
12870 -- pragma Ada_2005 (LOCAL_NAME):
12872 -- Note: these pragmas also have some specific processing in Par.Prag
12873 -- because we want to set the Ada 2005 version mode during parsing.
12875 -- The one argument form is used for managing the transition from
12876 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12877 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12878 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12879 -- mode, a preference rule is established which does not choose
12880 -- such an entity unless it is unambiguously specified. This avoids
12881 -- extra subprograms marked this way from generating ambiguities in
12882 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12883 -- intended for exclusive use in the GNAT run-time library.
12894 if Arg_Count = 1 then
12895 Check_Arg_Is_Local_Name (Arg1);
12896 E_Id := Get_Pragma_Arg (Arg1);
12898 if Etype (E_Id) = Any_Type then
12902 Set_Is_Ada_2005_Only (Entity (E_Id));
12903 Record_Rep_Item (Entity (E_Id), N);
12906 Check_Arg_Count (0);
12908 -- For Ada_2005 we unconditionally enforce the documented
12909 -- configuration pragma placement, since we do not want to
12910 -- tolerate mixed modes in a unit involving Ada 2005. That
12911 -- would cause real difficulties for those cases where there
12912 -- are incompatibilities between Ada 95 and Ada 2005.
12914 Check_Valid_Configuration_Pragma;
12916 -- Now set appropriate Ada mode
12918 if Latest_Ada_Only then
12919 Error_Pragma ("??pragma% ignored");
12921 Ada_Version := Ada_2005;
12922 Ada_Version_Explicit := Ada_2005;
12923 Ada_Version_Pragma := N;
12928 ---------------------
12929 -- Ada_12/Ada_2012 --
12930 ---------------------
12933 -- pragma Ada_12 (LOCAL_NAME);
12935 -- pragma Ada_2012;
12936 -- pragma Ada_2012 (LOCAL_NAME):
12938 -- Note: these pragmas also have some specific processing in Par.Prag
12939 -- because we want to set the Ada 2012 version mode during parsing.
12941 -- The one argument form is used for managing the transition from Ada
12942 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12943 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12944 -- mode will generate a warning. In addition, in any pre-Ada_2012
12945 -- mode, a preference rule is established which does not choose
12946 -- such an entity unless it is unambiguously specified. This avoids
12947 -- extra subprograms marked this way from generating ambiguities in
12948 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12949 -- intended for exclusive use in the GNAT run-time library.
12960 if Arg_Count = 1 then
12961 Check_Arg_Is_Local_Name (Arg1);
12962 E_Id := Get_Pragma_Arg (Arg1);
12964 if Etype (E_Id) = Any_Type then
12968 Set_Is_Ada_2012_Only (Entity (E_Id));
12969 Record_Rep_Item (Entity (E_Id), N);
12972 Check_Arg_Count (0);
12974 -- For Ada_2012 we unconditionally enforce the documented
12975 -- configuration pragma placement, since we do not want to
12976 -- tolerate mixed modes in a unit involving Ada 2012. That
12977 -- would cause real difficulties for those cases where there
12978 -- are incompatibilities between Ada 95 and Ada 2012. We could
12979 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12981 Check_Valid_Configuration_Pragma;
12983 -- Now set appropriate Ada mode
12985 Ada_Version := Ada_2012;
12986 Ada_Version_Explicit := Ada_2012;
12987 Ada_Version_Pragma := N;
12995 -- pragma Ada_2020;
12997 -- Note: this pragma also has some specific processing in Par.Prag
12998 -- because we want to set the Ada 2020 version mode during parsing.
13000 when Pragma_Ada_2020 =>
13003 Check_Arg_Count (0);
13005 Check_Valid_Configuration_Pragma;
13007 -- Now set appropriate Ada mode
13009 Ada_Version := Ada_2020;
13010 Ada_Version_Explicit := Ada_2020;
13011 Ada_Version_Pragma := N;
13013 ----------------------
13014 -- All_Calls_Remote --
13015 ----------------------
13017 -- pragma All_Calls_Remote [(library_package_NAME)];
13019 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
13020 Lib_Entity : Entity_Id;
13023 Check_Ada_83_Warning;
13024 Check_Valid_Library_Unit_Pragma;
13026 if Nkind (N) = N_Null_Statement then
13030 Lib_Entity := Find_Lib_Unit_Name;
13032 -- A pragma that applies to a Ghost entity becomes Ghost for the
13033 -- purposes of legality checks and removal of ignored Ghost code.
13035 Mark_Ghost_Pragma (N, Lib_Entity);
13037 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13039 if Present (Lib_Entity) and then not Debug_Flag_U then
13040 if not Is_Remote_Call_Interface (Lib_Entity) then
13041 Error_Pragma ("pragma% only apply to rci unit");
13043 -- Set flag for entity of the library unit
13046 Set_Has_All_Calls_Remote (Lib_Entity);
13049 end All_Calls_Remote;
13051 ---------------------------
13052 -- Allow_Integer_Address --
13053 ---------------------------
13055 -- pragma Allow_Integer_Address;
13057 when Pragma_Allow_Integer_Address =>
13059 Check_Valid_Configuration_Pragma;
13060 Check_Arg_Count (0);
13062 -- If Address is a private type, then set the flag to allow
13063 -- integer address values. If Address is not private, then this
13064 -- pragma has no purpose, so it is simply ignored. Not clear if
13065 -- there are any such targets now.
13067 if Opt.Address_Is_Private then
13068 Opt.Allow_Integer_Address := True;
13076 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13077 -- ARG ::= NAME | EXPRESSION
13079 -- The first two arguments are by convention intended to refer to an
13080 -- external tool and a tool-specific function. These arguments are
13083 when Pragma_Annotate => Annotate : declare
13090 Check_At_Least_N_Arguments (1);
13092 Nam_Arg := Last (Pragma_Argument_Associations (N));
13094 -- Determine whether the last argument is "Entity => local_NAME"
13095 -- and if it is, perform the required semantic checks. Remove the
13096 -- argument from further processing.
13098 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
13099 and then Chars (Nam_Arg) = Name_Entity
13101 Check_Arg_Is_Local_Name (Nam_Arg);
13102 Arg_Count := Arg_Count - 1;
13104 -- A pragma that applies to a Ghost entity becomes Ghost for
13105 -- the purposes of legality checks and removal of ignored Ghost
13108 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
13109 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
13111 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
13114 -- Not allowed in compiler units (bootstrap issues)
13116 Check_Compiler_Unit ("Entity for pragma Annotate", N);
13119 -- Continue the processing with last argument removed for now
13121 Check_Arg_Is_Identifier (Arg1);
13122 Check_No_Identifiers;
13125 -- The second parameter is optional, it is never analyzed
13130 -- Otherwise there is a second parameter
13133 -- The second parameter must be an identifier
13135 Check_Arg_Is_Identifier (Arg2);
13137 -- Process the remaining parameters (if any)
13139 Arg := Next (Arg2);
13140 while Present (Arg) loop
13141 Expr := Get_Pragma_Arg (Arg);
13144 if Is_Entity_Name (Expr) then
13147 -- For string literals, we assume Standard_String as the
13148 -- type, unless the string contains wide or wide_wide
13151 elsif Nkind (Expr) = N_String_Literal then
13152 if Has_Wide_Wide_Character (Expr) then
13153 Resolve (Expr, Standard_Wide_Wide_String);
13154 elsif Has_Wide_Character (Expr) then
13155 Resolve (Expr, Standard_Wide_String);
13157 Resolve (Expr, Standard_String);
13160 elsif Is_Overloaded (Expr) then
13161 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
13172 -------------------------------------------------
13173 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13174 -------------------------------------------------
13177 -- ( [Check => ] Boolean_EXPRESSION
13178 -- [, [Message =>] Static_String_EXPRESSION]);
13180 -- pragma Assert_And_Cut
13181 -- ( [Check => ] Boolean_EXPRESSION
13182 -- [, [Message =>] Static_String_EXPRESSION]);
13185 -- ( [Check => ] Boolean_EXPRESSION
13186 -- [, [Message =>] Static_String_EXPRESSION]);
13188 -- pragma Loop_Invariant
13189 -- ( [Check => ] Boolean_EXPRESSION
13190 -- [, [Message =>] Static_String_EXPRESSION]);
13193 | Pragma_Assert_And_Cut
13195 | Pragma_Loop_Invariant
13198 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
13199 -- Determine whether expression Expr contains a Loop_Entry
13200 -- attribute reference.
13202 -------------------------
13203 -- Contains_Loop_Entry --
13204 -------------------------
13206 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
13207 Has_Loop_Entry : Boolean := False;
13209 function Process (N : Node_Id) return Traverse_Result;
13210 -- Process function for traversal to look for Loop_Entry
13216 function Process (N : Node_Id) return Traverse_Result is
13218 if Nkind (N) = N_Attribute_Reference
13219 and then Attribute_Name (N) = Name_Loop_Entry
13221 Has_Loop_Entry := True;
13228 procedure Traverse is new Traverse_Proc (Process);
13230 -- Start of processing for Contains_Loop_Entry
13234 return Has_Loop_Entry;
13235 end Contains_Loop_Entry;
13240 New_Args : List_Id;
13242 -- Start of processing for Assert
13245 -- Assert is an Ada 2005 RM-defined pragma
13247 if Prag_Id = Pragma_Assert then
13250 -- The remaining ones are GNAT pragmas
13256 Check_At_Least_N_Arguments (1);
13257 Check_At_Most_N_Arguments (2);
13258 Check_Arg_Order ((Name_Check, Name_Message));
13259 Check_Optional_Identifier (Arg1, Name_Check);
13260 Expr := Get_Pragma_Arg (Arg1);
13262 -- Special processing for Loop_Invariant, Loop_Variant or for
13263 -- other cases where a Loop_Entry attribute is present. If the
13264 -- assertion pragma contains attribute Loop_Entry, ensure that
13265 -- the related pragma is within a loop.
13267 if Prag_Id = Pragma_Loop_Invariant
13268 or else Prag_Id = Pragma_Loop_Variant
13269 or else Contains_Loop_Entry (Expr)
13271 Check_Loop_Pragma_Placement;
13273 -- Perform preanalysis to deal with embedded Loop_Entry
13276 Preanalyze_Assert_Expression (Expr, Any_Boolean);
13279 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13280 -- a corresponding Check pragma:
13282 -- pragma Check (name, condition [, msg]);
13284 -- Where name is the identifier matching the pragma name. So
13285 -- rewrite pragma in this manner, transfer the message argument
13286 -- if present, and analyze the result
13288 -- Note: When dealing with a semantically analyzed tree, the
13289 -- information that a Check node N corresponds to a source Assert,
13290 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13291 -- pragma kind of Original_Node(N).
13293 New_Args := New_List (
13294 Make_Pragma_Argument_Association (Loc,
13295 Expression => Make_Identifier (Loc, Pname)),
13296 Make_Pragma_Argument_Association (Sloc (Expr),
13297 Expression => Expr));
13299 if Arg_Count > 1 then
13300 Check_Optional_Identifier (Arg2, Name_Message);
13302 -- Provide semantic annnotations for optional argument, for
13303 -- ASIS use, before rewriting.
13305 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
13306 Append_To (New_Args, New_Copy_Tree (Arg2));
13309 -- Rewrite as Check pragma
13313 Chars => Name_Check,
13314 Pragma_Argument_Associations => New_Args));
13319 ----------------------
13320 -- Assertion_Policy --
13321 ----------------------
13323 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13325 -- The following form is Ada 2012 only, but we allow it in all modes
13327 -- Pragma Assertion_Policy (
13328 -- ASSERTION_KIND => POLICY_IDENTIFIER
13329 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13331 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13333 -- RM_ASSERTION_KIND ::= Assert |
13334 -- Static_Predicate |
13335 -- Dynamic_Predicate |
13340 -- Type_Invariant |
13341 -- Type_Invariant'Class
13343 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13345 -- Contract_Cases |
13347 -- Default_Initial_Condition |
13349 -- Initial_Condition |
13350 -- Loop_Invariant |
13356 -- Statement_Assertions
13358 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13359 -- ID_ASSERTION_KIND list contains implementation-defined additions
13360 -- recognized by GNAT. The effect is to control the behavior of
13361 -- identically named aspects and pragmas, depending on the specified
13362 -- policy identifier:
13364 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13366 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13367 -- implementation-defined addition that results in totally ignoring
13368 -- the corresponding assertion. If Disable is specified, then the
13369 -- argument of the assertion is not even analyzed. This is useful
13370 -- when the aspect/pragma argument references entities in a with'ed
13371 -- package that is replaced by a dummy package in the final build.
13373 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13374 -- and Type_Invariant'Class were recognized by the parser and
13375 -- transformed into references to the special internal identifiers
13376 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13377 -- processing is required here.
13379 when Pragma_Assertion_Policy => Assertion_Policy : declare
13380 procedure Resolve_Suppressible (Policy : Node_Id);
13381 -- Converts the assertion policy 'Suppressible' to either Check or
13382 -- Ignore based on whether checks are suppressed via -gnatp.
13384 --------------------------
13385 -- Resolve_Suppressible --
13386 --------------------------
13388 procedure Resolve_Suppressible (Policy : Node_Id) is
13389 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13393 -- Transform policy argument Suppressible into either Ignore or
13394 -- Check depending on whether checks are enabled or suppressed.
13396 if Chars (Arg) = Name_Suppressible then
13397 if Suppress_Checks then
13398 Nam := Name_Ignore;
13403 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13405 end Resolve_Suppressible;
13417 -- This can always appear as a configuration pragma
13419 if Is_Configuration_Pragma then
13422 -- It can also appear in a declarative part or package spec in Ada
13423 -- 2012 mode. We allow this in other modes, but in that case we
13424 -- consider that we have an Ada 2012 pragma on our hands.
13427 Check_Is_In_Decl_Part_Or_Package_Spec;
13431 -- One argument case with no identifier (first form above)
13434 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13435 or else Chars (Arg1) = No_Name)
13437 Check_Arg_Is_One_Of (Arg1,
13438 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13440 Resolve_Suppressible (Arg1);
13442 -- Treat one argument Assertion_Policy as equivalent to:
13444 -- pragma Check_Policy (Assertion, policy)
13446 -- So rewrite pragma in that manner and link on to the chain
13447 -- of Check_Policy pragmas, marking the pragma as analyzed.
13449 Policy := Get_Pragma_Arg (Arg1);
13453 Chars => Name_Check_Policy,
13454 Pragma_Argument_Associations => New_List (
13455 Make_Pragma_Argument_Association (Loc,
13456 Expression => Make_Identifier (Loc, Name_Assertion)),
13458 Make_Pragma_Argument_Association (Loc,
13460 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13463 -- Here if we have two or more arguments
13466 Check_At_Least_N_Arguments (1);
13469 -- Loop through arguments
13472 while Present (Arg) loop
13473 LocP := Sloc (Arg);
13475 -- Kind must be specified
13477 if Nkind (Arg) /= N_Pragma_Argument_Association
13478 or else Chars (Arg) = No_Name
13481 ("missing assertion kind for pragma%", Arg);
13484 -- Check Kind and Policy have allowed forms
13486 Kind := Chars (Arg);
13487 Policy := Get_Pragma_Arg (Arg);
13489 if not Is_Valid_Assertion_Kind (Kind) then
13491 ("invalid assertion kind for pragma%", Arg);
13494 Check_Arg_Is_One_Of (Arg,
13495 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13497 Resolve_Suppressible (Arg);
13499 if Kind = Name_Ghost then
13501 -- The Ghost policy must be either Check or Ignore
13502 -- (SPARK RM 6.9(6)).
13504 if not Nam_In (Chars (Policy), Name_Check,
13508 ("argument of pragma % Ghost must be Check or "
13509 & "Ignore", Policy);
13512 -- Pragma Assertion_Policy specifying a Ghost policy
13513 -- cannot occur within a Ghost subprogram or package
13514 -- (SPARK RM 6.9(14)).
13516 if Ghost_Mode > None then
13518 ("pragma % cannot appear within ghost subprogram or "
13523 -- Rewrite the Assertion_Policy pragma as a series of
13524 -- Check_Policy pragmas of the form:
13526 -- Check_Policy (Kind, Policy);
13528 -- Note: the insertion of the pragmas cannot be done with
13529 -- Insert_Action because in the configuration case, there
13530 -- are no scopes on the scope stack and the mechanism will
13533 Insert_Before_And_Analyze (N,
13535 Chars => Name_Check_Policy,
13536 Pragma_Argument_Associations => New_List (
13537 Make_Pragma_Argument_Association (LocP,
13538 Expression => Make_Identifier (LocP, Kind)),
13539 Make_Pragma_Argument_Association (LocP,
13540 Expression => Policy))));
13545 -- Rewrite the Assertion_Policy pragma as null since we have
13546 -- now inserted all the equivalent Check pragmas.
13548 Rewrite (N, Make_Null_Statement (Loc));
13551 end Assertion_Policy;
13553 ------------------------------
13554 -- Assume_No_Invalid_Values --
13555 ------------------------------
13557 -- pragma Assume_No_Invalid_Values (On | Off);
13559 when Pragma_Assume_No_Invalid_Values =>
13561 Check_Valid_Configuration_Pragma;
13562 Check_Arg_Count (1);
13563 Check_No_Identifiers;
13564 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13566 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13567 Assume_No_Invalid_Values := True;
13569 Assume_No_Invalid_Values := False;
13572 --------------------------
13573 -- Attribute_Definition --
13574 --------------------------
13576 -- pragma Attribute_Definition
13577 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13578 -- [Entity =>] LOCAL_NAME,
13579 -- [Expression =>] EXPRESSION | NAME);
13581 when Pragma_Attribute_Definition => Attribute_Definition : declare
13582 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13587 Check_Arg_Count (3);
13588 Check_Optional_Identifier (Arg1, "attribute");
13589 Check_Optional_Identifier (Arg2, "entity");
13590 Check_Optional_Identifier (Arg3, "expression");
13592 if Nkind (Attribute_Designator) /= N_Identifier then
13593 Error_Msg_N ("attribute name expected", Attribute_Designator);
13597 Check_Arg_Is_Local_Name (Arg2);
13599 -- If the attribute is not recognized, then issue a warning (not
13600 -- an error), and ignore the pragma.
13602 Aname := Chars (Attribute_Designator);
13604 if not Is_Attribute_Name (Aname) then
13605 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13609 -- Otherwise, rewrite the pragma as an attribute definition clause
13612 Make_Attribute_Definition_Clause (Loc,
13613 Name => Get_Pragma_Arg (Arg2),
13615 Expression => Get_Pragma_Arg (Arg3)));
13617 end Attribute_Definition;
13619 ------------------------------------------------------------------
13620 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13622 ------------------------------------------------------------------
13624 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13625 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13626 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13627 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13628 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13630 when Pragma_Async_Readers
13631 | Pragma_Async_Writers
13632 | Pragma_Effective_Reads
13633 | Pragma_Effective_Writes
13634 | Pragma_No_Caching
13636 Async_Effective : declare
13637 Obj_Decl : Node_Id;
13638 Obj_Id : Entity_Id;
13642 Check_No_Identifiers;
13643 Check_At_Most_N_Arguments (1);
13645 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13647 -- Object declaration
13649 if Nkind (Obj_Decl) /= N_Object_Declaration then
13654 Obj_Id := Defining_Entity (Obj_Decl);
13656 -- Perform minimal verification to ensure that the argument is at
13657 -- least a variable. Subsequent finer grained checks will be done
13658 -- at the end of the declarative region the contains the pragma.
13660 if Ekind (Obj_Id) = E_Variable then
13662 -- A pragma that applies to a Ghost entity becomes Ghost for
13663 -- the purposes of legality checks and removal of ignored Ghost
13666 Mark_Ghost_Pragma (N, Obj_Id);
13668 -- Chain the pragma on the contract for further processing by
13669 -- Analyze_External_Property_In_Decl_Part.
13671 Add_Contract_Item (N, Obj_Id);
13673 -- Analyze the Boolean expression (if any)
13675 if Present (Arg1) then
13676 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13679 -- Otherwise the external property applies to a constant
13682 Error_Pragma ("pragma % must apply to a volatile object");
13684 end Async_Effective;
13690 -- pragma Asynchronous (LOCAL_NAME);
13692 when Pragma_Asynchronous => Asynchronous : declare
13695 Formal : Entity_Id;
13700 procedure Process_Async_Pragma;
13701 -- Common processing for procedure and access-to-procedure case
13703 --------------------------
13704 -- Process_Async_Pragma --
13705 --------------------------
13707 procedure Process_Async_Pragma is
13710 Set_Is_Asynchronous (Nm);
13714 -- The formals should be of mode IN (RM E.4.1(6))
13717 while Present (S) loop
13718 Formal := Defining_Identifier (S);
13720 if Nkind (Formal) = N_Defining_Identifier
13721 and then Ekind (Formal) /= E_In_Parameter
13724 ("pragma% procedure can only have IN parameter",
13731 Set_Is_Asynchronous (Nm);
13732 end Process_Async_Pragma;
13734 -- Start of processing for pragma Asynchronous
13737 Check_Ada_83_Warning;
13738 Check_No_Identifiers;
13739 Check_Arg_Count (1);
13740 Check_Arg_Is_Local_Name (Arg1);
13742 if Debug_Flag_U then
13746 C_Ent := Cunit_Entity (Current_Sem_Unit);
13747 Analyze (Get_Pragma_Arg (Arg1));
13748 Nm := Entity (Get_Pragma_Arg (Arg1));
13750 -- A pragma that applies to a Ghost entity becomes Ghost for the
13751 -- purposes of legality checks and removal of ignored Ghost code.
13753 Mark_Ghost_Pragma (N, Nm);
13755 if not Is_Remote_Call_Interface (C_Ent)
13756 and then not Is_Remote_Types (C_Ent)
13758 -- This pragma should only appear in an RCI or Remote Types
13759 -- unit (RM E.4.1(4)).
13762 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13765 if Ekind (Nm) = E_Procedure
13766 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13768 if not Is_Remote_Call_Interface (Nm) then
13770 ("pragma% cannot be applied on non-remote procedure",
13774 L := Parameter_Specifications (Parent (Nm));
13775 Process_Async_Pragma;
13778 elsif Ekind (Nm) = E_Function then
13780 ("pragma% cannot be applied to function", Arg1);
13782 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13783 if Is_Record_Type (Nm) then
13785 -- A record type that is the Equivalent_Type for a remote
13786 -- access-to-subprogram type.
13788 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13791 -- A non-expanded RAS type (distribution is not enabled)
13793 Decl := Declaration_Node (Nm);
13796 if Nkind (Decl) = N_Full_Type_Declaration
13797 and then Nkind (Type_Definition (Decl)) =
13798 N_Access_Procedure_Definition
13800 L := Parameter_Specifications (Type_Definition (Decl));
13801 Process_Async_Pragma;
13803 if Is_Asynchronous (Nm)
13804 and then Expander_Active
13805 and then Get_PCS_Name /= Name_No_DSA
13807 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13812 ("pragma% cannot reference access-to-function type",
13816 -- Only other possibility is Access-to-class-wide type
13818 elsif Is_Access_Type (Nm)
13819 and then Is_Class_Wide_Type (Designated_Type (Nm))
13821 Check_First_Subtype (Arg1);
13822 Set_Is_Asynchronous (Nm);
13823 if Expander_Active then
13824 RACW_Type_Is_Asynchronous (Nm);
13828 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13836 -- pragma Atomic (LOCAL_NAME);
13838 when Pragma_Atomic =>
13839 Process_Atomic_Independent_Shared_Volatile;
13841 -----------------------
13842 -- Atomic_Components --
13843 -----------------------
13845 -- pragma Atomic_Components (array_LOCAL_NAME);
13847 -- This processing is shared by Volatile_Components
13849 when Pragma_Atomic_Components
13850 | Pragma_Volatile_Components
13852 Atomic_Components : declare
13859 Check_Ada_83_Warning;
13860 Check_No_Identifiers;
13861 Check_Arg_Count (1);
13862 Check_Arg_Is_Local_Name (Arg1);
13863 E_Id := Get_Pragma_Arg (Arg1);
13865 if Etype (E_Id) = Any_Type then
13869 E := Entity (E_Id);
13871 -- A pragma that applies to a Ghost entity becomes Ghost for the
13872 -- purposes of legality checks and removal of ignored Ghost code.
13874 Mark_Ghost_Pragma (N, E);
13875 Check_Duplicate_Pragma (E);
13877 if Rep_Item_Too_Early (E, N)
13879 Rep_Item_Too_Late (E, N)
13884 D := Declaration_Node (E);
13887 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
13889 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13890 and then Nkind (D) = N_Object_Declaration
13891 and then Nkind (Object_Definition (D)) =
13892 N_Constrained_Array_Definition)
13894 -- The flag is set on the object, or on the base type
13896 if Nkind (D) /= N_Object_Declaration then
13897 E := Base_Type (E);
13900 -- Atomic implies both Independent and Volatile
13902 if Prag_Id = Pragma_Atomic_Components then
13903 Set_Has_Atomic_Components (E);
13904 Set_Has_Independent_Components (E);
13907 Set_Has_Volatile_Components (E);
13910 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13912 end Atomic_Components;
13914 --------------------
13915 -- Attach_Handler --
13916 --------------------
13918 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13920 when Pragma_Attach_Handler =>
13921 Check_Ada_83_Warning;
13922 Check_No_Identifiers;
13923 Check_Arg_Count (2);
13925 if No_Run_Time_Mode then
13926 Error_Msg_CRT ("Attach_Handler pragma", N);
13928 Check_Interrupt_Or_Attach_Handler;
13930 -- The expression that designates the attribute may depend on a
13931 -- discriminant, and is therefore a per-object expression, to
13932 -- be expanded in the init proc. If expansion is enabled, then
13933 -- perform semantic checks on a copy only.
13938 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13941 -- In Relaxed_RM_Semantics mode, we allow any static
13942 -- integer value, for compatibility with other compilers.
13944 if Relaxed_RM_Semantics
13945 and then Nkind (Parg2) = N_Integer_Literal
13947 Typ := Standard_Integer;
13949 Typ := RTE (RE_Interrupt_ID);
13952 if Expander_Active then
13953 Temp := New_Copy_Tree (Parg2);
13954 Set_Parent (Temp, N);
13955 Preanalyze_And_Resolve (Temp, Typ);
13958 Resolve (Parg2, Typ);
13962 Process_Interrupt_Or_Attach_Handler;
13965 --------------------
13966 -- C_Pass_By_Copy --
13967 --------------------
13969 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13971 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13977 Check_Valid_Configuration_Pragma;
13978 Check_Arg_Count (1);
13979 Check_Optional_Identifier (Arg1, "max_size");
13981 Arg := Get_Pragma_Arg (Arg1);
13982 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13984 Val := Expr_Value (Arg);
13988 ("maximum size for pragma% must be positive", Arg1);
13990 elsif UI_Is_In_Int_Range (Val) then
13991 Default_C_Record_Mechanism := UI_To_Int (Val);
13993 -- If a giant value is given, Int'Last will do well enough.
13994 -- If sometime someone complains that a record larger than
13995 -- two gigabytes is not copied, we will worry about it then.
13998 Default_C_Record_Mechanism := Mechanism_Type'Last;
14000 end C_Pass_By_Copy;
14006 -- pragma Check ([Name =>] CHECK_KIND,
14007 -- [Check =>] Boolean_EXPRESSION
14008 -- [,[Message =>] String_EXPRESSION]);
14010 -- CHECK_KIND ::= IDENTIFIER |
14013 -- Invariant'Class |
14014 -- Type_Invariant'Class
14016 -- The identifiers Assertions and Statement_Assertions are not
14017 -- allowed, since they have special meaning for Check_Policy.
14019 -- WARNING: The code below manages Ghost regions. Return statements
14020 -- must be replaced by gotos which jump to the end of the code and
14021 -- restore the Ghost mode.
14023 when Pragma_Check => Check : declare
14024 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
14025 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
14026 -- Save the Ghost-related attributes to restore on exit
14032 pragma Warnings (Off, Str);
14035 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14036 -- the mode now to ensure that any nodes generated during analysis
14037 -- and expansion are marked as Ghost.
14039 Set_Ghost_Mode (N);
14042 Check_At_Least_N_Arguments (2);
14043 Check_At_Most_N_Arguments (3);
14044 Check_Optional_Identifier (Arg1, Name_Name);
14045 Check_Optional_Identifier (Arg2, Name_Check);
14047 if Arg_Count = 3 then
14048 Check_Optional_Identifier (Arg3, Name_Message);
14049 Str := Get_Pragma_Arg (Arg3);
14052 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
14053 Check_Arg_Is_Identifier (Arg1);
14054 Cname := Chars (Get_Pragma_Arg (Arg1));
14056 -- Check forbidden name Assertions or Statement_Assertions
14059 when Name_Assertions =>
14061 ("""Assertions"" is not allowed as a check kind for "
14062 & "pragma%", Arg1);
14064 when Name_Statement_Assertions =>
14066 ("""Statement_Assertions"" is not allowed as a check kind "
14067 & "for pragma%", Arg1);
14073 -- Check applicable policy. We skip this if Checked/Ignored status
14074 -- is already set (e.g. in the case of a pragma from an aspect).
14076 if Is_Checked (N) or else Is_Ignored (N) then
14079 -- For a non-source pragma that is a rewriting of another pragma,
14080 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14082 elsif Is_Rewrite_Substitution (N)
14083 and then Nkind (Original_Node (N)) = N_Pragma
14085 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
14086 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
14088 -- Otherwise query the applicable policy at this point
14091 case Check_Kind (Cname) is
14092 when Name_Ignore =>
14093 Set_Is_Ignored (N, True);
14094 Set_Is_Checked (N, False);
14097 Set_Is_Ignored (N, False);
14098 Set_Is_Checked (N, True);
14100 -- For disable, rewrite pragma as null statement and skip
14101 -- rest of the analysis of the pragma.
14103 when Name_Disable =>
14104 Rewrite (N, Make_Null_Statement (Loc));
14108 -- No other possibilities
14111 raise Program_Error;
14115 -- If check kind was not Disable, then continue pragma analysis
14117 Expr := Get_Pragma_Arg (Arg2);
14119 -- Mark the pragma (or, if rewritten from an aspect, the original
14120 -- aspect) as enabled. Nothing to do for an internally generated
14121 -- check for a dynamic predicate.
14124 and then not Split_PPC (N)
14125 and then Cname /= Name_Dynamic_Predicate
14127 Set_SCO_Pragma_Enabled (Loc);
14130 -- Deal with analyzing the string argument. If checks are not
14131 -- on we don't want any expansion (since such expansion would
14132 -- not get properly deleted) but we do want to analyze (to get
14133 -- proper references). The Preanalyze_And_Resolve routine does
14134 -- just what we want. Ditto if pragma is active, because it will
14135 -- be rewritten as an if-statement whose analysis will complete
14136 -- analysis and expansion of the string message. This makes a
14137 -- difference in the unusual case where the expression for the
14138 -- string may have a side effect, such as raising an exception.
14139 -- This is mandated by RM 11.4.2, which specifies that the string
14140 -- expression is only evaluated if the check fails and
14141 -- Assertion_Error is to be raised.
14143 if Arg_Count = 3 then
14144 Preanalyze_And_Resolve (Str, Standard_String);
14147 -- Now you might think we could just do the same with the Boolean
14148 -- expression if checks are off (and expansion is on) and then
14149 -- rewrite the check as a null statement. This would work but we
14150 -- would lose the useful warnings about an assertion being bound
14151 -- to fail even if assertions are turned off.
14153 -- So instead we wrap the boolean expression in an if statement
14154 -- that looks like:
14156 -- if False and then condition then
14160 -- The reason we do this rewriting during semantic analysis rather
14161 -- than as part of normal expansion is that we cannot analyze and
14162 -- expand the code for the boolean expression directly, or it may
14163 -- cause insertion of actions that would escape the attempt to
14164 -- suppress the check code.
14166 -- Note that the Sloc for the if statement corresponds to the
14167 -- argument condition, not the pragma itself. The reason for
14168 -- this is that we may generate a warning if the condition is
14169 -- False at compile time, and we do not want to delete this
14170 -- warning when we delete the if statement.
14172 if Expander_Active and Is_Ignored (N) then
14173 Eloc := Sloc (Expr);
14176 Make_If_Statement (Eloc,
14178 Make_And_Then (Eloc,
14179 Left_Opnd => Make_Identifier (Eloc, Name_False),
14180 Right_Opnd => Expr),
14181 Then_Statements => New_List (
14182 Make_Null_Statement (Eloc))));
14184 -- Now go ahead and analyze the if statement
14186 In_Assertion_Expr := In_Assertion_Expr + 1;
14188 -- One rather special treatment. If we are now in Eliminated
14189 -- overflow mode, then suppress overflow checking since we do
14190 -- not want to drag in the bignum stuff if we are in Ignore
14191 -- mode anyway. This is particularly important if we are using
14192 -- a configurable run time that does not support bignum ops.
14194 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
14196 Svo : constant Boolean :=
14197 Scope_Suppress.Suppress (Overflow_Check);
14199 Scope_Suppress.Overflow_Mode_Assertions := Strict;
14200 Scope_Suppress.Suppress (Overflow_Check) := True;
14202 Scope_Suppress.Suppress (Overflow_Check) := Svo;
14203 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
14206 -- Not that special case
14212 -- All done with this check
14214 In_Assertion_Expr := In_Assertion_Expr - 1;
14216 -- Check is active or expansion not active. In these cases we can
14217 -- just go ahead and analyze the boolean with no worries.
14220 In_Assertion_Expr := In_Assertion_Expr + 1;
14221 Analyze_And_Resolve (Expr, Any_Boolean);
14222 In_Assertion_Expr := In_Assertion_Expr - 1;
14225 Restore_Ghost_Region (Saved_GM, Saved_IGR);
14228 --------------------------
14229 -- Check_Float_Overflow --
14230 --------------------------
14232 -- pragma Check_Float_Overflow;
14234 when Pragma_Check_Float_Overflow =>
14236 Check_Valid_Configuration_Pragma;
14237 Check_Arg_Count (0);
14238 Check_Float_Overflow := not Machine_Overflows_On_Target;
14244 -- pragma Check_Name (check_IDENTIFIER);
14246 when Pragma_Check_Name =>
14248 Check_No_Identifiers;
14249 Check_Valid_Configuration_Pragma;
14250 Check_Arg_Count (1);
14251 Check_Arg_Is_Identifier (Arg1);
14254 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
14257 for J in Check_Names.First .. Check_Names.Last loop
14258 if Check_Names.Table (J) = Nam then
14263 Check_Names.Append (Nam);
14270 -- This is the old style syntax, which is still allowed in all modes:
14272 -- pragma Check_Policy ([Name =>] CHECK_KIND
14273 -- [Policy =>] POLICY_IDENTIFIER);
14275 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14277 -- CHECK_KIND ::= IDENTIFIER |
14280 -- Type_Invariant'Class |
14283 -- This is the new style syntax, compatible with Assertion_Policy
14284 -- and also allowed in all modes.
14286 -- Pragma Check_Policy (
14287 -- CHECK_KIND => POLICY_IDENTIFIER
14288 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14290 -- Note: the identifiers Name and Policy are not allowed as
14291 -- Check_Kind values. This avoids ambiguities between the old and
14292 -- new form syntax.
14294 when Pragma_Check_Policy => Check_Policy : declare
14299 Check_At_Least_N_Arguments (1);
14301 -- A Check_Policy pragma can appear either as a configuration
14302 -- pragma, or in a declarative part or a package spec (see RM
14303 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14304 -- followed for Check_Policy).
14306 if not Is_Configuration_Pragma then
14307 Check_Is_In_Decl_Part_Or_Package_Spec;
14310 -- Figure out if we have the old or new syntax. We have the
14311 -- old syntax if the first argument has no identifier, or the
14312 -- identifier is Name.
14314 if Nkind (Arg1) /= N_Pragma_Argument_Association
14315 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
14319 Check_Arg_Count (2);
14320 Check_Optional_Identifier (Arg1, Name_Name);
14321 Kind := Get_Pragma_Arg (Arg1);
14322 Rewrite_Assertion_Kind (Kind,
14323 From_Policy => Comes_From_Source (N));
14324 Check_Arg_Is_Identifier (Arg1);
14326 -- Check forbidden check kind
14328 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
14329 Error_Msg_Name_2 := Chars (Kind);
14331 ("pragma% does not allow% as check name", Arg1);
14336 Check_Optional_Identifier (Arg2, Name_Policy);
14337 Check_Arg_Is_One_Of
14339 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14341 -- And chain pragma on the Check_Policy_List for search
14343 Set_Next_Pragma (N, Opt.Check_Policy_List);
14344 Opt.Check_Policy_List := N;
14346 -- For the new syntax, what we do is to convert each argument to
14347 -- an old syntax equivalent. We do that because we want to chain
14348 -- old style Check_Policy pragmas for the search (we don't want
14349 -- to have to deal with multiple arguments in the search).
14360 while Present (Arg) loop
14361 LocP := Sloc (Arg);
14362 Argx := Get_Pragma_Arg (Arg);
14364 -- Kind must be specified
14366 if Nkind (Arg) /= N_Pragma_Argument_Association
14367 or else Chars (Arg) = No_Name
14370 ("missing assertion kind for pragma%", Arg);
14373 -- Construct equivalent old form syntax Check_Policy
14374 -- pragma and insert it to get remaining checks.
14378 Chars => Name_Check_Policy,
14379 Pragma_Argument_Associations => New_List (
14380 Make_Pragma_Argument_Association (LocP,
14382 Make_Identifier (LocP, Chars (Arg))),
14383 Make_Pragma_Argument_Association (Sloc (Argx),
14384 Expression => Argx)));
14388 -- For a configuration pragma, insert old form in
14389 -- the corresponding file.
14391 if Is_Configuration_Pragma then
14392 Insert_After (N, New_P);
14396 Insert_Action (N, New_P);
14400 -- Rewrite original Check_Policy pragma to null, since we
14401 -- have converted it into a series of old syntax pragmas.
14403 Rewrite (N, Make_Null_Statement (Loc));
14413 -- pragma Comment (static_string_EXPRESSION)
14415 -- Processing for pragma Comment shares the circuitry for pragma
14416 -- Ident. The only differences are that Ident enforces a limit of 31
14417 -- characters on its argument, and also enforces limitations on
14418 -- placement for DEC compatibility. Pragma Comment shares neither of
14419 -- these restrictions.
14421 -------------------
14422 -- Common_Object --
14423 -------------------
14425 -- pragma Common_Object (
14426 -- [Internal =>] LOCAL_NAME
14427 -- [, [External =>] EXTERNAL_SYMBOL]
14428 -- [, [Size =>] EXTERNAL_SYMBOL]);
14430 -- Processing for this pragma is shared with Psect_Object
14432 ----------------------------------------------
14433 -- Compile_Time_Error, Compile_Time_Warning --
14434 ----------------------------------------------
14436 -- pragma Compile_Time_Error
14437 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14439 -- pragma Compile_Time_Warning
14440 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14442 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14444 Process_Compile_Time_Warning_Or_Error;
14446 ---------------------------
14447 -- Compiler_Unit_Warning --
14448 ---------------------------
14450 -- pragma Compiler_Unit_Warning;
14454 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14455 -- errors not warnings. This means that we had introduced a big extra
14456 -- inertia to compiler changes, since even if we implemented a new
14457 -- feature, and even if all versions to be used for bootstrapping
14458 -- implemented this new feature, we could not use it, since old
14459 -- compilers would give errors for using this feature in units
14460 -- having Compiler_Unit pragmas.
14462 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14463 -- problem. We no longer have any units mentioning Compiler_Unit,
14464 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14465 -- and thus generates a warning which can be ignored. So that deals
14466 -- with the problem of old compilers not implementing the newer form
14469 -- Newer compilers recognize the new pragma, but generate warning
14470 -- messages instead of errors, which again can be ignored in the
14471 -- case of an old compiler which implements a wanted new feature
14472 -- but at the time felt like warning about it for older compilers.
14474 -- We retain Compiler_Unit so that new compilers can be used to build
14475 -- older run-times that use this pragma. That's an unusual case, but
14476 -- it's easy enough to handle, so why not?
14478 when Pragma_Compiler_Unit
14479 | Pragma_Compiler_Unit_Warning
14482 Check_Arg_Count (0);
14484 -- Only recognized in main unit
14486 if Current_Sem_Unit = Main_Unit then
14487 Compiler_Unit := True;
14490 -----------------------------
14491 -- Complete_Representation --
14492 -----------------------------
14494 -- pragma Complete_Representation;
14496 when Pragma_Complete_Representation =>
14498 Check_Arg_Count (0);
14500 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14502 ("pragma & must appear within record representation clause");
14505 ----------------------------
14506 -- Complex_Representation --
14507 ----------------------------
14509 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14511 when Pragma_Complex_Representation => Complex_Representation : declare
14518 Check_Arg_Count (1);
14519 Check_Optional_Identifier (Arg1, Name_Entity);
14520 Check_Arg_Is_Local_Name (Arg1);
14521 E_Id := Get_Pragma_Arg (Arg1);
14523 if Etype (E_Id) = Any_Type then
14527 E := Entity (E_Id);
14529 if not Is_Record_Type (E) then
14531 ("argument for pragma% must be record type", Arg1);
14534 Ent := First_Entity (E);
14537 or else No (Next_Entity (Ent))
14538 or else Present (Next_Entity (Next_Entity (Ent)))
14539 or else not Is_Floating_Point_Type (Etype (Ent))
14540 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14543 ("record for pragma% must have two fields of the same "
14544 & "floating-point type", Arg1);
14547 Set_Has_Complex_Representation (Base_Type (E));
14549 -- We need to treat the type has having a non-standard
14550 -- representation, for back-end purposes, even though in
14551 -- general a complex will have the default representation
14552 -- of a record with two real components.
14554 Set_Has_Non_Standard_Rep (Base_Type (E));
14556 end Complex_Representation;
14558 -------------------------
14559 -- Component_Alignment --
14560 -------------------------
14562 -- pragma Component_Alignment (
14563 -- [Form =>] ALIGNMENT_CHOICE
14564 -- [, [Name =>] type_LOCAL_NAME]);
14566 -- ALIGNMENT_CHOICE ::=
14568 -- | Component_Size_4
14572 when Pragma_Component_Alignment => Component_AlignmentP : declare
14573 Args : Args_List (1 .. 2);
14574 Names : constant Name_List (1 .. 2) := (
14578 Form : Node_Id renames Args (1);
14579 Name : Node_Id renames Args (2);
14581 Atype : Component_Alignment_Kind;
14586 Gather_Associations (Names, Args);
14589 Error_Pragma ("missing Form argument for pragma%");
14592 Check_Arg_Is_Identifier (Form);
14594 -- Get proper alignment, note that Default = Component_Size on all
14595 -- machines we have so far, and we want to set this value rather
14596 -- than the default value to indicate that it has been explicitly
14597 -- set (and thus will not get overridden by the default component
14598 -- alignment for the current scope)
14600 if Chars (Form) = Name_Component_Size then
14601 Atype := Calign_Component_Size;
14603 elsif Chars (Form) = Name_Component_Size_4 then
14604 Atype := Calign_Component_Size_4;
14606 elsif Chars (Form) = Name_Default then
14607 Atype := Calign_Component_Size;
14609 elsif Chars (Form) = Name_Storage_Unit then
14610 Atype := Calign_Storage_Unit;
14614 ("invalid Form parameter for pragma%", Form);
14617 -- The pragma appears in a configuration file
14619 if No (Parent (N)) then
14620 Check_Valid_Configuration_Pragma;
14622 -- Capture the component alignment in a global variable when
14623 -- the pragma appears in a configuration file. Note that the
14624 -- scope stack is empty at this point and cannot be used to
14625 -- store the alignment value.
14627 Configuration_Component_Alignment := Atype;
14629 -- Case with no name, supplied, affects scope table entry
14631 elsif No (Name) then
14633 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14635 -- Case of name supplied
14638 Check_Arg_Is_Local_Name (Name);
14640 Typ := Entity (Name);
14643 or else Rep_Item_Too_Early (Typ, N)
14647 Typ := Underlying_Type (Typ);
14650 if not Is_Record_Type (Typ)
14651 and then not Is_Array_Type (Typ)
14654 ("Name parameter of pragma% must identify record or "
14655 & "array type", Name);
14658 -- An explicit Component_Alignment pragma overrides an
14659 -- implicit pragma Pack, but not an explicit one.
14661 if not Has_Pragma_Pack (Base_Type (Typ)) then
14662 Set_Is_Packed (Base_Type (Typ), False);
14663 Set_Component_Alignment (Base_Type (Typ), Atype);
14666 end Component_AlignmentP;
14668 --------------------------------
14669 -- Constant_After_Elaboration --
14670 --------------------------------
14672 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14674 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14676 Obj_Decl : Node_Id;
14677 Obj_Id : Entity_Id;
14681 Check_No_Identifiers;
14682 Check_At_Most_N_Arguments (1);
14684 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14686 if Nkind (Obj_Decl) /= N_Object_Declaration then
14691 Obj_Id := Defining_Entity (Obj_Decl);
14693 -- The object declaration must be a library-level variable which
14694 -- is either explicitly initialized or obtains a value during the
14695 -- elaboration of a package body (SPARK RM 3.3.1).
14697 if Ekind (Obj_Id) = E_Variable then
14698 if not Is_Library_Level_Entity (Obj_Id) then
14700 ("pragma % must apply to a library level variable");
14704 -- Otherwise the pragma applies to a constant, which is illegal
14707 Error_Pragma ("pragma % must apply to a variable declaration");
14711 -- A pragma that applies to a Ghost entity becomes Ghost for the
14712 -- purposes of legality checks and removal of ignored Ghost code.
14714 Mark_Ghost_Pragma (N, Obj_Id);
14716 -- Chain the pragma on the contract for completeness
14718 Add_Contract_Item (N, Obj_Id);
14720 -- Analyze the Boolean expression (if any)
14722 if Present (Arg1) then
14723 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14725 end Constant_After_Elaboration;
14727 --------------------
14728 -- Contract_Cases --
14729 --------------------
14731 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14733 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14735 -- CASE_GUARD ::= boolean_EXPRESSION | others
14737 -- CONSEQUENCE ::= boolean_EXPRESSION
14739 -- Characteristics:
14741 -- * Analysis - The annotation undergoes initial checks to verify
14742 -- the legal placement and context. Secondary checks preanalyze the
14745 -- Analyze_Contract_Cases_In_Decl_Part
14747 -- * Expansion - The annotation is expanded during the expansion of
14748 -- the related subprogram [body] contract as performed in:
14750 -- Expand_Subprogram_Contract
14752 -- * Template - The annotation utilizes the generic template of the
14753 -- related subprogram [body] when it is:
14755 -- aspect on subprogram declaration
14756 -- aspect on stand-alone subprogram body
14757 -- pragma on stand-alone subprogram body
14759 -- The annotation must prepare its own template when it is:
14761 -- pragma on subprogram declaration
14763 -- * Globals - Capture of global references must occur after full
14766 -- * Instance - The annotation is instantiated automatically when
14767 -- the related generic subprogram [body] is instantiated except for
14768 -- the "pragma on subprogram declaration" case. In that scenario
14769 -- the annotation must instantiate itself.
14771 when Pragma_Contract_Cases => Contract_Cases : declare
14772 Spec_Id : Entity_Id;
14773 Subp_Decl : Node_Id;
14774 Subp_Spec : Node_Id;
14778 Check_No_Identifiers;
14779 Check_Arg_Count (1);
14781 -- Ensure the proper placement of the pragma. Contract_Cases must
14782 -- be associated with a subprogram declaration or a body that acts
14786 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14790 if Nkind (Subp_Decl) = N_Entry_Declaration then
14793 -- Generic subprogram
14795 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14798 -- Body acts as spec
14800 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14801 and then No (Corresponding_Spec (Subp_Decl))
14805 -- Body stub acts as spec
14807 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14808 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14814 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14815 Subp_Spec := Specification (Subp_Decl);
14817 -- Pragma Contract_Cases is forbidden on null procedures, as
14818 -- this may lead to potential ambiguities in behavior when
14819 -- interface null procedures are involved.
14821 if Nkind (Subp_Spec) = N_Procedure_Specification
14822 and then Null_Present (Subp_Spec)
14824 Error_Msg_N (Fix_Error
14825 ("pragma % cannot apply to null procedure"), N);
14834 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14836 -- A pragma that applies to a Ghost entity becomes Ghost for the
14837 -- purposes of legality checks and removal of ignored Ghost code.
14839 Mark_Ghost_Pragma (N, Spec_Id);
14840 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14842 -- Chain the pragma on the contract for further processing by
14843 -- Analyze_Contract_Cases_In_Decl_Part.
14845 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14847 -- Fully analyze the pragma when it appears inside an entry
14848 -- or subprogram body because it cannot benefit from forward
14851 if Nkind_In (Subp_Decl, N_Entry_Body,
14853 N_Subprogram_Body_Stub)
14855 -- The legality checks of pragma Contract_Cases are affected by
14856 -- the SPARK mode in effect and the volatility of the context.
14857 -- Analyze all pragmas in a specific order.
14859 Analyze_If_Present (Pragma_SPARK_Mode);
14860 Analyze_If_Present (Pragma_Volatile_Function);
14861 Analyze_Contract_Cases_In_Decl_Part (N);
14863 end Contract_Cases;
14869 -- pragma Controlled (first_subtype_LOCAL_NAME);
14871 when Pragma_Controlled => Controlled : declare
14875 Check_No_Identifiers;
14876 Check_Arg_Count (1);
14877 Check_Arg_Is_Local_Name (Arg1);
14878 Arg := Get_Pragma_Arg (Arg1);
14880 if not Is_Entity_Name (Arg)
14881 or else not Is_Access_Type (Entity (Arg))
14883 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14885 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14893 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14894 -- [Entity =>] LOCAL_NAME);
14896 when Pragma_Convention => Convention : declare
14899 pragma Warnings (Off, C);
14900 pragma Warnings (Off, E);
14903 Check_Arg_Order ((Name_Convention, Name_Entity));
14904 Check_Ada_83_Warning;
14905 Check_Arg_Count (2);
14906 Process_Convention (C, E);
14908 -- A pragma that applies to a Ghost entity becomes Ghost for the
14909 -- purposes of legality checks and removal of ignored Ghost code.
14911 Mark_Ghost_Pragma (N, E);
14914 ---------------------------
14915 -- Convention_Identifier --
14916 ---------------------------
14918 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14919 -- [Convention =>] convention_IDENTIFIER);
14921 when Pragma_Convention_Identifier => Convention_Identifier : declare
14927 Check_Arg_Order ((Name_Name, Name_Convention));
14928 Check_Arg_Count (2);
14929 Check_Optional_Identifier (Arg1, Name_Name);
14930 Check_Optional_Identifier (Arg2, Name_Convention);
14931 Check_Arg_Is_Identifier (Arg1);
14932 Check_Arg_Is_Identifier (Arg2);
14933 Idnam := Chars (Get_Pragma_Arg (Arg1));
14934 Cname := Chars (Get_Pragma_Arg (Arg2));
14936 if Is_Convention_Name (Cname) then
14937 Record_Convention_Identifier
14938 (Idnam, Get_Convention_Id (Cname));
14941 ("second arg for % pragma must be convention", Arg2);
14943 end Convention_Identifier;
14949 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14951 when Pragma_CPP_Class =>
14954 if Warn_On_Obsolescent_Feature then
14956 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14957 & "effect; replace it by pragma import?j?", N);
14960 Check_Arg_Count (1);
14964 Chars => Name_Import,
14965 Pragma_Argument_Associations => New_List (
14966 Make_Pragma_Argument_Association (Loc,
14967 Expression => Make_Identifier (Loc, Name_CPP)),
14968 New_Copy (First (Pragma_Argument_Associations (N))))));
14971 ---------------------
14972 -- CPP_Constructor --
14973 ---------------------
14975 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14976 -- [, [External_Name =>] static_string_EXPRESSION ]
14977 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14979 when Pragma_CPP_Constructor => CPP_Constructor : declare
14982 Def_Id : Entity_Id;
14983 Tag_Typ : Entity_Id;
14987 Check_At_Least_N_Arguments (1);
14988 Check_At_Most_N_Arguments (3);
14989 Check_Optional_Identifier (Arg1, Name_Entity);
14990 Check_Arg_Is_Local_Name (Arg1);
14992 Id := Get_Pragma_Arg (Arg1);
14993 Find_Program_Unit_Name (Id);
14995 -- If we did not find the name, we are done
14997 if Etype (Id) = Any_Type then
15001 Def_Id := Entity (Id);
15003 -- Check if already defined as constructor
15005 if Is_Constructor (Def_Id) then
15007 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
15011 if Ekind (Def_Id) = E_Function
15012 and then (Is_CPP_Class (Etype (Def_Id))
15013 or else (Is_Class_Wide_Type (Etype (Def_Id))
15015 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
15017 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
15019 ("'C'P'P constructor must be defined in the scope of "
15020 & "its returned type", Arg1);
15023 if Arg_Count >= 2 then
15024 Set_Imported (Def_Id);
15025 Set_Is_Public (Def_Id);
15026 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
15029 Set_Has_Completion (Def_Id);
15030 Set_Is_Constructor (Def_Id);
15031 Set_Convention (Def_Id, Convention_CPP);
15033 -- Imported C++ constructors are not dispatching primitives
15034 -- because in C++ they don't have a dispatch table slot.
15035 -- However, in Ada the constructor has the profile of a
15036 -- function that returns a tagged type and therefore it has
15037 -- been treated as a primitive operation during semantic
15038 -- analysis. We now remove it from the list of primitive
15039 -- operations of the type.
15041 if Is_Tagged_Type (Etype (Def_Id))
15042 and then not Is_Class_Wide_Type (Etype (Def_Id))
15043 and then Is_Dispatching_Operation (Def_Id)
15045 Tag_Typ := Etype (Def_Id);
15047 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
15048 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
15052 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
15053 Set_Is_Dispatching_Operation (Def_Id, False);
15056 -- For backward compatibility, if the constructor returns a
15057 -- class wide type, and we internally change the return type to
15058 -- the corresponding root type.
15060 if Is_Class_Wide_Type (Etype (Def_Id)) then
15061 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
15065 ("pragma% requires function returning a 'C'P'P_Class type",
15068 end CPP_Constructor;
15074 when Pragma_CPP_Virtual =>
15077 if Warn_On_Obsolescent_Feature then
15079 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15087 when Pragma_CPP_Vtable =>
15090 if Warn_On_Obsolescent_Feature then
15092 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15100 -- pragma CPU (EXPRESSION);
15102 when Pragma_CPU => CPU : declare
15103 P : constant Node_Id := Parent (N);
15109 Check_No_Identifiers;
15110 Check_Arg_Count (1);
15114 if Nkind (P) = N_Subprogram_Body then
15115 Check_In_Main_Program;
15117 Arg := Get_Pragma_Arg (Arg1);
15118 Analyze_And_Resolve (Arg, Any_Integer);
15120 Ent := Defining_Unit_Name (Specification (P));
15122 if Nkind (Ent) = N_Defining_Program_Unit_Name then
15123 Ent := Defining_Identifier (Ent);
15128 if not Is_OK_Static_Expression (Arg) then
15129 Flag_Non_Static_Expr
15130 ("main subprogram affinity is not static!", Arg);
15133 -- If constraint error, then we already signalled an error
15135 elsif Raises_Constraint_Error (Arg) then
15138 -- Otherwise check in range
15142 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
15143 -- This is the entity System.Multiprocessors.CPU_Range;
15145 Val : constant Uint := Expr_Value (Arg);
15148 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
15150 Val > Expr_Value (Type_High_Bound (CPU_Id))
15153 ("main subprogram CPU is out of range", Arg1);
15159 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
15163 elsif Nkind (P) = N_Task_Definition then
15164 Arg := Get_Pragma_Arg (Arg1);
15165 Ent := Defining_Identifier (Parent (P));
15167 -- The expression must be analyzed in the special manner
15168 -- described in "Handling of Default and Per-Object
15169 -- Expressions" in sem.ads.
15171 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
15173 -- Anything else is incorrect
15179 -- Check duplicate pragma before we chain the pragma in the Rep
15180 -- Item chain of Ent.
15182 Check_Duplicate_Pragma (Ent);
15183 Record_Rep_Item (Ent, N);
15186 --------------------
15187 -- Deadline_Floor --
15188 --------------------
15190 -- pragma Deadline_Floor (time_span_EXPRESSION);
15192 when Pragma_Deadline_Floor => Deadline_Floor : declare
15193 P : constant Node_Id := Parent (N);
15199 Check_No_Identifiers;
15200 Check_Arg_Count (1);
15202 Arg := Get_Pragma_Arg (Arg1);
15204 -- The expression must be analyzed in the special manner described
15205 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15207 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15209 -- Only protected types allowed
15211 if Nkind (P) /= N_Protected_Definition then
15215 Ent := Defining_Identifier (Parent (P));
15217 -- Check duplicate pragma before we chain the pragma in the Rep
15218 -- Item chain of Ent.
15220 Check_Duplicate_Pragma (Ent);
15221 Record_Rep_Item (Ent, N);
15223 end Deadline_Floor;
15229 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15231 when Pragma_Debug => Debug : declare
15238 -- The condition for executing the call is that the expander
15239 -- is active and that we are not ignoring this debug pragma.
15244 (Expander_Active and then not Is_Ignored (N)),
15247 if not Is_Ignored (N) then
15248 Set_SCO_Pragma_Enabled (Loc);
15251 if Arg_Count = 2 then
15253 Make_And_Then (Loc,
15254 Left_Opnd => Relocate_Node (Cond),
15255 Right_Opnd => Get_Pragma_Arg (Arg1));
15256 Call := Get_Pragma_Arg (Arg2);
15258 Call := Get_Pragma_Arg (Arg1);
15261 if Nkind_In (Call, N_Expanded_Name,
15264 N_Indexed_Component,
15265 N_Selected_Component)
15267 -- If this pragma Debug comes from source, its argument was
15268 -- parsed as a name form (which is syntactically identical).
15269 -- In a generic context a parameterless call will be left as
15270 -- an expanded name (if global) or selected_component if local.
15271 -- Change it to a procedure call statement now.
15273 Change_Name_To_Procedure_Call_Statement (Call);
15275 elsif Nkind (Call) = N_Procedure_Call_Statement then
15277 -- Already in the form of a procedure call statement: nothing
15278 -- to do (could happen in case of an internally generated
15284 -- All other cases: diagnose error
15287 ("argument of pragma ""Debug"" is not procedure call",
15292 -- Rewrite into a conditional with an appropriate condition. We
15293 -- wrap the procedure call in a block so that overhead from e.g.
15294 -- use of the secondary stack does not generate execution overhead
15295 -- for suppressed conditions.
15297 -- Normally the analysis that follows will freeze the subprogram
15298 -- being called. However, if the call is to a null procedure,
15299 -- we want to freeze it before creating the block, because the
15300 -- analysis that follows may be done with expansion disabled, in
15301 -- which case the body will not be generated, leading to spurious
15304 if Nkind (Call) = N_Procedure_Call_Statement
15305 and then Is_Entity_Name (Name (Call))
15307 Analyze (Name (Call));
15308 Freeze_Before (N, Entity (Name (Call)));
15312 Make_Implicit_If_Statement (N,
15314 Then_Statements => New_List (
15315 Make_Block_Statement (Loc,
15316 Handled_Statement_Sequence =>
15317 Make_Handled_Sequence_Of_Statements (Loc,
15318 Statements => New_List (Relocate_Node (Call)))))));
15321 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15322 -- after analysis of the normally rewritten node, to capture all
15323 -- references to entities, which avoids issuing wrong warnings
15324 -- about unused entities.
15326 if GNATprove_Mode then
15327 Rewrite (N, Make_Null_Statement (Loc));
15335 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15337 when Pragma_Debug_Policy =>
15339 Check_Arg_Count (1);
15340 Check_No_Identifiers;
15341 Check_Arg_Is_Identifier (Arg1);
15343 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15344 -- rewrite it that way, and let the rest of the checking come
15345 -- from analyzing the rewritten pragma.
15349 Chars => Name_Check_Policy,
15350 Pragma_Argument_Associations => New_List (
15351 Make_Pragma_Argument_Association (Loc,
15352 Expression => Make_Identifier (Loc, Name_Debug)),
15354 Make_Pragma_Argument_Association (Loc,
15355 Expression => Get_Pragma_Arg (Arg1)))));
15358 -------------------------------
15359 -- Default_Initial_Condition --
15360 -------------------------------
15362 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15364 when Pragma_Default_Initial_Condition => DIC : declare
15371 Check_No_Identifiers;
15372 Check_At_Most_N_Arguments (1);
15376 while Present (Stmt) loop
15378 -- Skip prior pragmas, but check for duplicates
15380 if Nkind (Stmt) = N_Pragma then
15381 if Pragma_Name (Stmt) = Pname then
15388 -- Skip internally generated code. Note that derived type
15389 -- declarations of untagged types with discriminants are
15390 -- rewritten as private type declarations.
15392 elsif not Comes_From_Source (Stmt)
15393 and then Nkind (Stmt) /= N_Private_Type_Declaration
15397 -- The associated private type [extension] has been found, stop
15400 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
15401 N_Private_Type_Declaration)
15403 Typ := Defining_Entity (Stmt);
15406 -- The pragma does not apply to a legal construct, issue an
15407 -- error and stop the analysis.
15414 Stmt := Prev (Stmt);
15417 -- The pragma does not apply to a legal construct, issue an error
15418 -- and stop the analysis.
15425 -- A pragma that applies to a Ghost entity becomes Ghost for the
15426 -- purposes of legality checks and removal of ignored Ghost code.
15428 Mark_Ghost_Pragma (N, Typ);
15430 -- The pragma signals that the type defines its own DIC assertion
15433 Set_Has_Own_DIC (Typ);
15435 -- Chain the pragma on the rep item chain for further processing
15437 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15439 -- Create the declaration of the procedure which verifies the
15440 -- assertion expression of pragma DIC at runtime.
15442 Build_DIC_Procedure_Declaration (Typ);
15445 ----------------------------------
15446 -- Default_Scalar_Storage_Order --
15447 ----------------------------------
15449 -- pragma Default_Scalar_Storage_Order
15450 -- (High_Order_First | Low_Order_First);
15452 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15453 Default : Character;
15457 Check_Arg_Count (1);
15459 -- Default_Scalar_Storage_Order can appear as a configuration
15460 -- pragma, or in a declarative part of a package spec.
15462 if not Is_Configuration_Pragma then
15463 Check_Is_In_Decl_Part_Or_Package_Spec;
15466 Check_No_Identifiers;
15467 Check_Arg_Is_One_Of
15468 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15469 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15470 Default := Fold_Upper (Name_Buffer (1));
15472 if not Support_Nondefault_SSO_On_Target
15473 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15475 if Warn_On_Unrecognized_Pragma then
15477 ("non-default Scalar_Storage_Order not supported "
15478 & "on target?g?", N);
15480 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15483 -- Here set the specified default
15486 Opt.Default_SSO := Default;
15490 --------------------------
15491 -- Default_Storage_Pool --
15492 --------------------------
15494 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15496 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15501 Check_Arg_Count (1);
15503 -- Default_Storage_Pool can appear as a configuration pragma, or
15504 -- in a declarative part of a package spec.
15506 if not Is_Configuration_Pragma then
15507 Check_Is_In_Decl_Part_Or_Package_Spec;
15510 if From_Aspect_Specification (N) then
15512 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15514 if not In_Open_Scopes (E) then
15516 ("aspect must apply to package or subprogram", N);
15521 if Present (Arg1) then
15522 Pool := Get_Pragma_Arg (Arg1);
15524 -- Case of Default_Storage_Pool (null);
15526 if Nkind (Pool) = N_Null then
15529 -- This is an odd case, this is not really an expression,
15530 -- so we don't have a type for it. So just set the type to
15533 Set_Etype (Pool, Empty);
15535 -- Case of Default_Storage_Pool (storage_pool_NAME);
15538 -- If it's a configuration pragma, then the only allowed
15539 -- argument is "null".
15541 if Is_Configuration_Pragma then
15542 Error_Pragma_Arg ("NULL expected", Arg1);
15545 -- The expected type for a non-"null" argument is
15546 -- Root_Storage_Pool'Class, and the pool must be a variable.
15548 Analyze_And_Resolve
15549 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15551 if Is_Variable (Pool) then
15553 -- A pragma that applies to a Ghost entity becomes Ghost
15554 -- for the purposes of legality checks and removal of
15555 -- ignored Ghost code.
15557 Mark_Ghost_Pragma (N, Entity (Pool));
15561 ("default storage pool must be a variable", Arg1);
15565 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15566 -- access type will use this information to set the appropriate
15567 -- attributes of the access type. If the pragma appears in a
15568 -- generic unit it is ignored, given that it may refer to a
15571 if not Inside_A_Generic then
15572 Default_Pool := Pool;
15575 end Default_Storage_Pool;
15581 -- pragma Depends (DEPENDENCY_RELATION);
15583 -- DEPENDENCY_RELATION ::=
15585 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15587 -- DEPENDENCY_CLAUSE ::=
15588 -- OUTPUT_LIST =>[+] INPUT_LIST
15589 -- | NULL_DEPENDENCY_CLAUSE
15591 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15593 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15595 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15597 -- OUTPUT ::= NAME | FUNCTION_RESULT
15600 -- where FUNCTION_RESULT is a function Result attribute_reference
15602 -- Characteristics:
15604 -- * Analysis - The annotation undergoes initial checks to verify
15605 -- the legal placement and context. Secondary checks fully analyze
15606 -- the dependency clauses in:
15608 -- Analyze_Depends_In_Decl_Part
15610 -- * Expansion - None.
15612 -- * Template - The annotation utilizes the generic template of the
15613 -- related subprogram [body] when it is:
15615 -- aspect on subprogram declaration
15616 -- aspect on stand-alone subprogram body
15617 -- pragma on stand-alone subprogram body
15619 -- The annotation must prepare its own template when it is:
15621 -- pragma on subprogram declaration
15623 -- * Globals - Capture of global references must occur after full
15626 -- * Instance - The annotation is instantiated automatically when
15627 -- the related generic subprogram [body] is instantiated except for
15628 -- the "pragma on subprogram declaration" case. In that scenario
15629 -- the annotation must instantiate itself.
15631 when Pragma_Depends => Depends : declare
15633 Spec_Id : Entity_Id;
15634 Subp_Decl : Node_Id;
15637 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15641 -- Chain the pragma on the contract for further processing by
15642 -- Analyze_Depends_In_Decl_Part.
15644 Add_Contract_Item (N, Spec_Id);
15646 -- Fully analyze the pragma when it appears inside an entry
15647 -- or subprogram body because it cannot benefit from forward
15650 if Nkind_In (Subp_Decl, N_Entry_Body,
15652 N_Subprogram_Body_Stub)
15654 -- The legality checks of pragmas Depends and Global are
15655 -- affected by the SPARK mode in effect and the volatility
15656 -- of the context. In addition these two pragmas are subject
15657 -- to an inherent order:
15662 -- Analyze all these pragmas in the order outlined above
15664 Analyze_If_Present (Pragma_SPARK_Mode);
15665 Analyze_If_Present (Pragma_Volatile_Function);
15666 Analyze_If_Present (Pragma_Global);
15667 Analyze_Depends_In_Decl_Part (N);
15672 ---------------------
15673 -- Detect_Blocking --
15674 ---------------------
15676 -- pragma Detect_Blocking;
15678 when Pragma_Detect_Blocking =>
15680 Check_Arg_Count (0);
15681 Check_Valid_Configuration_Pragma;
15682 Detect_Blocking := True;
15684 ------------------------------------
15685 -- Disable_Atomic_Synchronization --
15686 ------------------------------------
15688 -- pragma Disable_Atomic_Synchronization [(Entity)];
15690 when Pragma_Disable_Atomic_Synchronization =>
15692 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15694 -------------------
15695 -- Discard_Names --
15696 -------------------
15698 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15700 when Pragma_Discard_Names => Discard_Names : declare
15705 Check_Ada_83_Warning;
15707 -- Deal with configuration pragma case
15709 if Arg_Count = 0 and then Is_Configuration_Pragma then
15710 Global_Discard_Names := True;
15713 -- Otherwise, check correct appropriate context
15716 Check_Is_In_Decl_Part_Or_Package_Spec;
15718 if Arg_Count = 0 then
15720 -- If there is no parameter, then from now on this pragma
15721 -- applies to any enumeration, exception or tagged type
15722 -- defined in the current declarative part, and recursively
15723 -- to any nested scope.
15725 Set_Discard_Names (Current_Scope);
15729 Check_Arg_Count (1);
15730 Check_Optional_Identifier (Arg1, Name_On);
15731 Check_Arg_Is_Local_Name (Arg1);
15733 E_Id := Get_Pragma_Arg (Arg1);
15735 if Etype (E_Id) = Any_Type then
15739 E := Entity (E_Id);
15741 -- A pragma that applies to a Ghost entity becomes Ghost for
15742 -- the purposes of legality checks and removal of ignored
15745 Mark_Ghost_Pragma (N, E);
15747 if (Is_First_Subtype (E)
15749 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15750 or else Ekind (E) = E_Exception
15752 Set_Discard_Names (E);
15753 Record_Rep_Item (E, N);
15757 ("inappropriate entity for pragma%", Arg1);
15763 ------------------------
15764 -- Dispatching_Domain --
15765 ------------------------
15767 -- pragma Dispatching_Domain (EXPRESSION);
15769 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15770 P : constant Node_Id := Parent (N);
15776 Check_No_Identifiers;
15777 Check_Arg_Count (1);
15779 -- This pragma is born obsolete, but not the aspect
15781 if not From_Aspect_Specification (N) then
15783 (No_Obsolescent_Features, Pragma_Identifier (N));
15786 if Nkind (P) = N_Task_Definition then
15787 Arg := Get_Pragma_Arg (Arg1);
15788 Ent := Defining_Identifier (Parent (P));
15790 -- A pragma that applies to a Ghost entity becomes Ghost for
15791 -- the purposes of legality checks and removal of ignored Ghost
15794 Mark_Ghost_Pragma (N, Ent);
15796 -- The expression must be analyzed in the special manner
15797 -- described in "Handling of Default and Per-Object
15798 -- Expressions" in sem.ads.
15800 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15802 -- Check duplicate pragma before we chain the pragma in the Rep
15803 -- Item chain of Ent.
15805 Check_Duplicate_Pragma (Ent);
15806 Record_Rep_Item (Ent, N);
15808 -- Anything else is incorrect
15813 end Dispatching_Domain;
15819 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15821 when Pragma_Elaborate => Elaborate : declare
15826 -- Pragma must be in context items list of a compilation unit
15828 if not Is_In_Context_Clause then
15832 -- Must be at least one argument
15834 if Arg_Count = 0 then
15835 Error_Pragma ("pragma% requires at least one argument");
15838 -- In Ada 83 mode, there can be no items following it in the
15839 -- context list except other pragmas and implicit with clauses
15840 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15841 -- placement rule does not apply.
15843 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15845 while Present (Citem) loop
15846 if Nkind (Citem) = N_Pragma
15847 or else (Nkind (Citem) = N_With_Clause
15848 and then Implicit_With (Citem))
15853 ("(Ada 83) pragma% must be at end of context clause");
15860 -- Finally, the arguments must all be units mentioned in a with
15861 -- clause in the same context clause. Note we already checked (in
15862 -- Par.Prag) that the arguments are all identifiers or selected
15866 Outer : while Present (Arg) loop
15867 Citem := First (List_Containing (N));
15868 Inner : while Citem /= N loop
15869 if Nkind (Citem) = N_With_Clause
15870 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15872 Set_Elaborate_Present (Citem, True);
15873 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15875 -- With the pragma present, elaboration calls on
15876 -- subprograms from the named unit need no further
15877 -- checks, as long as the pragma appears in the current
15878 -- compilation unit. If the pragma appears in some unit
15879 -- in the context, there might still be a need for an
15880 -- Elaborate_All_Desirable from the current compilation
15881 -- to the named unit, so we keep the check enabled. This
15882 -- does not apply in SPARK mode, where we allow pragma
15883 -- Elaborate, but we don't trust it to be right so we
15884 -- will still insist on the Elaborate_All.
15886 if Legacy_Elaboration_Checks
15887 and then In_Extended_Main_Source_Unit (N)
15888 and then SPARK_Mode /= On
15890 Set_Suppress_Elaboration_Warnings
15891 (Entity (Name (Citem)));
15902 ("argument of pragma% is not withed unit", Arg);
15909 -------------------
15910 -- Elaborate_All --
15911 -------------------
15913 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15915 when Pragma_Elaborate_All => Elaborate_All : declare
15920 Check_Ada_83_Warning;
15922 -- Pragma must be in context items list of a compilation unit
15924 if not Is_In_Context_Clause then
15928 -- Must be at least one argument
15930 if Arg_Count = 0 then
15931 Error_Pragma ("pragma% requires at least one argument");
15934 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15935 -- have to appear at the end of the context clause, but may
15936 -- appear mixed in with other items, even in Ada 83 mode.
15938 -- Final check: the arguments must all be units mentioned in
15939 -- a with clause in the same context clause. Note that we
15940 -- already checked (in Par.Prag) that all the arguments are
15941 -- either identifiers or selected components.
15944 Outr : while Present (Arg) loop
15945 Citem := First (List_Containing (N));
15946 Innr : while Citem /= N loop
15947 if Nkind (Citem) = N_With_Clause
15948 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15950 Set_Elaborate_All_Present (Citem, True);
15951 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15953 -- Suppress warnings and elaboration checks on the named
15954 -- unit if the pragma is in the current compilation, as
15955 -- for pragma Elaborate.
15957 if Legacy_Elaboration_Checks
15958 and then In_Extended_Main_Source_Unit (N)
15960 Set_Suppress_Elaboration_Warnings
15961 (Entity (Name (Citem)));
15971 Set_Error_Posted (N);
15973 ("argument of pragma% is not withed unit", Arg);
15980 --------------------
15981 -- Elaborate_Body --
15982 --------------------
15984 -- pragma Elaborate_Body [( library_unit_NAME )];
15986 when Pragma_Elaborate_Body => Elaborate_Body : declare
15987 Cunit_Node : Node_Id;
15988 Cunit_Ent : Entity_Id;
15991 Check_Ada_83_Warning;
15992 Check_Valid_Library_Unit_Pragma;
15994 if Nkind (N) = N_Null_Statement then
15998 Cunit_Node := Cunit (Current_Sem_Unit);
15999 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16001 -- A pragma that applies to a Ghost entity becomes Ghost for the
16002 -- purposes of legality checks and removal of ignored Ghost code.
16004 Mark_Ghost_Pragma (N, Cunit_Ent);
16006 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
16009 Error_Pragma ("pragma% must refer to a spec, not a body");
16011 Set_Body_Required (Cunit_Node);
16012 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
16014 -- If we are in dynamic elaboration mode, then we suppress
16015 -- elaboration warnings for the unit, since it is definitely
16016 -- fine NOT to do dynamic checks at the first level (and such
16017 -- checks will be suppressed because no elaboration boolean
16018 -- is created for Elaborate_Body packages).
16020 -- But in the static model of elaboration, Elaborate_Body is
16021 -- definitely NOT good enough to ensure elaboration safety on
16022 -- its own, since the body may WITH other units that are not
16023 -- safe from an elaboration point of view, so a client must
16024 -- still do an Elaborate_All on such units.
16026 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16027 -- Elaborate_Body always suppressed elab warnings.
16029 if Legacy_Elaboration_Checks
16030 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
16032 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
16035 end Elaborate_Body;
16037 ------------------------
16038 -- Elaboration_Checks --
16039 ------------------------
16041 -- pragma Elaboration_Checks (Static | Dynamic);
16043 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
16044 procedure Check_Duplicate_Elaboration_Checks_Pragma;
16045 -- Emit an error if the current context list already contains
16046 -- a previous Elaboration_Checks pragma. This routine raises
16047 -- Pragma_Exit if a duplicate is found.
16049 procedure Ignore_Elaboration_Checks_Pragma;
16050 -- Warn that the effects of the pragma are ignored. This routine
16051 -- raises Pragma_Exit.
16053 -----------------------------------------------
16054 -- Check_Duplicate_Elaboration_Checks_Pragma --
16055 -----------------------------------------------
16057 procedure Check_Duplicate_Elaboration_Checks_Pragma is
16062 while Present (Item) loop
16063 if Nkind (Item) = N_Pragma
16064 and then Pragma_Name (Item) = Name_Elaboration_Checks
16074 end Check_Duplicate_Elaboration_Checks_Pragma;
16076 --------------------------------------
16077 -- Ignore_Elaboration_Checks_Pragma --
16078 --------------------------------------
16080 procedure Ignore_Elaboration_Checks_Pragma is
16082 Error_Msg_Name_1 := Pname;
16083 Error_Msg_N ("??effects of pragma % are ignored", N);
16085 ("\place pragma on initial declaration of library unit", N);
16088 end Ignore_Elaboration_Checks_Pragma;
16092 Context : constant Node_Id := Parent (N);
16095 -- Start of processing for Elaboration_Checks
16099 Check_Arg_Count (1);
16100 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
16102 -- The pragma appears in a configuration file
16104 if No (Context) then
16105 Check_Valid_Configuration_Pragma;
16106 Check_Duplicate_Elaboration_Checks_Pragma;
16108 -- The pragma acts as a configuration pragma in a compilation unit
16110 -- pragma Elaboration_Checks (...);
16111 -- package Pack is ...;
16113 elsif Nkind (Context) = N_Compilation_Unit
16114 and then List_Containing (N) = Context_Items (Context)
16116 Check_Valid_Configuration_Pragma;
16117 Check_Duplicate_Elaboration_Checks_Pragma;
16119 Unt := Unit (Context);
16121 -- The pragma must appear on the initial declaration of a unit.
16122 -- If this is not the case, warn that the effects of the pragma
16125 if Nkind (Unt) = N_Package_Body then
16126 Ignore_Elaboration_Checks_Pragma;
16128 -- Check the Acts_As_Spec flag of the compilation units itself
16129 -- to determine whether the subprogram body completes since it
16130 -- has not been analyzed yet. This is safe because compilation
16131 -- units are not overloadable.
16133 elsif Nkind (Unt) = N_Subprogram_Body
16134 and then not Acts_As_Spec (Context)
16136 Ignore_Elaboration_Checks_Pragma;
16138 elsif Nkind (Unt) = N_Subunit then
16139 Ignore_Elaboration_Checks_Pragma;
16142 -- Otherwise the pragma does not appear at the configuration level
16149 -- At this point the pragma is not a duplicate, and appears in the
16150 -- proper context. Set the elaboration model in effect.
16152 Dynamic_Elaboration_Checks :=
16153 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
16154 end Elaboration_Checks;
16160 -- pragma Eliminate (
16161 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16162 -- [Entity =>] IDENTIFIER |
16163 -- SELECTED_COMPONENT |
16165 -- [, Source_Location => SOURCE_TRACE]);
16167 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16168 -- SOURCE_TRACE ::= STRING_LITERAL
16170 when Pragma_Eliminate => Eliminate : declare
16171 Args : Args_List (1 .. 5);
16172 Names : constant Name_List (1 .. 5) := (
16175 Name_Parameter_Types,
16177 Name_Source_Location);
16179 -- Note : Parameter_Types and Result_Type are leftovers from
16180 -- prior implementations of the pragma. They are not generated
16181 -- by the gnatelim tool, and play no role in selecting which
16182 -- of a set of overloaded names is chosen for elimination.
16184 Unit_Name : Node_Id renames Args (1);
16185 Entity : Node_Id renames Args (2);
16186 Parameter_Types : Node_Id renames Args (3);
16187 Result_Type : Node_Id renames Args (4);
16188 Source_Location : Node_Id renames Args (5);
16192 Check_Valid_Configuration_Pragma;
16193 Gather_Associations (Names, Args);
16195 if No (Unit_Name) then
16196 Error_Pragma ("missing Unit_Name argument for pragma%");
16200 and then (Present (Parameter_Types)
16202 Present (Result_Type)
16204 Present (Source_Location))
16206 Error_Pragma ("missing Entity argument for pragma%");
16209 if (Present (Parameter_Types)
16211 Present (Result_Type))
16213 Present (Source_Location)
16216 ("parameter profile and source location cannot be used "
16217 & "together in pragma%");
16220 Process_Eliminate_Pragma
16229 -----------------------------------
16230 -- Enable_Atomic_Synchronization --
16231 -----------------------------------
16233 -- pragma Enable_Atomic_Synchronization [(Entity)];
16235 when Pragma_Enable_Atomic_Synchronization =>
16237 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16244 -- [ Convention =>] convention_IDENTIFIER,
16245 -- [ Entity =>] LOCAL_NAME
16246 -- [, [External_Name =>] static_string_EXPRESSION ]
16247 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16249 when Pragma_Export => Export : declare
16251 Def_Id : Entity_Id;
16253 pragma Warnings (Off, C);
16256 Check_Ada_83_Warning;
16260 Name_External_Name,
16263 Check_At_Least_N_Arguments (2);
16264 Check_At_Most_N_Arguments (4);
16266 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16267 -- pragma Export (Entity, "external name");
16269 if Relaxed_RM_Semantics
16270 and then Arg_Count = 2
16271 and then Nkind (Expression (Arg2)) = N_String_Literal
16274 Def_Id := Get_Pragma_Arg (Arg1);
16277 if not Is_Entity_Name (Def_Id) then
16278 Error_Pragma_Arg ("entity name required", Arg1);
16281 Def_Id := Entity (Def_Id);
16282 Set_Exported (Def_Id, Arg1);
16285 Process_Convention (C, Def_Id);
16287 -- A pragma that applies to a Ghost entity becomes Ghost for
16288 -- the purposes of legality checks and removal of ignored Ghost
16291 Mark_Ghost_Pragma (N, Def_Id);
16293 if Ekind (Def_Id) /= E_Constant then
16294 Note_Possible_Modification
16295 (Get_Pragma_Arg (Arg2), Sure => False);
16298 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16299 Set_Exported (Def_Id, Arg2);
16302 -- If the entity is a deferred constant, propagate the information
16303 -- to the full view, because gigi elaborates the full view only.
16305 if Ekind (Def_Id) = E_Constant
16306 and then Present (Full_View (Def_Id))
16309 Id2 : constant Entity_Id := Full_View (Def_Id);
16311 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16312 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16313 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16318 ---------------------
16319 -- Export_Function --
16320 ---------------------
16322 -- pragma Export_Function (
16323 -- [Internal =>] LOCAL_NAME
16324 -- [, [External =>] EXTERNAL_SYMBOL]
16325 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16326 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16327 -- [, [Mechanism =>] MECHANISM]
16328 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16330 -- EXTERNAL_SYMBOL ::=
16332 -- | static_string_EXPRESSION
16334 -- PARAMETER_TYPES ::=
16336 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16338 -- TYPE_DESIGNATOR ::=
16340 -- | subtype_Name ' Access
16344 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16346 -- MECHANISM_ASSOCIATION ::=
16347 -- [formal_parameter_NAME =>] MECHANISM_NAME
16349 -- MECHANISM_NAME ::=
16353 when Pragma_Export_Function => Export_Function : declare
16354 Args : Args_List (1 .. 6);
16355 Names : constant Name_List (1 .. 6) := (
16358 Name_Parameter_Types,
16361 Name_Result_Mechanism);
16363 Internal : Node_Id renames Args (1);
16364 External : Node_Id renames Args (2);
16365 Parameter_Types : Node_Id renames Args (3);
16366 Result_Type : Node_Id renames Args (4);
16367 Mechanism : Node_Id renames Args (5);
16368 Result_Mechanism : Node_Id renames Args (6);
16372 Gather_Associations (Names, Args);
16373 Process_Extended_Import_Export_Subprogram_Pragma (
16374 Arg_Internal => Internal,
16375 Arg_External => External,
16376 Arg_Parameter_Types => Parameter_Types,
16377 Arg_Result_Type => Result_Type,
16378 Arg_Mechanism => Mechanism,
16379 Arg_Result_Mechanism => Result_Mechanism);
16380 end Export_Function;
16382 -------------------
16383 -- Export_Object --
16384 -------------------
16386 -- pragma Export_Object (
16387 -- [Internal =>] LOCAL_NAME
16388 -- [, [External =>] EXTERNAL_SYMBOL]
16389 -- [, [Size =>] EXTERNAL_SYMBOL]);
16391 -- EXTERNAL_SYMBOL ::=
16393 -- | static_string_EXPRESSION
16395 -- PARAMETER_TYPES ::=
16397 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16399 -- TYPE_DESIGNATOR ::=
16401 -- | subtype_Name ' Access
16405 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16407 -- MECHANISM_ASSOCIATION ::=
16408 -- [formal_parameter_NAME =>] MECHANISM_NAME
16410 -- MECHANISM_NAME ::=
16414 when Pragma_Export_Object => Export_Object : declare
16415 Args : Args_List (1 .. 3);
16416 Names : constant Name_List (1 .. 3) := (
16421 Internal : Node_Id renames Args (1);
16422 External : Node_Id renames Args (2);
16423 Size : Node_Id renames Args (3);
16427 Gather_Associations (Names, Args);
16428 Process_Extended_Import_Export_Object_Pragma (
16429 Arg_Internal => Internal,
16430 Arg_External => External,
16434 ----------------------
16435 -- Export_Procedure --
16436 ----------------------
16438 -- pragma Export_Procedure (
16439 -- [Internal =>] LOCAL_NAME
16440 -- [, [External =>] EXTERNAL_SYMBOL]
16441 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16442 -- [, [Mechanism =>] MECHANISM]);
16444 -- EXTERNAL_SYMBOL ::=
16446 -- | static_string_EXPRESSION
16448 -- PARAMETER_TYPES ::=
16450 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16452 -- TYPE_DESIGNATOR ::=
16454 -- | subtype_Name ' Access
16458 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16460 -- MECHANISM_ASSOCIATION ::=
16461 -- [formal_parameter_NAME =>] MECHANISM_NAME
16463 -- MECHANISM_NAME ::=
16467 when Pragma_Export_Procedure => Export_Procedure : declare
16468 Args : Args_List (1 .. 4);
16469 Names : constant Name_List (1 .. 4) := (
16472 Name_Parameter_Types,
16475 Internal : Node_Id renames Args (1);
16476 External : Node_Id renames Args (2);
16477 Parameter_Types : Node_Id renames Args (3);
16478 Mechanism : Node_Id renames Args (4);
16482 Gather_Associations (Names, Args);
16483 Process_Extended_Import_Export_Subprogram_Pragma (
16484 Arg_Internal => Internal,
16485 Arg_External => External,
16486 Arg_Parameter_Types => Parameter_Types,
16487 Arg_Mechanism => Mechanism);
16488 end Export_Procedure;
16494 -- pragma Export_Value (
16495 -- [Value =>] static_integer_EXPRESSION,
16496 -- [Link_Name =>] static_string_EXPRESSION);
16498 when Pragma_Export_Value =>
16500 Check_Arg_Order ((Name_Value, Name_Link_Name));
16501 Check_Arg_Count (2);
16503 Check_Optional_Identifier (Arg1, Name_Value);
16504 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16506 Check_Optional_Identifier (Arg2, Name_Link_Name);
16507 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16509 -----------------------------
16510 -- Export_Valued_Procedure --
16511 -----------------------------
16513 -- pragma Export_Valued_Procedure (
16514 -- [Internal =>] LOCAL_NAME
16515 -- [, [External =>] EXTERNAL_SYMBOL,]
16516 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16517 -- [, [Mechanism =>] MECHANISM]);
16519 -- EXTERNAL_SYMBOL ::=
16521 -- | static_string_EXPRESSION
16523 -- PARAMETER_TYPES ::=
16525 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16527 -- TYPE_DESIGNATOR ::=
16529 -- | subtype_Name ' Access
16533 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16535 -- MECHANISM_ASSOCIATION ::=
16536 -- [formal_parameter_NAME =>] MECHANISM_NAME
16538 -- MECHANISM_NAME ::=
16542 when Pragma_Export_Valued_Procedure =>
16543 Export_Valued_Procedure : declare
16544 Args : Args_List (1 .. 4);
16545 Names : constant Name_List (1 .. 4) := (
16548 Name_Parameter_Types,
16551 Internal : Node_Id renames Args (1);
16552 External : Node_Id renames Args (2);
16553 Parameter_Types : Node_Id renames Args (3);
16554 Mechanism : Node_Id renames Args (4);
16558 Gather_Associations (Names, Args);
16559 Process_Extended_Import_Export_Subprogram_Pragma (
16560 Arg_Internal => Internal,
16561 Arg_External => External,
16562 Arg_Parameter_Types => Parameter_Types,
16563 Arg_Mechanism => Mechanism);
16564 end Export_Valued_Procedure;
16566 -------------------
16567 -- Extend_System --
16568 -------------------
16570 -- pragma Extend_System ([Name =>] Identifier);
16572 when Pragma_Extend_System =>
16574 Check_Valid_Configuration_Pragma;
16575 Check_Arg_Count (1);
16576 Check_Optional_Identifier (Arg1, Name_Name);
16577 Check_Arg_Is_Identifier (Arg1);
16579 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16582 and then Name_Buffer (1 .. 4) = "aux_"
16584 if Present (System_Extend_Pragma_Arg) then
16585 if Chars (Get_Pragma_Arg (Arg1)) =
16586 Chars (Expression (System_Extend_Pragma_Arg))
16590 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16591 Error_Pragma ("pragma% conflicts with that #");
16595 System_Extend_Pragma_Arg := Arg1;
16597 if not GNAT_Mode then
16598 System_Extend_Unit := Arg1;
16602 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16605 ------------------------
16606 -- Extensions_Allowed --
16607 ------------------------
16609 -- pragma Extensions_Allowed (ON | OFF);
16611 when Pragma_Extensions_Allowed =>
16613 Check_Arg_Count (1);
16614 Check_No_Identifiers;
16615 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16617 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16618 Extensions_Allowed := True;
16619 Ada_Version := Ada_Version_Type'Last;
16622 Extensions_Allowed := False;
16623 Ada_Version := Ada_Version_Explicit;
16624 Ada_Version_Pragma := Empty;
16627 ------------------------
16628 -- Extensions_Visible --
16629 ------------------------
16631 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16633 -- Characteristics:
16635 -- * Analysis - The annotation is fully analyzed immediately upon
16636 -- elaboration as its expression must be static.
16638 -- * Expansion - None.
16640 -- * Template - The annotation utilizes the generic template of the
16641 -- related subprogram [body] when it is:
16643 -- aspect on subprogram declaration
16644 -- aspect on stand-alone subprogram body
16645 -- pragma on stand-alone subprogram body
16647 -- The annotation must prepare its own template when it is:
16649 -- pragma on subprogram declaration
16651 -- * Globals - Capture of global references must occur after full
16654 -- * Instance - The annotation is instantiated automatically when
16655 -- the related generic subprogram [body] is instantiated except for
16656 -- the "pragma on subprogram declaration" case. In that scenario
16657 -- the annotation must instantiate itself.
16659 when Pragma_Extensions_Visible => Extensions_Visible : declare
16660 Formal : Entity_Id;
16661 Has_OK_Formal : Boolean := False;
16662 Spec_Id : Entity_Id;
16663 Subp_Decl : Node_Id;
16667 Check_No_Identifiers;
16668 Check_At_Most_N_Arguments (1);
16671 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16673 -- Abstract subprogram declaration
16675 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16678 -- Generic subprogram declaration
16680 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16683 -- Body acts as spec
16685 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16686 and then No (Corresponding_Spec (Subp_Decl))
16690 -- Body stub acts as spec
16692 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16693 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16697 -- Subprogram declaration
16699 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16702 -- Otherwise the pragma is associated with an illegal construct
16705 Error_Pragma ("pragma % must apply to a subprogram");
16709 -- Mark the pragma as Ghost if the related subprogram is also
16710 -- Ghost. This also ensures that any expansion performed further
16711 -- below will produce Ghost nodes.
16713 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16714 Mark_Ghost_Pragma (N, Spec_Id);
16716 -- Chain the pragma on the contract for completeness
16718 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16720 -- The legality checks of pragma Extension_Visible are affected
16721 -- by the SPARK mode in effect. Analyze all pragmas in specific
16724 Analyze_If_Present (Pragma_SPARK_Mode);
16726 -- Examine the formals of the related subprogram
16728 Formal := First_Formal (Spec_Id);
16729 while Present (Formal) loop
16731 -- At least one of the formals is of a specific tagged type,
16732 -- the pragma is legal.
16734 if Is_Specific_Tagged_Type (Etype (Formal)) then
16735 Has_OK_Formal := True;
16738 -- A generic subprogram with at least one formal of a private
16739 -- type ensures the legality of the pragma because the actual
16740 -- may be specifically tagged. Note that this is verified by
16741 -- the check above at instantiation time.
16743 elsif Is_Private_Type (Etype (Formal))
16744 and then Is_Generic_Type (Etype (Formal))
16746 Has_OK_Formal := True;
16750 Next_Formal (Formal);
16753 if not Has_OK_Formal then
16754 Error_Msg_Name_1 := Pname;
16755 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16757 ("\subprogram & lacks parameter of specific tagged or "
16758 & "generic private type", N, Spec_Id);
16763 -- Analyze the Boolean expression (if any)
16765 if Present (Arg1) then
16766 Check_Static_Boolean_Expression
16767 (Expression (Get_Argument (N, Spec_Id)));
16769 end Extensions_Visible;
16775 -- pragma External (
16776 -- [ Convention =>] convention_IDENTIFIER,
16777 -- [ Entity =>] LOCAL_NAME
16778 -- [, [External_Name =>] static_string_EXPRESSION ]
16779 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16781 when Pragma_External => External : declare
16784 pragma Warnings (Off, C);
16791 Name_External_Name,
16793 Check_At_Least_N_Arguments (2);
16794 Check_At_Most_N_Arguments (4);
16795 Process_Convention (C, E);
16797 -- A pragma that applies to a Ghost entity becomes Ghost for the
16798 -- purposes of legality checks and removal of ignored Ghost code.
16800 Mark_Ghost_Pragma (N, E);
16802 Note_Possible_Modification
16803 (Get_Pragma_Arg (Arg2), Sure => False);
16804 Process_Interface_Name (E, Arg3, Arg4, N);
16805 Set_Exported (E, Arg2);
16808 --------------------------
16809 -- External_Name_Casing --
16810 --------------------------
16812 -- pragma External_Name_Casing (
16813 -- UPPERCASE | LOWERCASE
16814 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16816 when Pragma_External_Name_Casing =>
16818 Check_No_Identifiers;
16820 if Arg_Count = 2 then
16821 Check_Arg_Is_One_Of
16822 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16824 case Chars (Get_Pragma_Arg (Arg2)) is
16826 Opt.External_Name_Exp_Casing := As_Is;
16828 when Name_Uppercase =>
16829 Opt.External_Name_Exp_Casing := Uppercase;
16831 when Name_Lowercase =>
16832 Opt.External_Name_Exp_Casing := Lowercase;
16839 Check_Arg_Count (1);
16842 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16844 case Chars (Get_Pragma_Arg (Arg1)) is
16845 when Name_Uppercase =>
16846 Opt.External_Name_Imp_Casing := Uppercase;
16848 when Name_Lowercase =>
16849 Opt.External_Name_Imp_Casing := Lowercase;
16859 -- pragma Fast_Math;
16861 when Pragma_Fast_Math =>
16863 Check_No_Identifiers;
16864 Check_Valid_Configuration_Pragma;
16867 --------------------------
16868 -- Favor_Top_Level --
16869 --------------------------
16871 -- pragma Favor_Top_Level (type_NAME);
16873 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16878 Check_No_Identifiers;
16879 Check_Arg_Count (1);
16880 Check_Arg_Is_Local_Name (Arg1);
16881 Typ := Entity (Get_Pragma_Arg (Arg1));
16883 -- A pragma that applies to a Ghost entity becomes Ghost for the
16884 -- purposes of legality checks and removal of ignored Ghost code.
16886 Mark_Ghost_Pragma (N, Typ);
16888 -- If it's an access-to-subprogram type (in particular, not a
16889 -- subtype), set the flag on that type.
16891 if Is_Access_Subprogram_Type (Typ) then
16892 Set_Can_Use_Internal_Rep (Typ, False);
16894 -- Otherwise it's an error (name denotes the wrong sort of entity)
16898 ("access-to-subprogram type expected",
16899 Get_Pragma_Arg (Arg1));
16901 end Favor_Top_Level;
16903 ---------------------------
16904 -- Finalize_Storage_Only --
16905 ---------------------------
16907 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16909 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16910 Assoc : constant Node_Id := Arg1;
16911 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16916 Check_No_Identifiers;
16917 Check_Arg_Count (1);
16918 Check_Arg_Is_Local_Name (Arg1);
16920 Find_Type (Type_Id);
16921 Typ := Entity (Type_Id);
16924 or else Rep_Item_Too_Early (Typ, N)
16928 Typ := Underlying_Type (Typ);
16931 if not Is_Controlled (Typ) then
16932 Error_Pragma ("pragma% must specify controlled type");
16935 Check_First_Subtype (Arg1);
16937 if Finalize_Storage_Only (Typ) then
16938 Error_Pragma ("duplicate pragma%, only one allowed");
16940 elsif not Rep_Item_Too_Late (Typ, N) then
16941 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16943 end Finalize_Storage;
16949 -- pragma Ghost [ (boolean_EXPRESSION) ];
16951 when Pragma_Ghost => Ghost : declare
16955 Orig_Stmt : Node_Id;
16956 Prev_Id : Entity_Id;
16961 Check_No_Identifiers;
16962 Check_At_Most_N_Arguments (1);
16966 while Present (Stmt) loop
16968 -- Skip prior pragmas, but check for duplicates
16970 if Nkind (Stmt) = N_Pragma then
16971 if Pragma_Name (Stmt) = Pname then
16978 -- Task unit declared without a definition cannot be subject to
16979 -- pragma Ghost (SPARK RM 6.9(19)).
16981 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
16982 N_Task_Type_Declaration)
16984 Error_Pragma ("pragma % cannot apply to a task type");
16987 -- Skip internally generated code
16989 elsif not Comes_From_Source (Stmt) then
16990 Orig_Stmt := Original_Node (Stmt);
16992 -- When pragma Ghost applies to an untagged derivation, the
16993 -- derivation is transformed into a [sub]type declaration.
16995 if Nkind_In (Stmt, N_Full_Type_Declaration,
16996 N_Subtype_Declaration)
16997 and then Comes_From_Source (Orig_Stmt)
16998 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16999 and then Nkind (Type_Definition (Orig_Stmt)) =
17000 N_Derived_Type_Definition
17002 Id := Defining_Entity (Stmt);
17005 -- When pragma Ghost applies to an object declaration which
17006 -- is initialized by means of a function call that returns
17007 -- on the secondary stack, the object declaration becomes a
17010 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
17011 and then Comes_From_Source (Orig_Stmt)
17012 and then Nkind (Orig_Stmt) = N_Object_Declaration
17014 Id := Defining_Entity (Stmt);
17017 -- When pragma Ghost applies to an expression function, the
17018 -- expression function is transformed into a subprogram.
17020 elsif Nkind (Stmt) = N_Subprogram_Declaration
17021 and then Comes_From_Source (Orig_Stmt)
17022 and then Nkind (Orig_Stmt) = N_Expression_Function
17024 Id := Defining_Entity (Stmt);
17028 -- The pragma applies to a legal construct, stop the traversal
17030 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
17031 N_Full_Type_Declaration,
17032 N_Generic_Subprogram_Declaration,
17033 N_Object_Declaration,
17034 N_Private_Extension_Declaration,
17035 N_Private_Type_Declaration,
17036 N_Subprogram_Declaration,
17037 N_Subtype_Declaration)
17039 Id := Defining_Entity (Stmt);
17042 -- The pragma does not apply to a legal construct, issue an
17043 -- error and stop the analysis.
17047 ("pragma % must apply to an object, package, subprogram "
17052 Stmt := Prev (Stmt);
17055 Context := Parent (N);
17057 -- Handle compilation units
17059 if Nkind (Context) = N_Compilation_Unit_Aux then
17060 Context := Unit (Parent (Context));
17063 -- Protected and task types cannot be subject to pragma Ghost
17064 -- (SPARK RM 6.9(19)).
17066 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
17068 Error_Pragma ("pragma % cannot apply to a protected type");
17071 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
17072 Error_Pragma ("pragma % cannot apply to a task type");
17078 -- When pragma Ghost is associated with a [generic] package, it
17079 -- appears in the visible declarations.
17081 if Nkind (Context) = N_Package_Specification
17082 and then Present (Visible_Declarations (Context))
17083 and then List_Containing (N) = Visible_Declarations (Context)
17085 Id := Defining_Entity (Context);
17087 -- Pragma Ghost applies to a stand-alone subprogram body
17089 elsif Nkind (Context) = N_Subprogram_Body
17090 and then No (Corresponding_Spec (Context))
17092 Id := Defining_Entity (Context);
17094 -- Pragma Ghost applies to a subprogram declaration that acts
17095 -- as a compilation unit.
17097 elsif Nkind (Context) = N_Subprogram_Declaration then
17098 Id := Defining_Entity (Context);
17100 -- Pragma Ghost applies to a generic subprogram
17102 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
17103 Id := Defining_Entity (Specification (Context));
17109 ("pragma % must apply to an object, package, subprogram or "
17114 -- Handle completions of types and constants that are subject to
17117 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
17118 Prev_Id := Incomplete_Or_Partial_View (Id);
17120 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
17121 Error_Msg_Name_1 := Pname;
17123 -- The full declaration of a deferred constant cannot be
17124 -- subject to pragma Ghost unless the deferred declaration
17125 -- is also Ghost (SPARK RM 6.9(9)).
17127 if Ekind (Prev_Id) = E_Constant then
17128 Error_Msg_Name_1 := Pname;
17129 Error_Msg_NE (Fix_Error
17130 ("pragma % must apply to declaration of deferred "
17131 & "constant &"), N, Id);
17134 -- Pragma Ghost may appear on the full view of an incomplete
17135 -- type because the incomplete declaration lacks aspects and
17136 -- cannot be subject to pragma Ghost.
17138 elsif Ekind (Prev_Id) = E_Incomplete_Type then
17141 -- The full declaration of a type cannot be subject to
17142 -- pragma Ghost unless the partial view is also Ghost
17143 -- (SPARK RM 6.9(9)).
17146 Error_Msg_NE (Fix_Error
17147 ("pragma % must apply to partial view of type &"),
17153 -- A synchronized object cannot be subject to pragma Ghost
17154 -- (SPARK RM 6.9(19)).
17156 elsif Ekind (Id) = E_Variable then
17157 if Is_Protected_Type (Etype (Id)) then
17158 Error_Pragma ("pragma % cannot apply to a protected object");
17161 elsif Is_Task_Type (Etype (Id)) then
17162 Error_Pragma ("pragma % cannot apply to a task object");
17167 -- Analyze the Boolean expression (if any)
17169 if Present (Arg1) then
17170 Expr := Get_Pragma_Arg (Arg1);
17172 Analyze_And_Resolve (Expr, Standard_Boolean);
17174 if Is_OK_Static_Expression (Expr) then
17176 -- "Ghostness" cannot be turned off once enabled within a
17177 -- region (SPARK RM 6.9(6)).
17179 if Is_False (Expr_Value (Expr))
17180 and then Ghost_Mode > None
17183 ("pragma % with value False cannot appear in enabled "
17188 -- Otherwie the expression is not static
17192 ("expression of pragma % must be static", Expr);
17197 Set_Is_Ghost_Entity (Id);
17204 -- pragma Global (GLOBAL_SPECIFICATION);
17206 -- GLOBAL_SPECIFICATION ::=
17209 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17211 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17213 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17214 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17215 -- GLOBAL_ITEM ::= NAME
17217 -- Characteristics:
17219 -- * Analysis - The annotation undergoes initial checks to verify
17220 -- the legal placement and context. Secondary checks fully analyze
17221 -- the dependency clauses in:
17223 -- Analyze_Global_In_Decl_Part
17225 -- * Expansion - None.
17227 -- * Template - The annotation utilizes the generic template of the
17228 -- related subprogram [body] when it is:
17230 -- aspect on subprogram declaration
17231 -- aspect on stand-alone subprogram body
17232 -- pragma on stand-alone subprogram body
17234 -- The annotation must prepare its own template when it is:
17236 -- pragma on subprogram declaration
17238 -- * Globals - Capture of global references must occur after full
17241 -- * Instance - The annotation is instantiated automatically when
17242 -- the related generic subprogram [body] is instantiated except for
17243 -- the "pragma on subprogram declaration" case. In that scenario
17244 -- the annotation must instantiate itself.
17246 when Pragma_Global => Global : declare
17248 Spec_Id : Entity_Id;
17249 Subp_Decl : Node_Id;
17252 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17256 -- Chain the pragma on the contract for further processing by
17257 -- Analyze_Global_In_Decl_Part.
17259 Add_Contract_Item (N, Spec_Id);
17261 -- Fully analyze the pragma when it appears inside an entry
17262 -- or subprogram body because it cannot benefit from forward
17265 if Nkind_In (Subp_Decl, N_Entry_Body,
17267 N_Subprogram_Body_Stub)
17269 -- The legality checks of pragmas Depends and Global are
17270 -- affected by the SPARK mode in effect and the volatility
17271 -- of the context. In addition these two pragmas are subject
17272 -- to an inherent order:
17277 -- Analyze all these pragmas in the order outlined above
17279 Analyze_If_Present (Pragma_SPARK_Mode);
17280 Analyze_If_Present (Pragma_Volatile_Function);
17281 Analyze_Global_In_Decl_Part (N);
17282 Analyze_If_Present (Pragma_Depends);
17291 -- pragma Ident (static_string_EXPRESSION)
17293 -- Note: pragma Comment shares this processing. Pragma Ident is
17294 -- identical in effect to pragma Commment.
17296 when Pragma_Comment
17304 Check_Arg_Count (1);
17305 Check_No_Identifiers;
17306 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17309 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17316 GP := Parent (Parent (N));
17318 if Nkind_In (GP, N_Package_Declaration,
17319 N_Generic_Package_Declaration)
17324 -- If we have a compilation unit, then record the ident value,
17325 -- checking for improper duplication.
17327 if Nkind (GP) = N_Compilation_Unit then
17328 CS := Ident_String (Current_Sem_Unit);
17330 if Present (CS) then
17332 -- If we have multiple instances, concatenate them, but
17333 -- not in ASIS, where we want the original tree.
17335 if not ASIS_Mode then
17336 Start_String (Strval (CS));
17337 Store_String_Char (' ');
17338 Store_String_Chars (Strval (Str));
17339 Set_Strval (CS, End_String);
17343 Set_Ident_String (Current_Sem_Unit, Str);
17346 -- For subunits, we just ignore the Ident, since in GNAT these
17347 -- are not separate object files, and hence not separate units
17348 -- in the unit table.
17350 elsif Nkind (GP) = N_Subunit then
17356 -------------------
17357 -- Ignore_Pragma --
17358 -------------------
17360 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17362 -- Entirely handled in the parser, nothing to do here
17364 when Pragma_Ignore_Pragma =>
17367 ----------------------------
17368 -- Implementation_Defined --
17369 ----------------------------
17371 -- pragma Implementation_Defined (LOCAL_NAME);
17373 -- Marks previously declared entity as implementation defined. For
17374 -- an overloaded entity, applies to the most recent homonym.
17376 -- pragma Implementation_Defined;
17378 -- The form with no arguments appears anywhere within a scope, most
17379 -- typically a package spec, and indicates that all entities that are
17380 -- defined within the package spec are Implementation_Defined.
17382 when Pragma_Implementation_Defined => Implementation_Defined : declare
17387 Check_No_Identifiers;
17389 -- Form with no arguments
17391 if Arg_Count = 0 then
17392 Set_Is_Implementation_Defined (Current_Scope);
17394 -- Form with one argument
17397 Check_Arg_Count (1);
17398 Check_Arg_Is_Local_Name (Arg1);
17399 Ent := Entity (Get_Pragma_Arg (Arg1));
17400 Set_Is_Implementation_Defined (Ent);
17402 end Implementation_Defined;
17408 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17410 -- IMPLEMENTATION_KIND ::=
17411 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17413 -- "By_Any" and "Optional" are treated as synonyms in order to
17414 -- support Ada 2012 aspect Synchronization.
17416 when Pragma_Implemented => Implemented : declare
17417 Proc_Id : Entity_Id;
17422 Check_Arg_Count (2);
17423 Check_No_Identifiers;
17424 Check_Arg_Is_Identifier (Arg1);
17425 Check_Arg_Is_Local_Name (Arg1);
17426 Check_Arg_Is_One_Of (Arg2,
17429 Name_By_Protected_Procedure,
17432 -- Extract the name of the local procedure
17434 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17436 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17437 -- primitive procedure of a synchronized tagged type.
17439 if Ekind (Proc_Id) = E_Procedure
17440 and then Is_Primitive (Proc_Id)
17441 and then Present (First_Formal (Proc_Id))
17443 Typ := Etype (First_Formal (Proc_Id));
17445 if Is_Tagged_Type (Typ)
17448 -- Check for a protected, a synchronized or a task interface
17450 ((Is_Interface (Typ)
17451 and then Is_Synchronized_Interface (Typ))
17453 -- Check for a protected type or a task type that implements
17457 (Is_Concurrent_Record_Type (Typ)
17458 and then Present (Interfaces (Typ)))
17460 -- In analysis-only mode, examine original protected type
17463 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17464 and then Present (Interface_List (Parent (Typ))))
17466 -- Check for a private record extension with keyword
17470 (Ekind_In (Typ, E_Record_Type_With_Private,
17471 E_Record_Subtype_With_Private)
17472 and then Synchronized_Present (Parent (Typ))))
17477 ("controlling formal must be of synchronized tagged type",
17482 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17483 -- By_Protected_Procedure to the primitive procedure of a task
17486 if Chars (Arg2) = Name_By_Protected_Procedure
17487 and then Is_Interface (Typ)
17488 and then Is_Task_Interface (Typ)
17491 ("implementation kind By_Protected_Procedure cannot be "
17492 & "applied to a task interface primitive", Arg2);
17496 -- Procedures declared inside a protected type must be accepted
17498 elsif Ekind (Proc_Id) = E_Procedure
17499 and then Is_Protected_Type (Scope (Proc_Id))
17503 -- The first argument is not a primitive procedure
17507 ("pragma % must be applied to a primitive procedure", Arg1);
17511 Record_Rep_Item (Proc_Id, N);
17514 ----------------------
17515 -- Implicit_Packing --
17516 ----------------------
17518 -- pragma Implicit_Packing;
17520 when Pragma_Implicit_Packing =>
17522 Check_Arg_Count (0);
17523 Implicit_Packing := True;
17530 -- [Convention =>] convention_IDENTIFIER,
17531 -- [Entity =>] LOCAL_NAME
17532 -- [, [External_Name =>] static_string_EXPRESSION ]
17533 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17535 when Pragma_Import =>
17536 Check_Ada_83_Warning;
17540 Name_External_Name,
17543 Check_At_Least_N_Arguments (2);
17544 Check_At_Most_N_Arguments (4);
17545 Process_Import_Or_Interface;
17547 ---------------------
17548 -- Import_Function --
17549 ---------------------
17551 -- pragma Import_Function (
17552 -- [Internal =>] LOCAL_NAME,
17553 -- [, [External =>] EXTERNAL_SYMBOL]
17554 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17555 -- [, [Result_Type =>] SUBTYPE_MARK]
17556 -- [, [Mechanism =>] MECHANISM]
17557 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17559 -- EXTERNAL_SYMBOL ::=
17561 -- | static_string_EXPRESSION
17563 -- PARAMETER_TYPES ::=
17565 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17567 -- TYPE_DESIGNATOR ::=
17569 -- | subtype_Name ' Access
17573 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17575 -- MECHANISM_ASSOCIATION ::=
17576 -- [formal_parameter_NAME =>] MECHANISM_NAME
17578 -- MECHANISM_NAME ::=
17582 when Pragma_Import_Function => Import_Function : declare
17583 Args : Args_List (1 .. 6);
17584 Names : constant Name_List (1 .. 6) := (
17587 Name_Parameter_Types,
17590 Name_Result_Mechanism);
17592 Internal : Node_Id renames Args (1);
17593 External : Node_Id renames Args (2);
17594 Parameter_Types : Node_Id renames Args (3);
17595 Result_Type : Node_Id renames Args (4);
17596 Mechanism : Node_Id renames Args (5);
17597 Result_Mechanism : Node_Id renames Args (6);
17601 Gather_Associations (Names, Args);
17602 Process_Extended_Import_Export_Subprogram_Pragma (
17603 Arg_Internal => Internal,
17604 Arg_External => External,
17605 Arg_Parameter_Types => Parameter_Types,
17606 Arg_Result_Type => Result_Type,
17607 Arg_Mechanism => Mechanism,
17608 Arg_Result_Mechanism => Result_Mechanism);
17609 end Import_Function;
17611 -------------------
17612 -- Import_Object --
17613 -------------------
17615 -- pragma Import_Object (
17616 -- [Internal =>] LOCAL_NAME
17617 -- [, [External =>] EXTERNAL_SYMBOL]
17618 -- [, [Size =>] EXTERNAL_SYMBOL]);
17620 -- EXTERNAL_SYMBOL ::=
17622 -- | static_string_EXPRESSION
17624 when Pragma_Import_Object => Import_Object : declare
17625 Args : Args_List (1 .. 3);
17626 Names : constant Name_List (1 .. 3) := (
17631 Internal : Node_Id renames Args (1);
17632 External : Node_Id renames Args (2);
17633 Size : Node_Id renames Args (3);
17637 Gather_Associations (Names, Args);
17638 Process_Extended_Import_Export_Object_Pragma (
17639 Arg_Internal => Internal,
17640 Arg_External => External,
17644 ----------------------
17645 -- Import_Procedure --
17646 ----------------------
17648 -- pragma Import_Procedure (
17649 -- [Internal =>] LOCAL_NAME
17650 -- [, [External =>] EXTERNAL_SYMBOL]
17651 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17652 -- [, [Mechanism =>] MECHANISM]);
17654 -- EXTERNAL_SYMBOL ::=
17656 -- | static_string_EXPRESSION
17658 -- PARAMETER_TYPES ::=
17660 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17662 -- TYPE_DESIGNATOR ::=
17664 -- | subtype_Name ' Access
17668 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17670 -- MECHANISM_ASSOCIATION ::=
17671 -- [formal_parameter_NAME =>] MECHANISM_NAME
17673 -- MECHANISM_NAME ::=
17677 when Pragma_Import_Procedure => Import_Procedure : declare
17678 Args : Args_List (1 .. 4);
17679 Names : constant Name_List (1 .. 4) := (
17682 Name_Parameter_Types,
17685 Internal : Node_Id renames Args (1);
17686 External : Node_Id renames Args (2);
17687 Parameter_Types : Node_Id renames Args (3);
17688 Mechanism : Node_Id renames Args (4);
17692 Gather_Associations (Names, Args);
17693 Process_Extended_Import_Export_Subprogram_Pragma (
17694 Arg_Internal => Internal,
17695 Arg_External => External,
17696 Arg_Parameter_Types => Parameter_Types,
17697 Arg_Mechanism => Mechanism);
17698 end Import_Procedure;
17700 -----------------------------
17701 -- Import_Valued_Procedure --
17702 -----------------------------
17704 -- pragma Import_Valued_Procedure (
17705 -- [Internal =>] LOCAL_NAME
17706 -- [, [External =>] EXTERNAL_SYMBOL]
17707 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17708 -- [, [Mechanism =>] MECHANISM]);
17710 -- EXTERNAL_SYMBOL ::=
17712 -- | static_string_EXPRESSION
17714 -- PARAMETER_TYPES ::=
17716 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17718 -- TYPE_DESIGNATOR ::=
17720 -- | subtype_Name ' Access
17724 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17726 -- MECHANISM_ASSOCIATION ::=
17727 -- [formal_parameter_NAME =>] MECHANISM_NAME
17729 -- MECHANISM_NAME ::=
17733 when Pragma_Import_Valued_Procedure =>
17734 Import_Valued_Procedure : declare
17735 Args : Args_List (1 .. 4);
17736 Names : constant Name_List (1 .. 4) := (
17739 Name_Parameter_Types,
17742 Internal : Node_Id renames Args (1);
17743 External : Node_Id renames Args (2);
17744 Parameter_Types : Node_Id renames Args (3);
17745 Mechanism : Node_Id renames Args (4);
17749 Gather_Associations (Names, Args);
17750 Process_Extended_Import_Export_Subprogram_Pragma (
17751 Arg_Internal => Internal,
17752 Arg_External => External,
17753 Arg_Parameter_Types => Parameter_Types,
17754 Arg_Mechanism => Mechanism);
17755 end Import_Valued_Procedure;
17761 -- pragma Independent (LOCAL_NAME);
17763 when Pragma_Independent =>
17764 Process_Atomic_Independent_Shared_Volatile;
17766 ----------------------------
17767 -- Independent_Components --
17768 ----------------------------
17770 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17772 when Pragma_Independent_Components => Independent_Components : declare
17780 Check_Ada_83_Warning;
17782 Check_No_Identifiers;
17783 Check_Arg_Count (1);
17784 Check_Arg_Is_Local_Name (Arg1);
17785 E_Id := Get_Pragma_Arg (Arg1);
17787 if Etype (E_Id) = Any_Type then
17791 E := Entity (E_Id);
17793 -- A record type with a self-referential component of anonymous
17794 -- access type is given an incomplete view in order to handle the
17797 -- type Rec is record
17798 -- Self : access Rec;
17804 -- type Ptr is access Rec;
17805 -- type Rec is record
17809 -- Since the incomplete view is now the initial view of the type,
17810 -- the argument of the pragma will reference the incomplete view,
17811 -- but this view is illegal according to the semantics of the
17814 -- Obtain the full view of an internally-generated incomplete type
17815 -- only. This way an attempt to associate the pragma with a source
17816 -- incomplete type is still caught.
17818 if Ekind (E) = E_Incomplete_Type
17819 and then not Comes_From_Source (E)
17820 and then Present (Full_View (E))
17822 E := Full_View (E);
17825 -- A pragma that applies to a Ghost entity becomes Ghost for the
17826 -- purposes of legality checks and removal of ignored Ghost code.
17828 Mark_Ghost_Pragma (N, E);
17830 -- Check duplicate before we chain ourselves
17832 Check_Duplicate_Pragma (E);
17834 -- Check appropriate entity
17836 if Rep_Item_Too_Early (E, N)
17838 Rep_Item_Too_Late (E, N)
17843 D := Declaration_Node (E);
17846 -- The flag is set on the base type, or on the object
17848 if K = N_Full_Type_Declaration
17849 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17851 Set_Has_Independent_Components (Base_Type (E));
17852 Record_Independence_Check (N, Base_Type (E));
17854 -- For record type, set all components independent
17856 if Is_Record_Type (E) then
17857 C := First_Component (E);
17858 while Present (C) loop
17859 Set_Is_Independent (C);
17860 Next_Component (C);
17864 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17865 and then Nkind (D) = N_Object_Declaration
17866 and then Nkind (Object_Definition (D)) =
17867 N_Constrained_Array_Definition
17869 Set_Has_Independent_Components (E);
17870 Record_Independence_Check (N, E);
17873 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17875 end Independent_Components;
17877 -----------------------
17878 -- Initial_Condition --
17879 -----------------------
17881 -- pragma Initial_Condition (boolean_EXPRESSION);
17883 -- Characteristics:
17885 -- * Analysis - The annotation undergoes initial checks to verify
17886 -- the legal placement and context. Secondary checks preanalyze the
17889 -- Analyze_Initial_Condition_In_Decl_Part
17891 -- * Expansion - The annotation is expanded during the expansion of
17892 -- the package body whose declaration is subject to the annotation
17895 -- Expand_Pragma_Initial_Condition
17897 -- * Template - The annotation utilizes the generic template of the
17898 -- related package declaration.
17900 -- * Globals - Capture of global references must occur after full
17903 -- * Instance - The annotation is instantiated automatically when
17904 -- the related generic package is instantiated.
17906 when Pragma_Initial_Condition => Initial_Condition : declare
17907 Pack_Decl : Node_Id;
17908 Pack_Id : Entity_Id;
17912 Check_No_Identifiers;
17913 Check_Arg_Count (1);
17915 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17917 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17918 N_Package_Declaration)
17924 Pack_Id := Defining_Entity (Pack_Decl);
17926 -- A pragma that applies to a Ghost entity becomes Ghost for the
17927 -- purposes of legality checks and removal of ignored Ghost code.
17929 Mark_Ghost_Pragma (N, Pack_Id);
17931 -- Chain the pragma on the contract for further processing by
17932 -- Analyze_Initial_Condition_In_Decl_Part.
17934 Add_Contract_Item (N, Pack_Id);
17936 -- The legality checks of pragmas Abstract_State, Initializes, and
17937 -- Initial_Condition are affected by the SPARK mode in effect. In
17938 -- addition, these three pragmas are subject to an inherent order:
17940 -- 1) Abstract_State
17942 -- 3) Initial_Condition
17944 -- Analyze all these pragmas in the order outlined above
17946 Analyze_If_Present (Pragma_SPARK_Mode);
17947 Analyze_If_Present (Pragma_Abstract_State);
17948 Analyze_If_Present (Pragma_Initializes);
17949 end Initial_Condition;
17951 ------------------------
17952 -- Initialize_Scalars --
17953 ------------------------
17955 -- pragma Initialize_Scalars
17956 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17958 -- TYPE_VALUE_PAIR ::=
17959 -- SCALAR_TYPE => static_EXPRESSION
17965 -- | Long_Long_Flat
17975 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17976 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17977 -- This collection holds the individual pairs which specify the
17978 -- invalid values of their respective scalar types.
17980 procedure Analyze_Float_Value
17981 (Scal_Typ : Float_Scalar_Id;
17982 Val_Expr : Node_Id);
17983 -- Analyze a type value pair associated with float type Scal_Typ
17984 -- and expression Val_Expr.
17986 procedure Analyze_Integer_Value
17987 (Scal_Typ : Integer_Scalar_Id;
17988 Val_Expr : Node_Id);
17989 -- Analyze a type value pair associated with integer type Scal_Typ
17990 -- and expression Val_Expr.
17992 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17993 -- Analyze type value pair Pair
17995 -------------------------
17996 -- Analyze_Float_Value --
17997 -------------------------
17999 procedure Analyze_Float_Value
18000 (Scal_Typ : Float_Scalar_Id;
18001 Val_Expr : Node_Id)
18004 Analyze_And_Resolve (Val_Expr, Any_Real);
18006 if Is_OK_Static_Expression (Val_Expr) then
18007 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
18010 Error_Msg_Name_1 := Scal_Typ;
18011 Error_Msg_N ("value for type % must be static", Val_Expr);
18013 end Analyze_Float_Value;
18015 ---------------------------
18016 -- Analyze_Integer_Value --
18017 ---------------------------
18019 procedure Analyze_Integer_Value
18020 (Scal_Typ : Integer_Scalar_Id;
18021 Val_Expr : Node_Id)
18024 Analyze_And_Resolve (Val_Expr, Any_Integer);
18026 if Is_OK_Static_Expression (Val_Expr) then
18027 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
18030 Error_Msg_Name_1 := Scal_Typ;
18031 Error_Msg_N ("value for type % must be static", Val_Expr);
18033 end Analyze_Integer_Value;
18035 -----------------------------
18036 -- Analyze_Type_Value_Pair --
18037 -----------------------------
18039 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
18040 Scal_Typ : constant Name_Id := Chars (Pair);
18041 Val_Expr : constant Node_Id := Expression (Pair);
18042 Prev_Pair : Node_Id;
18045 if Scal_Typ in Scalar_Id then
18046 Prev_Pair := Seen (Scal_Typ);
18048 -- Prevent multiple attempts to set a value for a scalar
18051 if Present (Prev_Pair) then
18052 Error_Msg_Name_1 := Scal_Typ;
18054 ("cannot specify multiple invalid values for type %",
18057 Error_Msg_Sloc := Sloc (Prev_Pair);
18058 Error_Msg_N ("previous value set #", Pair);
18060 -- Ignore the effects of the pair, but do not halt the
18061 -- analysis of the pragma altogether.
18065 -- Otherwise capture the first pair for this scalar type
18068 Seen (Scal_Typ) := Pair;
18071 if Scal_Typ in Float_Scalar_Id then
18072 Analyze_Float_Value (Scal_Typ, Val_Expr);
18074 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
18075 Analyze_Integer_Value (Scal_Typ, Val_Expr);
18078 -- Otherwise the scalar family is illegal
18081 Error_Msg_Name_1 := Pname;
18083 ("argument of pragma % must denote valid scalar family",
18086 end Analyze_Type_Value_Pair;
18090 Pairs : constant List_Id := Pragma_Argument_Associations (N);
18093 -- Start of processing for Do_Initialize_Scalars
18097 Check_Valid_Configuration_Pragma;
18098 Check_Restriction (No_Initialize_Scalars, N);
18100 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18103 if Restriction_Active (No_Initialize_Scalars) then
18106 -- Initialize_Scalars creates false positives in CodePeer, and
18107 -- incorrect negative results in GNATprove mode, so ignore this
18108 -- pragma in these modes.
18110 elsif CodePeer_Mode or GNATprove_Mode then
18113 -- Otherwise analyze the pragma
18116 if Present (Pairs) then
18118 -- Install Standard in order to provide access to primitive
18119 -- types in case the expressions contain attributes such as
18122 Push_Scope (Standard_Standard);
18124 Pair := First (Pairs);
18125 while Present (Pair) loop
18126 Analyze_Type_Value_Pair (Pair);
18135 Init_Or_Norm_Scalars := True;
18136 Initialize_Scalars := True;
18138 end Do_Initialize_Scalars;
18144 -- pragma Initializes (INITIALIZATION_LIST);
18146 -- INITIALIZATION_LIST ::=
18148 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18150 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18155 -- | (INPUT {, INPUT})
18159 -- Characteristics:
18161 -- * Analysis - The annotation undergoes initial checks to verify
18162 -- the legal placement and context. Secondary checks preanalyze the
18165 -- Analyze_Initializes_In_Decl_Part
18167 -- * Expansion - None.
18169 -- * Template - The annotation utilizes the generic template of the
18170 -- related package declaration.
18172 -- * Globals - Capture of global references must occur after full
18175 -- * Instance - The annotation is instantiated automatically when
18176 -- the related generic package is instantiated.
18178 when Pragma_Initializes => Initializes : declare
18179 Pack_Decl : Node_Id;
18180 Pack_Id : Entity_Id;
18184 Check_No_Identifiers;
18185 Check_Arg_Count (1);
18187 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18189 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
18190 N_Package_Declaration)
18196 Pack_Id := Defining_Entity (Pack_Decl);
18198 -- A pragma that applies to a Ghost entity becomes Ghost for the
18199 -- purposes of legality checks and removal of ignored Ghost code.
18201 Mark_Ghost_Pragma (N, Pack_Id);
18202 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18204 -- Chain the pragma on the contract for further processing by
18205 -- Analyze_Initializes_In_Decl_Part.
18207 Add_Contract_Item (N, Pack_Id);
18209 -- The legality checks of pragmas Abstract_State, Initializes, and
18210 -- Initial_Condition are affected by the SPARK mode in effect. In
18211 -- addition, these three pragmas are subject to an inherent order:
18213 -- 1) Abstract_State
18215 -- 3) Initial_Condition
18217 -- Analyze all these pragmas in the order outlined above
18219 Analyze_If_Present (Pragma_SPARK_Mode);
18220 Analyze_If_Present (Pragma_Abstract_State);
18221 Analyze_If_Present (Pragma_Initial_Condition);
18228 -- pragma Inline ( NAME {, NAME} );
18230 when Pragma_Inline =>
18232 -- Pragma always active unless in GNATprove mode. It is disabled
18233 -- in GNATprove mode because frontend inlining is applied
18234 -- independently of pragmas Inline and Inline_Always for
18235 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18238 if not GNATprove_Mode then
18240 -- Inline status is Enabled if option -gnatn is specified.
18241 -- However this status determines only the value of the
18242 -- Is_Inlined flag on the subprogram and does not prevent
18243 -- the pragma itself from being recorded for later use,
18244 -- in particular for a later modification of Is_Inlined
18245 -- independently of the -gnatn option.
18247 -- In other words, if -gnatn is specified for a unit, then
18248 -- all Inline pragmas processed for the compilation of this
18249 -- unit, including those in the spec of other units, are
18250 -- activated, so subprograms will be inlined across units.
18252 -- If -gnatn is not specified, no Inline pragma is activated
18253 -- here, which means that subprograms will not be inlined
18254 -- across units. The Is_Inlined flag will nevertheless be
18255 -- set later when bodies are analyzed, so subprograms will
18256 -- be inlined within the unit.
18258 if Inline_Active then
18259 Process_Inline (Enabled);
18261 Process_Inline (Disabled);
18265 -------------------
18266 -- Inline_Always --
18267 -------------------
18269 -- pragma Inline_Always ( NAME {, NAME} );
18271 when Pragma_Inline_Always =>
18274 -- Pragma always active unless in CodePeer mode or GNATprove
18275 -- mode. It is disabled in CodePeer mode because inlining is
18276 -- not helpful, and enabling it caused walk order issues. It
18277 -- is disabled in GNATprove mode because frontend inlining is
18278 -- applied independently of pragmas Inline and Inline_Always for
18279 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18282 if not CodePeer_Mode and not GNATprove_Mode then
18283 Process_Inline (Enabled);
18286 --------------------
18287 -- Inline_Generic --
18288 --------------------
18290 -- pragma Inline_Generic (NAME {, NAME});
18292 when Pragma_Inline_Generic =>
18294 Process_Generic_List;
18296 ----------------------
18297 -- Inspection_Point --
18298 ----------------------
18300 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18302 when Pragma_Inspection_Point => Inspection_Point : declare
18309 if Arg_Count > 0 then
18312 Exp := Get_Pragma_Arg (Arg);
18315 if not Is_Entity_Name (Exp)
18316 or else not Is_Object (Entity (Exp))
18318 Error_Pragma_Arg ("object name required", Arg);
18322 exit when No (Arg);
18325 end Inspection_Point;
18331 -- pragma Interface (
18332 -- [ Convention =>] convention_IDENTIFIER,
18333 -- [ Entity =>] LOCAL_NAME
18334 -- [, [External_Name =>] static_string_EXPRESSION ]
18335 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18337 when Pragma_Interface =>
18342 Name_External_Name,
18344 Check_At_Least_N_Arguments (2);
18345 Check_At_Most_N_Arguments (4);
18346 Process_Import_Or_Interface;
18348 -- In Ada 2005, the permission to use Interface (a reserved word)
18349 -- as a pragma name is considered an obsolescent feature, and this
18350 -- pragma was already obsolescent in Ada 95.
18352 if Ada_Version >= Ada_95 then
18354 (No_Obsolescent_Features, Pragma_Identifier (N));
18356 if Warn_On_Obsolescent_Feature then
18358 ("pragma Interface is an obsolescent feature?j?", N);
18360 ("|use pragma Import instead?j?", N);
18364 --------------------
18365 -- Interface_Name --
18366 --------------------
18368 -- pragma Interface_Name (
18369 -- [ Entity =>] LOCAL_NAME
18370 -- [,[External_Name =>] static_string_EXPRESSION ]
18371 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18373 when Pragma_Interface_Name => Interface_Name : declare
18375 Def_Id : Entity_Id;
18376 Hom_Id : Entity_Id;
18382 ((Name_Entity, Name_External_Name, Name_Link_Name));
18383 Check_At_Least_N_Arguments (2);
18384 Check_At_Most_N_Arguments (3);
18385 Id := Get_Pragma_Arg (Arg1);
18388 -- This is obsolete from Ada 95 on, but it is an implementation
18389 -- defined pragma, so we do not consider that it violates the
18390 -- restriction (No_Obsolescent_Features).
18392 if Ada_Version >= Ada_95 then
18393 if Warn_On_Obsolescent_Feature then
18395 ("pragma Interface_Name is an obsolescent feature?j?", N);
18397 ("|use pragma Import instead?j?", N);
18401 if not Is_Entity_Name (Id) then
18403 ("first argument for pragma% must be entity name", Arg1);
18404 elsif Etype (Id) = Any_Type then
18407 Def_Id := Entity (Id);
18410 -- Special DEC-compatible processing for the object case, forces
18411 -- object to be imported.
18413 if Ekind (Def_Id) = E_Variable then
18414 Kill_Size_Check_Code (Def_Id);
18415 Note_Possible_Modification (Id, Sure => False);
18417 -- Initialization is not allowed for imported variable
18419 if Present (Expression (Parent (Def_Id)))
18420 and then Comes_From_Source (Expression (Parent (Def_Id)))
18422 Error_Msg_Sloc := Sloc (Def_Id);
18424 ("no initialization allowed for declaration of& #",
18428 -- For compatibility, support VADS usage of providing both
18429 -- pragmas Interface and Interface_Name to obtain the effect
18430 -- of a single Import pragma.
18432 if Is_Imported (Def_Id)
18433 and then Present (First_Rep_Item (Def_Id))
18434 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18435 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18440 Set_Imported (Def_Id);
18443 Set_Is_Public (Def_Id);
18444 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18447 -- Otherwise must be subprogram
18449 elsif not Is_Subprogram (Def_Id) then
18451 ("argument of pragma% is not subprogram", Arg1);
18454 Check_At_Most_N_Arguments (3);
18458 -- Loop through homonyms
18461 Def_Id := Get_Base_Subprogram (Hom_Id);
18463 if Is_Imported (Def_Id) then
18464 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18468 exit when From_Aspect_Specification (N);
18469 Hom_Id := Homonym (Hom_Id);
18471 exit when No (Hom_Id)
18472 or else Scope (Hom_Id) /= Current_Scope;
18477 ("argument of pragma% is not imported subprogram",
18481 end Interface_Name;
18483 -----------------------
18484 -- Interrupt_Handler --
18485 -----------------------
18487 -- pragma Interrupt_Handler (handler_NAME);
18489 when Pragma_Interrupt_Handler =>
18490 Check_Ada_83_Warning;
18491 Check_Arg_Count (1);
18492 Check_No_Identifiers;
18494 if No_Run_Time_Mode then
18495 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18497 Check_Interrupt_Or_Attach_Handler;
18498 Process_Interrupt_Or_Attach_Handler;
18501 ------------------------
18502 -- Interrupt_Priority --
18503 ------------------------
18505 -- pragma Interrupt_Priority [(EXPRESSION)];
18507 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18508 P : constant Node_Id := Parent (N);
18513 Check_Ada_83_Warning;
18515 if Arg_Count /= 0 then
18516 Arg := Get_Pragma_Arg (Arg1);
18517 Check_Arg_Count (1);
18518 Check_No_Identifiers;
18520 -- The expression must be analyzed in the special manner
18521 -- described in "Handling of Default and Per-Object
18522 -- Expressions" in sem.ads.
18524 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18527 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
18532 Ent := Defining_Identifier (Parent (P));
18534 -- Check duplicate pragma before we chain the pragma in the Rep
18535 -- Item chain of Ent.
18537 Check_Duplicate_Pragma (Ent);
18538 Record_Rep_Item (Ent, N);
18540 -- Check the No_Task_At_Interrupt_Priority restriction
18542 if Nkind (P) = N_Task_Definition then
18543 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18546 end Interrupt_Priority;
18548 ---------------------
18549 -- Interrupt_State --
18550 ---------------------
18552 -- pragma Interrupt_State (
18553 -- [Name =>] INTERRUPT_ID,
18554 -- [State =>] INTERRUPT_STATE);
18556 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18557 -- INTERRUPT_STATE => System | Runtime | User
18559 -- Note: if the interrupt id is given as an identifier, then it must
18560 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18561 -- given as a static integer expression which must be in the range of
18562 -- Ada.Interrupts.Interrupt_ID.
18564 when Pragma_Interrupt_State => Interrupt_State : declare
18565 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18566 -- This is the entity Ada.Interrupts.Interrupt_ID;
18568 State_Type : Character;
18569 -- Set to 's'/'r'/'u' for System/Runtime/User
18572 -- Index to entry in Interrupt_States table
18575 -- Value of interrupt
18577 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18578 -- The first argument to the pragma
18580 Int_Ent : Entity_Id;
18581 -- Interrupt entity in Ada.Interrupts.Names
18585 Check_Arg_Order ((Name_Name, Name_State));
18586 Check_Arg_Count (2);
18588 Check_Optional_Identifier (Arg1, Name_Name);
18589 Check_Optional_Identifier (Arg2, Name_State);
18590 Check_Arg_Is_Identifier (Arg2);
18592 -- First argument is identifier
18594 if Nkind (Arg1X) = N_Identifier then
18596 -- Search list of names in Ada.Interrupts.Names
18598 Int_Ent := First_Entity (RTE (RE_Names));
18600 if No (Int_Ent) then
18601 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18603 elsif Chars (Int_Ent) = Chars (Arg1X) then
18604 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18608 Next_Entity (Int_Ent);
18611 -- First argument is not an identifier, so it must be a static
18612 -- expression of type Ada.Interrupts.Interrupt_ID.
18615 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18616 Int_Val := Expr_Value (Arg1X);
18618 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18620 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18623 ("value not in range of type "
18624 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18630 case Chars (Get_Pragma_Arg (Arg2)) is
18631 when Name_Runtime => State_Type := 'r';
18632 when Name_System => State_Type := 's';
18633 when Name_User => State_Type := 'u';
18636 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18639 -- Check if entry is already stored
18641 IST_Num := Interrupt_States.First;
18643 -- If entry not found, add it
18645 if IST_Num > Interrupt_States.Last then
18646 Interrupt_States.Append
18647 ((Interrupt_Number => UI_To_Int (Int_Val),
18648 Interrupt_State => State_Type,
18649 Pragma_Loc => Loc));
18652 -- Case of entry for the same entry
18654 elsif Int_Val = Interrupt_States.Table (IST_Num).
18657 -- If state matches, done, no need to make redundant entry
18660 State_Type = Interrupt_States.Table (IST_Num).
18663 -- Otherwise if state does not match, error
18666 Interrupt_States.Table (IST_Num).Pragma_Loc;
18668 ("state conflicts with that given #", Arg2);
18672 IST_Num := IST_Num + 1;
18674 end Interrupt_State;
18680 -- pragma Invariant
18681 -- ([Entity =>] type_LOCAL_NAME,
18682 -- [Check =>] EXPRESSION
18683 -- [,[Message =>] String_Expression]);
18685 when Pragma_Invariant => Invariant : declare
18692 Check_At_Least_N_Arguments (2);
18693 Check_At_Most_N_Arguments (3);
18694 Check_Optional_Identifier (Arg1, Name_Entity);
18695 Check_Optional_Identifier (Arg2, Name_Check);
18697 if Arg_Count = 3 then
18698 Check_Optional_Identifier (Arg3, Name_Message);
18699 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18702 Check_Arg_Is_Local_Name (Arg1);
18704 Typ_Arg := Get_Pragma_Arg (Arg1);
18705 Find_Type (Typ_Arg);
18706 Typ := Entity (Typ_Arg);
18708 -- Nothing to do of the related type is erroneous in some way
18710 if Typ = Any_Type then
18713 -- AI12-0041: Invariants are allowed in interface types
18715 elsif Is_Interface (Typ) then
18718 -- An invariant must apply to a private type, or appear in the
18719 -- private part of a package spec and apply to a completion.
18720 -- a class-wide invariant can only appear on a private declaration
18721 -- or private extension, not a completion.
18723 -- A [class-wide] invariant may be associated a [limited] private
18724 -- type or a private extension.
18726 elsif Ekind_In (Typ, E_Limited_Private_Type,
18728 E_Record_Type_With_Private)
18732 -- A non-class-wide invariant may be associated with the full view
18733 -- of a [limited] private type or a private extension.
18735 elsif Has_Private_Declaration (Typ)
18736 and then not Class_Present (N)
18740 -- A class-wide invariant may appear on the partial view only
18742 elsif Class_Present (N) then
18744 ("pragma % only allowed for private type", Arg1);
18747 -- A regular invariant may appear on both views
18751 ("pragma % only allowed for private type or corresponding "
18752 & "full view", Arg1);
18756 -- An invariant associated with an abstract type (this includes
18757 -- interfaces) must be class-wide.
18759 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18761 ("pragma % not allowed for abstract type", Arg1);
18765 -- A pragma that applies to a Ghost entity becomes Ghost for the
18766 -- purposes of legality checks and removal of ignored Ghost code.
18768 Mark_Ghost_Pragma (N, Typ);
18770 -- The pragma defines a type-specific invariant, the type is said
18771 -- to have invariants of its "own".
18773 Set_Has_Own_Invariants (Typ);
18775 -- If the invariant is class-wide, then it can be inherited by
18776 -- derived or interface implementing types. The type is said to
18777 -- have "inheritable" invariants.
18779 if Class_Present (N) then
18780 Set_Has_Inheritable_Invariants (Typ);
18783 -- Chain the pragma on to the rep item chain, for processing when
18784 -- the type is frozen.
18786 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18788 -- Create the declaration of the invariant procedure that will
18789 -- verify the invariant at run time. Interfaces are treated as the
18790 -- partial view of a private type in order to achieve uniformity
18791 -- with the general case. As a result, an interface receives only
18792 -- a "partial" invariant procedure, which is never called.
18794 Build_Invariant_Procedure_Declaration
18796 Partial_Invariant => Is_Interface (Typ));
18803 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18805 when Pragma_Keep_Names => Keep_Names : declare
18810 Check_Arg_Count (1);
18811 Check_Optional_Identifier (Arg1, Name_On);
18812 Check_Arg_Is_Local_Name (Arg1);
18814 Arg := Get_Pragma_Arg (Arg1);
18817 if Etype (Arg) = Any_Type then
18821 if not Is_Entity_Name (Arg)
18822 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18825 ("pragma% requires a local enumeration type", Arg1);
18828 Set_Discard_Names (Entity (Arg), False);
18835 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18837 when Pragma_License =>
18840 -- Do not analyze pragma any further in CodePeer mode, to avoid
18841 -- extraneous errors in this implementation-dependent pragma,
18842 -- which has a different profile on other compilers.
18844 if CodePeer_Mode then
18848 Check_Arg_Count (1);
18849 Check_No_Identifiers;
18850 Check_Valid_Configuration_Pragma;
18851 Check_Arg_Is_Identifier (Arg1);
18854 Sind : constant Source_File_Index :=
18855 Source_Index (Current_Sem_Unit);
18858 case Chars (Get_Pragma_Arg (Arg1)) is
18860 Set_License (Sind, GPL);
18862 when Name_Modified_GPL =>
18863 Set_License (Sind, Modified_GPL);
18865 when Name_Restricted =>
18866 Set_License (Sind, Restricted);
18868 when Name_Unrestricted =>
18869 Set_License (Sind, Unrestricted);
18872 Error_Pragma_Arg ("invalid license name", Arg1);
18880 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18882 when Pragma_Link_With => Link_With : declare
18888 if Operating_Mode = Generate_Code
18889 and then In_Extended_Main_Source_Unit (N)
18891 Check_At_Least_N_Arguments (1);
18892 Check_No_Identifiers;
18893 Check_Is_In_Decl_Part_Or_Package_Spec;
18894 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18898 while Present (Arg) loop
18899 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18901 -- Store argument, converting sequences of spaces to a
18902 -- single null character (this is one of the differences
18903 -- in processing between Link_With and Linker_Options).
18905 Arg_Store : declare
18906 C : constant Char_Code := Get_Char_Code (' ');
18907 S : constant String_Id :=
18908 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18909 L : constant Nat := String_Length (S);
18912 procedure Skip_Spaces;
18913 -- Advance F past any spaces
18919 procedure Skip_Spaces is
18921 while F <= L and then Get_String_Char (S, F) = C loop
18926 -- Start of processing for Arg_Store
18929 Skip_Spaces; -- skip leading spaces
18931 -- Loop through characters, changing any embedded
18932 -- sequence of spaces to a single null character (this
18933 -- is how Link_With/Linker_Options differ)
18936 if Get_String_Char (S, F) = C then
18939 Store_String_Char (ASCII.NUL);
18942 Store_String_Char (Get_String_Char (S, F));
18950 if Present (Arg) then
18951 Store_String_Char (ASCII.NUL);
18955 Store_Linker_Option_String (End_String);
18963 -- pragma Linker_Alias (
18964 -- [Entity =>] LOCAL_NAME
18965 -- [Target =>] static_string_EXPRESSION);
18967 when Pragma_Linker_Alias =>
18969 Check_Arg_Order ((Name_Entity, Name_Target));
18970 Check_Arg_Count (2);
18971 Check_Optional_Identifier (Arg1, Name_Entity);
18972 Check_Optional_Identifier (Arg2, Name_Target);
18973 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18974 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18976 -- The only processing required is to link this item on to the
18977 -- list of rep items for the given entity. This is accomplished
18978 -- by the call to Rep_Item_Too_Late (when no error is detected
18979 -- and False is returned).
18981 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18984 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18987 ------------------------
18988 -- Linker_Constructor --
18989 ------------------------
18991 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18993 -- Code is shared with Linker_Destructor
18995 -----------------------
18996 -- Linker_Destructor --
18997 -----------------------
18999 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19001 when Pragma_Linker_Constructor
19002 | Pragma_Linker_Destructor
19004 Linker_Constructor : declare
19010 Check_Arg_Count (1);
19011 Check_No_Identifiers;
19012 Check_Arg_Is_Local_Name (Arg1);
19013 Arg1_X := Get_Pragma_Arg (Arg1);
19015 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
19017 if not Is_Library_Level_Entity (Proc) then
19019 ("argument for pragma% must be library level entity", Arg1);
19022 -- The only processing required is to link this item on to the
19023 -- list of rep items for the given entity. This is accomplished
19024 -- by the call to Rep_Item_Too_Late (when no error is detected
19025 -- and False is returned).
19027 if Rep_Item_Too_Late (Proc, N) then
19030 Set_Has_Gigi_Rep_Item (Proc);
19032 end Linker_Constructor;
19034 --------------------
19035 -- Linker_Options --
19036 --------------------
19038 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19040 when Pragma_Linker_Options => Linker_Options : declare
19044 Check_Ada_83_Warning;
19045 Check_No_Identifiers;
19046 Check_Arg_Count (1);
19047 Check_Is_In_Decl_Part_Or_Package_Spec;
19048 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19049 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
19052 while Present (Arg) loop
19053 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19054 Store_String_Char (ASCII.NUL);
19056 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
19060 if Operating_Mode = Generate_Code
19061 and then In_Extended_Main_Source_Unit (N)
19063 Store_Linker_Option_String (End_String);
19065 end Linker_Options;
19067 --------------------
19068 -- Linker_Section --
19069 --------------------
19071 -- pragma Linker_Section (
19072 -- [Entity =>] LOCAL_NAME
19073 -- [Section =>] static_string_EXPRESSION);
19075 when Pragma_Linker_Section => Linker_Section : declare
19080 Ghost_Error_Posted : Boolean := False;
19081 -- Flag set when an error concerning the illegal mix of Ghost and
19082 -- non-Ghost subprograms is emitted.
19084 Ghost_Id : Entity_Id := Empty;
19085 -- The entity of the first Ghost subprogram encountered while
19086 -- processing the arguments of the pragma.
19090 Check_Arg_Order ((Name_Entity, Name_Section));
19091 Check_Arg_Count (2);
19092 Check_Optional_Identifier (Arg1, Name_Entity);
19093 Check_Optional_Identifier (Arg2, Name_Section);
19094 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19095 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19097 -- Check kind of entity
19099 Arg := Get_Pragma_Arg (Arg1);
19100 Ent := Entity (Arg);
19102 case Ekind (Ent) is
19104 -- Objects (constants and variables) and types. For these cases
19105 -- all we need to do is to set the Linker_Section_pragma field,
19106 -- checking that we do not have a duplicate.
19112 LPE := Linker_Section_Pragma (Ent);
19114 if Present (LPE) then
19115 Error_Msg_Sloc := Sloc (LPE);
19117 ("Linker_Section already specified for &#", Arg1, Ent);
19120 Set_Linker_Section_Pragma (Ent, N);
19122 -- A pragma that applies to a Ghost entity becomes Ghost for
19123 -- the purposes of legality checks and removal of ignored
19126 Mark_Ghost_Pragma (N, Ent);
19130 when Subprogram_Kind =>
19132 -- Aspect case, entity already set
19134 if From_Aspect_Specification (N) then
19135 Set_Linker_Section_Pragma
19136 (Entity (Corresponding_Aspect (N)), N);
19138 -- Pragma case, we must climb the homonym chain, but skip
19139 -- any for which the linker section is already set.
19143 if No (Linker_Section_Pragma (Ent)) then
19144 Set_Linker_Section_Pragma (Ent, N);
19146 -- A pragma that applies to a Ghost entity becomes
19147 -- Ghost for the purposes of legality checks and
19148 -- removal of ignored Ghost code.
19150 Mark_Ghost_Pragma (N, Ent);
19152 -- Capture the entity of the first Ghost subprogram
19153 -- being processed for error detection purposes.
19155 if Is_Ghost_Entity (Ent) then
19156 if No (Ghost_Id) then
19160 -- Otherwise the subprogram is non-Ghost. It is
19161 -- illegal to mix references to Ghost and non-Ghost
19162 -- entities (SPARK RM 6.9).
19164 elsif Present (Ghost_Id)
19165 and then not Ghost_Error_Posted
19167 Ghost_Error_Posted := True;
19169 Error_Msg_Name_1 := Pname;
19171 ("pragma % cannot mention ghost and "
19172 & "non-ghost subprograms", N);
19174 Error_Msg_Sloc := Sloc (Ghost_Id);
19176 ("\& # declared as ghost", N, Ghost_Id);
19178 Error_Msg_Sloc := Sloc (Ent);
19180 ("\& # declared as non-ghost", N, Ent);
19184 Ent := Homonym (Ent);
19186 or else Scope (Ent) /= Current_Scope;
19190 -- All other cases are illegal
19194 ("pragma% applies only to objects, subprograms, and types",
19197 end Linker_Section;
19203 -- pragma List (On | Off)
19205 -- There is nothing to do here, since we did all the processing for
19206 -- this pragma in Par.Prag (so that it works properly even in syntax
19209 when Pragma_List =>
19216 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19218 when Pragma_Lock_Free => Lock_Free : declare
19219 P : constant Node_Id := Parent (N);
19225 Check_No_Identifiers;
19226 Check_At_Most_N_Arguments (1);
19228 -- Protected definition case
19230 if Nkind (P) = N_Protected_Definition then
19231 Ent := Defining_Identifier (Parent (P));
19235 if Arg_Count = 1 then
19236 Arg := Get_Pragma_Arg (Arg1);
19237 Val := Is_True (Static_Boolean (Arg));
19239 -- No arguments (expression is considered to be True)
19245 -- Check duplicate pragma before we chain the pragma in the Rep
19246 -- Item chain of Ent.
19248 Check_Duplicate_Pragma (Ent);
19249 Record_Rep_Item (Ent, N);
19250 Set_Uses_Lock_Free (Ent, Val);
19252 -- Anything else is incorrect placement
19259 --------------------
19260 -- Locking_Policy --
19261 --------------------
19263 -- pragma Locking_Policy (policy_IDENTIFIER);
19265 when Pragma_Locking_Policy => declare
19266 subtype LP_Range is Name_Id
19267 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19272 Check_Ada_83_Warning;
19273 Check_Arg_Count (1);
19274 Check_No_Identifiers;
19275 Check_Arg_Is_Locking_Policy (Arg1);
19276 Check_Valid_Configuration_Pragma;
19277 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19280 when Name_Ceiling_Locking => LP := 'C';
19281 when Name_Concurrent_Readers_Locking => LP := 'R';
19282 when Name_Inheritance_Locking => LP := 'I';
19285 if Locking_Policy /= ' '
19286 and then Locking_Policy /= LP
19288 Error_Msg_Sloc := Locking_Policy_Sloc;
19289 Error_Pragma ("locking policy incompatible with policy#");
19291 -- Set new policy, but always preserve System_Location since we
19292 -- like the error message with the run time name.
19295 Locking_Policy := LP;
19297 if Locking_Policy_Sloc /= System_Location then
19298 Locking_Policy_Sloc := Loc;
19303 -------------------
19304 -- Loop_Optimize --
19305 -------------------
19307 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19309 -- OPTIMIZATION_HINT ::=
19310 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19312 when Pragma_Loop_Optimize => Loop_Optimize : declare
19317 Check_At_Least_N_Arguments (1);
19318 Check_No_Identifiers;
19320 Hint := First (Pragma_Argument_Associations (N));
19321 while Present (Hint) loop
19322 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19330 Check_Loop_Pragma_Placement;
19337 -- pragma Loop_Variant
19338 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19340 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19342 -- CHANGE_DIRECTION ::= Increases | Decreases
19344 when Pragma_Loop_Variant => Loop_Variant : declare
19349 Check_At_Least_N_Arguments (1);
19350 Check_Loop_Pragma_Placement;
19352 -- Process all increasing / decreasing expressions
19354 Variant := First (Pragma_Argument_Associations (N));
19355 while Present (Variant) loop
19356 if Chars (Variant) = No_Name then
19357 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19359 elsif not Nam_In (Chars (Variant), Name_Decreases,
19363 Name : String := Get_Name_String (Chars (Variant));
19366 -- It is a common mistake to write "Increasing" for
19367 -- "Increases" or "Decreasing" for "Decreases". Recognize
19368 -- specially names starting with "incr" or "decr" to
19369 -- suggest the corresponding name.
19371 System.Case_Util.To_Lower (Name);
19373 if Name'Length >= 4
19374 and then Name (1 .. 4) = "incr"
19376 Error_Pragma_Arg_Ident
19377 ("expect name `Increases`", Variant);
19379 elsif Name'Length >= 4
19380 and then Name (1 .. 4) = "decr"
19382 Error_Pragma_Arg_Ident
19383 ("expect name `Decreases`", Variant);
19386 Error_Pragma_Arg_Ident
19387 ("expect name `Increases` or `Decreases`", Variant);
19392 Preanalyze_Assert_Expression
19393 (Expression (Variant), Any_Discrete);
19399 -----------------------
19400 -- Machine_Attribute --
19401 -----------------------
19403 -- pragma Machine_Attribute (
19404 -- [Entity =>] LOCAL_NAME,
19405 -- [Attribute_Name =>] static_string_EXPRESSION
19406 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19408 when Pragma_Machine_Attribute => Machine_Attribute : declare
19410 Def_Id : Entity_Id;
19414 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19416 if Arg_Count >= 3 then
19417 Check_Optional_Identifier (Arg3, Name_Info);
19419 while Present (Arg) loop
19420 Check_Arg_Is_OK_Static_Expression (Arg);
19424 Check_Arg_Count (2);
19427 Check_Optional_Identifier (Arg1, Name_Entity);
19428 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19429 Check_Arg_Is_Local_Name (Arg1);
19430 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19431 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19433 if Is_Access_Type (Def_Id) then
19434 Def_Id := Designated_Type (Def_Id);
19437 if Rep_Item_Too_Early (Def_Id, N) then
19441 Def_Id := Underlying_Type (Def_Id);
19443 -- The only processing required is to link this item on to the
19444 -- list of rep items for the given entity. This is accomplished
19445 -- by the call to Rep_Item_Too_Late (when no error is detected
19446 -- and False is returned).
19448 if Rep_Item_Too_Late (Def_Id, N) then
19451 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19453 end Machine_Attribute;
19460 -- (MAIN_OPTION [, MAIN_OPTION]);
19463 -- [STACK_SIZE =>] static_integer_EXPRESSION
19464 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19465 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19467 when Pragma_Main => Main : declare
19468 Args : Args_List (1 .. 3);
19469 Names : constant Name_List (1 .. 3) := (
19471 Name_Task_Stack_Size_Default,
19472 Name_Time_Slicing_Enabled);
19478 Gather_Associations (Names, Args);
19480 for J in 1 .. 2 loop
19481 if Present (Args (J)) then
19482 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19486 if Present (Args (3)) then
19487 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19491 while Present (Nod) loop
19492 if Nkind (Nod) = N_Pragma
19493 and then Pragma_Name (Nod) = Name_Main
19495 Error_Msg_Name_1 := Pname;
19496 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19507 -- pragma Main_Storage
19508 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19510 -- MAIN_STORAGE_OPTION ::=
19511 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19512 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19514 when Pragma_Main_Storage => Main_Storage : declare
19515 Args : Args_List (1 .. 2);
19516 Names : constant Name_List (1 .. 2) := (
19517 Name_Working_Storage,
19524 Gather_Associations (Names, Args);
19526 for J in 1 .. 2 loop
19527 if Present (Args (J)) then
19528 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19532 Check_In_Main_Program;
19535 while Present (Nod) loop
19536 if Nkind (Nod) = N_Pragma
19537 and then Pragma_Name (Nod) = Name_Main_Storage
19539 Error_Msg_Name_1 := Pname;
19540 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19547 ----------------------------
19548 -- Max_Entry_Queue_Length --
19549 ----------------------------
19551 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19553 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19554 -- Pragma_Max_Queue_Length.
19556 when Pragma_Max_Entry_Queue_Length
19557 | Pragma_Max_Entry_Queue_Depth
19558 | Pragma_Max_Queue_Length
19560 Max_Queue_Length : declare
19562 Entry_Decl : Node_Id;
19563 Entry_Id : Entity_Id;
19567 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19568 or else Prag_Id = Pragma_Max_Queue_Length
19573 Check_Arg_Count (1);
19576 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19578 -- Entry declaration
19580 if Nkind (Entry_Decl) = N_Entry_Declaration then
19582 -- Entry illegally within a task
19584 if Nkind (Parent (N)) = N_Task_Definition then
19585 Error_Pragma ("pragma % cannot apply to task entries");
19589 Entry_Id := Defining_Entity (Entry_Decl);
19591 -- Otherwise the pragma is associated with an illegal construct
19594 Error_Pragma ("pragma % must apply to a protected entry");
19598 -- Mark the pragma as Ghost if the related subprogram is also
19599 -- Ghost. This also ensures that any expansion performed further
19600 -- below will produce Ghost nodes.
19602 Mark_Ghost_Pragma (N, Entry_Id);
19604 -- Analyze the Integer expression
19606 Arg := Get_Pragma_Arg (Arg1);
19607 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19609 Val := Expr_Value (Arg);
19613 ("argument for pragma% must be positive", Arg1);
19615 elsif not UI_Is_In_Int_Range (Val) then
19617 ("argument for pragma% out of range of Integer", Arg1);
19621 -- Manually substitute the expression value of the pragma argument
19622 -- if it's not an integer literal because this is not taken care
19623 -- of automatically elsewhere.
19625 if Nkind (Arg) /= N_Integer_Literal then
19626 Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
19627 Set_Etype (Arg, Etype (Original_Node (Arg)));
19630 Record_Rep_Item (Entry_Id, N);
19631 end Max_Queue_Length;
19637 -- pragma Memory_Size (NUMERIC_LITERAL)
19639 when Pragma_Memory_Size =>
19642 -- Memory size is simply ignored
19644 Check_No_Identifiers;
19645 Check_Arg_Count (1);
19646 Check_Arg_Is_Integer_Literal (Arg1);
19654 -- The only correct use of this pragma is on its own in a file, in
19655 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19656 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19657 -- check for a file containing nothing but a No_Body pragma). If we
19658 -- attempt to process it during normal semantics processing, it means
19659 -- it was misplaced.
19661 when Pragma_No_Body =>
19665 -----------------------------
19666 -- No_Elaboration_Code_All --
19667 -----------------------------
19669 -- pragma No_Elaboration_Code_All;
19671 when Pragma_No_Elaboration_Code_All =>
19673 Check_Valid_Library_Unit_Pragma;
19675 if Nkind (N) = N_Null_Statement then
19679 -- Must appear for a spec or generic spec
19681 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
19682 N_Generic_Package_Declaration,
19683 N_Generic_Subprogram_Declaration,
19684 N_Package_Declaration,
19685 N_Subprogram_Declaration)
19689 ("pragma% can only occur for package "
19690 & "or subprogram spec"));
19693 -- Set flag in unit table
19695 Set_No_Elab_Code_All (Current_Sem_Unit);
19697 -- Set restriction No_Elaboration_Code if this is the main unit
19699 if Current_Sem_Unit = Main_Unit then
19700 Set_Restriction (No_Elaboration_Code, N);
19703 -- If we are in the main unit or in an extended main source unit,
19704 -- then we also add it to the configuration restrictions so that
19705 -- it will apply to all units in the extended main source.
19707 if Current_Sem_Unit = Main_Unit
19708 or else In_Extended_Main_Source_Unit (N)
19710 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19713 -- If in main extended unit, activate transitive with test
19715 if In_Extended_Main_Source_Unit (N) then
19716 Opt.No_Elab_Code_All_Pragma := N;
19719 -----------------------------
19720 -- No_Component_Reordering --
19721 -----------------------------
19723 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19725 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19731 Check_At_Most_N_Arguments (1);
19733 if Arg_Count = 0 then
19734 Check_Valid_Configuration_Pragma;
19735 Opt.No_Component_Reordering := True;
19738 Check_Optional_Identifier (Arg2, Name_Entity);
19739 Check_Arg_Is_Local_Name (Arg1);
19740 E_Id := Get_Pragma_Arg (Arg1);
19742 if Etype (E_Id) = Any_Type then
19746 E := Entity (E_Id);
19748 if not Is_Record_Type (E) then
19749 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19752 Set_No_Reordering (Base_Type (E));
19754 end No_Comp_Reordering;
19756 --------------------------
19757 -- No_Heap_Finalization --
19758 --------------------------
19760 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19762 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19763 Context : constant Node_Id := Parent (N);
19764 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19770 Check_No_Identifiers;
19772 -- The pragma appears in a configuration file
19774 if No (Context) then
19775 Check_Arg_Count (0);
19776 Check_Valid_Configuration_Pragma;
19778 -- Detect a duplicate pragma
19780 if Present (No_Heap_Finalization_Pragma) then
19783 Prev => No_Heap_Finalization_Pragma);
19787 No_Heap_Finalization_Pragma := N;
19789 -- Otherwise the pragma should be associated with a library-level
19790 -- named access-to-object type.
19793 Check_Arg_Count (1);
19794 Check_Arg_Is_Local_Name (Arg1);
19796 Find_Type (Typ_Arg);
19797 Typ := Entity (Typ_Arg);
19799 -- The type being subjected to the pragma is erroneous
19801 if Typ = Any_Type then
19802 Error_Pragma ("cannot find type referenced by pragma %");
19804 -- The pragma is applied to an incomplete or generic formal
19805 -- type way too early.
19807 elsif Rep_Item_Too_Early (Typ, N) then
19811 Typ := Underlying_Type (Typ);
19814 -- The pragma must apply to an access-to-object type
19816 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
19819 -- Give a detailed error message on all other access type kinds
19821 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19823 ("pragma % cannot apply to access protected subprogram "
19826 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19828 ("pragma % cannot apply to access subprogram type");
19830 elsif Is_Anonymous_Access_Type (Typ) then
19832 ("pragma % cannot apply to anonymous access type");
19834 -- Give a general error message in case the pragma applies to a
19835 -- non-access type.
19839 ("pragma % must apply to library level access type");
19842 -- At this point the argument denotes an access-to-object type.
19843 -- Ensure that the type is declared at the library level.
19845 if Is_Library_Level_Entity (Typ) then
19848 -- Quietly ignore an access-to-object type originally declared
19849 -- at the library level within a generic, but instantiated at
19850 -- a non-library level. As a result the access-to-object type
19851 -- "loses" its No_Heap_Finalization property.
19853 elsif In_Instance then
19858 ("pragma % must apply to library level access type");
19861 -- Detect a duplicate pragma
19863 if Present (No_Heap_Finalization_Pragma) then
19866 Prev => No_Heap_Finalization_Pragma);
19870 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19872 if Present (Prev) then
19880 Record_Rep_Item (Typ, N);
19882 end No_Heap_Finalization;
19888 -- pragma No_Inline ( NAME {, NAME} );
19890 when Pragma_No_Inline =>
19892 Process_Inline (Suppressed);
19898 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19900 when Pragma_No_Return => No_Return : declare
19906 Ghost_Error_Posted : Boolean := False;
19907 -- Flag set when an error concerning the illegal mix of Ghost and
19908 -- non-Ghost subprograms is emitted.
19910 Ghost_Id : Entity_Id := Empty;
19911 -- The entity of the first Ghost procedure encountered while
19912 -- processing the arguments of the pragma.
19916 Check_At_Least_N_Arguments (1);
19918 -- Loop through arguments of pragma
19921 while Present (Arg) loop
19922 Check_Arg_Is_Local_Name (Arg);
19923 Id := Get_Pragma_Arg (Arg);
19926 if not Is_Entity_Name (Id) then
19927 Error_Pragma_Arg ("entity name required", Arg);
19930 if Etype (Id) = Any_Type then
19934 -- Loop to find matching procedures
19940 and then Scope (E) = Current_Scope
19942 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
19944 -- Check that the pragma is not applied to a body.
19945 -- First check the specless body case, to give a
19946 -- different error message. These checks do not apply
19947 -- if Relaxed_RM_Semantics, to accommodate other Ada
19948 -- compilers. Disable these checks under -gnatd.J.
19950 if not Debug_Flag_Dot_JJ then
19951 if Nkind (Parent (Declaration_Node (E))) =
19953 and then not Relaxed_RM_Semantics
19956 ("pragma% requires separate spec and must come "
19960 -- Now the "specful" body case
19962 if Rep_Item_Too_Late (E, N) then
19969 -- A pragma that applies to a Ghost entity becomes Ghost
19970 -- for the purposes of legality checks and removal of
19971 -- ignored Ghost code.
19973 Mark_Ghost_Pragma (N, E);
19975 -- Capture the entity of the first Ghost procedure being
19976 -- processed for error detection purposes.
19978 if Is_Ghost_Entity (E) then
19979 if No (Ghost_Id) then
19983 -- Otherwise the subprogram is non-Ghost. It is illegal
19984 -- to mix references to Ghost and non-Ghost entities
19987 elsif Present (Ghost_Id)
19988 and then not Ghost_Error_Posted
19990 Ghost_Error_Posted := True;
19992 Error_Msg_Name_1 := Pname;
19994 ("pragma % cannot mention ghost and non-ghost "
19995 & "procedures", N);
19997 Error_Msg_Sloc := Sloc (Ghost_Id);
19998 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
20000 Error_Msg_Sloc := Sloc (E);
20001 Error_Msg_NE ("\& # declared as non-ghost", N, E);
20004 -- Set flag on any alias as well
20006 if Is_Overloadable (E) and then Present (Alias (E)) then
20007 Set_No_Return (Alias (E));
20013 exit when From_Aspect_Specification (N);
20017 -- If entity in not in current scope it may be the enclosing
20018 -- suprogram body to which the aspect applies.
20021 if Entity (Id) = Current_Scope
20022 and then From_Aspect_Specification (N)
20024 Set_No_Return (Entity (Id));
20026 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
20038 -- pragma No_Run_Time;
20040 -- Note: this pragma is retained for backwards compatibility. See
20041 -- body of Rtsfind for full details on its handling.
20043 when Pragma_No_Run_Time =>
20045 Check_Valid_Configuration_Pragma;
20046 Check_Arg_Count (0);
20048 -- Remove backward compatibility if Build_Type is FSF or GPL and
20049 -- generate a warning.
20052 Ignore : constant Boolean := Build_Type in FSF .. GPL;
20055 Error_Pragma ("pragma% is ignored, has no effect??");
20057 No_Run_Time_Mode := True;
20058 Configurable_Run_Time_Mode := True;
20060 -- Set Duration to 32 bits if word size is 32
20062 if Ttypes.System_Word_Size = 32 then
20063 Duration_32_Bits_On_Target := True;
20066 -- Set appropriate restrictions
20068 Set_Restriction (No_Finalization, N);
20069 Set_Restriction (No_Exception_Handlers, N);
20070 Set_Restriction (Max_Tasks, N, 0);
20071 Set_Restriction (No_Tasking, N);
20075 -----------------------
20076 -- No_Tagged_Streams --
20077 -----------------------
20079 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20081 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
20087 Check_At_Most_N_Arguments (1);
20089 -- One argument case
20091 if Arg_Count = 1 then
20092 Check_Optional_Identifier (Arg1, Name_Entity);
20093 Check_Arg_Is_Local_Name (Arg1);
20094 E_Id := Get_Pragma_Arg (Arg1);
20096 if Etype (E_Id) = Any_Type then
20100 E := Entity (E_Id);
20102 Check_Duplicate_Pragma (E);
20104 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
20106 ("argument for pragma% must be root tagged type", Arg1);
20109 if Rep_Item_Too_Early (E, N)
20111 Rep_Item_Too_Late (E, N)
20115 Set_No_Tagged_Streams_Pragma (E, N);
20118 -- Zero argument case
20121 Check_Is_In_Decl_Part_Or_Package_Spec;
20122 No_Tagged_Streams := N;
20124 end No_Tagged_Strms;
20126 ------------------------
20127 -- No_Strict_Aliasing --
20128 ------------------------
20130 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20132 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20138 Check_At_Most_N_Arguments (1);
20140 if Arg_Count = 0 then
20141 Check_Valid_Configuration_Pragma;
20142 Opt.No_Strict_Aliasing := True;
20145 Check_Optional_Identifier (Arg2, Name_Entity);
20146 Check_Arg_Is_Local_Name (Arg1);
20147 E_Id := Get_Pragma_Arg (Arg1);
20149 if Etype (E_Id) = Any_Type then
20153 E := Entity (E_Id);
20155 if not Is_Access_Type (E) then
20156 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20159 Set_No_Strict_Aliasing (Base_Type (E));
20161 end No_Strict_Aliasing;
20163 -----------------------
20164 -- Normalize_Scalars --
20165 -----------------------
20167 -- pragma Normalize_Scalars;
20169 when Pragma_Normalize_Scalars =>
20170 Check_Ada_83_Warning;
20171 Check_Arg_Count (0);
20172 Check_Valid_Configuration_Pragma;
20174 -- Normalize_Scalars creates false positives in CodePeer, and
20175 -- incorrect negative results in GNATprove mode, so ignore this
20176 -- pragma in these modes.
20178 if not (CodePeer_Mode or GNATprove_Mode) then
20179 Normalize_Scalars := True;
20180 Init_Or_Norm_Scalars := True;
20187 -- pragma Obsolescent;
20189 -- pragma Obsolescent (
20190 -- [Message =>] static_string_EXPRESSION
20191 -- [,[Version =>] Ada_05]]);
20193 -- pragma Obsolescent (
20194 -- [Entity =>] NAME
20195 -- [,[Message =>] static_string_EXPRESSION
20196 -- [,[Version =>] Ada_05]] );
20198 when Pragma_Obsolescent => Obsolescent : declare
20202 procedure Set_Obsolescent (E : Entity_Id);
20203 -- Given an entity Ent, mark it as obsolescent if appropriate
20205 ---------------------
20206 -- Set_Obsolescent --
20207 ---------------------
20209 procedure Set_Obsolescent (E : Entity_Id) is
20218 -- A pragma that applies to a Ghost entity becomes Ghost for
20219 -- the purposes of legality checks and removal of ignored Ghost
20222 Mark_Ghost_Pragma (N, E);
20224 -- Entity name was given
20226 if Present (Ename) then
20228 -- If entity name matches, we are fine. Save entity in
20229 -- pragma argument, for ASIS use.
20231 if Chars (Ename) = Chars (Ent) then
20232 Set_Entity (Ename, Ent);
20233 Generate_Reference (Ent, Ename);
20235 -- If entity name does not match, only possibility is an
20236 -- enumeration literal from an enumeration type declaration.
20238 elsif Ekind (Ent) /= E_Enumeration_Type then
20240 ("pragma % entity name does not match declaration");
20243 Ent := First_Literal (E);
20247 ("pragma % entity name does not match any "
20248 & "enumeration literal");
20250 elsif Chars (Ent) = Chars (Ename) then
20251 Set_Entity (Ename, Ent);
20252 Generate_Reference (Ent, Ename);
20256 Ent := Next_Literal (Ent);
20262 -- Ent points to entity to be marked
20264 if Arg_Count >= 1 then
20266 -- Deal with static string argument
20268 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20269 S := Strval (Get_Pragma_Arg (Arg1));
20271 for J in 1 .. String_Length (S) loop
20272 if not In_Character_Range (Get_String_Char (S, J)) then
20274 ("pragma% argument does not allow wide characters",
20279 Obsolescent_Warnings.Append
20280 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20282 -- Check for Ada_05 parameter
20284 if Arg_Count /= 1 then
20285 Check_Arg_Count (2);
20288 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20291 Check_Arg_Is_Identifier (Argx);
20293 if Chars (Argx) /= Name_Ada_05 then
20294 Error_Msg_Name_2 := Name_Ada_05;
20296 ("only allowed argument for pragma% is %", Argx);
20299 if Ada_Version_Explicit < Ada_2005
20300 or else not Warn_On_Ada_2005_Compatibility
20308 -- Set flag if pragma active
20311 Set_Is_Obsolescent (Ent);
20315 end Set_Obsolescent;
20317 -- Start of processing for pragma Obsolescent
20322 Check_At_Most_N_Arguments (3);
20324 -- See if first argument specifies an entity name
20328 (Chars (Arg1) = Name_Entity
20330 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
20332 N_Operator_Symbol))
20334 Ename := Get_Pragma_Arg (Arg1);
20336 -- Eliminate first argument, so we can share processing
20340 Arg_Count := Arg_Count - 1;
20342 -- No Entity name argument given
20348 if Arg_Count >= 1 then
20349 Check_Optional_Identifier (Arg1, Name_Message);
20351 if Arg_Count = 2 then
20352 Check_Optional_Identifier (Arg2, Name_Version);
20356 -- Get immediately preceding declaration
20359 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20363 -- Cases where we do not follow anything other than another pragma
20367 -- First case: library level compilation unit declaration with
20368 -- the pragma immediately following the declaration.
20370 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20372 (Defining_Entity (Unit (Parent (Parent (N)))));
20375 -- Case 2: library unit placement for package
20379 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20381 if Is_Package_Or_Generic_Package (Ent) then
20382 Set_Obsolescent (Ent);
20388 -- Cases where we must follow a declaration, including an
20389 -- abstract subprogram declaration, which is not in the
20390 -- other node subtypes.
20393 if Nkind (Decl) not in N_Declaration
20394 and then Nkind (Decl) not in N_Later_Decl_Item
20395 and then Nkind (Decl) not in N_Generic_Declaration
20396 and then Nkind (Decl) not in N_Renaming_Declaration
20397 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20400 ("pragma% misplaced, "
20401 & "must immediately follow a declaration");
20404 Set_Obsolescent (Defining_Entity (Decl));
20414 -- pragma Optimize (Time | Space | Off);
20416 -- The actual check for optimize is done in Gigi. Note that this
20417 -- pragma does not actually change the optimization setting, it
20418 -- simply checks that it is consistent with the pragma.
20420 when Pragma_Optimize =>
20421 Check_No_Identifiers;
20422 Check_Arg_Count (1);
20423 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20425 ------------------------
20426 -- Optimize_Alignment --
20427 ------------------------
20429 -- pragma Optimize_Alignment (Time | Space | Off);
20431 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20433 Check_No_Identifiers;
20434 Check_Arg_Count (1);
20435 Check_Valid_Configuration_Pragma;
20438 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20441 when Name_Off => Opt.Optimize_Alignment := 'O';
20442 when Name_Space => Opt.Optimize_Alignment := 'S';
20443 when Name_Time => Opt.Optimize_Alignment := 'T';
20446 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20450 -- Set indication that mode is set locally. If we are in fact in a
20451 -- configuration pragma file, this setting is harmless since the
20452 -- switch will get reset anyway at the start of each unit.
20454 Optimize_Alignment_Local := True;
20455 end Optimize_Alignment;
20461 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20463 when Pragma_Ordered => Ordered : declare
20464 Assoc : constant Node_Id := Arg1;
20470 Check_No_Identifiers;
20471 Check_Arg_Count (1);
20472 Check_Arg_Is_Local_Name (Arg1);
20474 Type_Id := Get_Pragma_Arg (Assoc);
20475 Find_Type (Type_Id);
20476 Typ := Entity (Type_Id);
20478 if Typ = Any_Type then
20481 Typ := Underlying_Type (Typ);
20484 if not Is_Enumeration_Type (Typ) then
20485 Error_Pragma ("pragma% must specify enumeration type");
20488 Check_First_Subtype (Arg1);
20489 Set_Has_Pragma_Ordered (Base_Type (Typ));
20492 -------------------
20493 -- Overflow_Mode --
20494 -------------------
20496 -- pragma Overflow_Mode
20497 -- ([General => ] MODE [, [Assertions => ] MODE]);
20499 -- MODE := STRICT | MINIMIZED | ELIMINATED
20501 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20502 -- since System.Bignums makes this assumption. This is true of nearly
20503 -- all (all?) targets.
20505 when Pragma_Overflow_Mode => Overflow_Mode : declare
20506 function Get_Overflow_Mode
20508 Arg : Node_Id) return Overflow_Mode_Type;
20509 -- Function to process one pragma argument, Arg. If an identifier
20510 -- is present, it must be Name. Mode type is returned if a valid
20511 -- argument exists, otherwise an error is signalled.
20513 -----------------------
20514 -- Get_Overflow_Mode --
20515 -----------------------
20517 function Get_Overflow_Mode
20519 Arg : Node_Id) return Overflow_Mode_Type
20521 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20524 Check_Optional_Identifier (Arg, Name);
20525 Check_Arg_Is_Identifier (Argx);
20527 if Chars (Argx) = Name_Strict then
20530 elsif Chars (Argx) = Name_Minimized then
20533 elsif Chars (Argx) = Name_Eliminated then
20534 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20536 ("Eliminated not implemented on this target", Argx);
20542 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20544 end Get_Overflow_Mode;
20546 -- Start of processing for Overflow_Mode
20550 Check_At_Least_N_Arguments (1);
20551 Check_At_Most_N_Arguments (2);
20553 -- Process first argument
20555 Scope_Suppress.Overflow_Mode_General :=
20556 Get_Overflow_Mode (Name_General, Arg1);
20558 -- Case of only one argument
20560 if Arg_Count = 1 then
20561 Scope_Suppress.Overflow_Mode_Assertions :=
20562 Scope_Suppress.Overflow_Mode_General;
20564 -- Case of two arguments present
20567 Scope_Suppress.Overflow_Mode_Assertions :=
20568 Get_Overflow_Mode (Name_Assertions, Arg2);
20572 --------------------------
20573 -- Overriding Renamings --
20574 --------------------------
20576 -- pragma Overriding_Renamings;
20578 when Pragma_Overriding_Renamings =>
20580 Check_Arg_Count (0);
20581 Check_Valid_Configuration_Pragma;
20582 Overriding_Renamings := True;
20588 -- pragma Pack (first_subtype_LOCAL_NAME);
20590 when Pragma_Pack => Pack : declare
20591 Assoc : constant Node_Id := Arg1;
20593 Ignore : Boolean := False;
20598 Check_No_Identifiers;
20599 Check_Arg_Count (1);
20600 Check_Arg_Is_Local_Name (Arg1);
20601 Type_Id := Get_Pragma_Arg (Assoc);
20603 if not Is_Entity_Name (Type_Id)
20604 or else not Is_Type (Entity (Type_Id))
20607 ("argument for pragma% must be type or subtype", Arg1);
20610 Find_Type (Type_Id);
20611 Typ := Entity (Type_Id);
20614 or else Rep_Item_Too_Early (Typ, N)
20618 Typ := Underlying_Type (Typ);
20621 -- A pragma that applies to a Ghost entity becomes Ghost for the
20622 -- purposes of legality checks and removal of ignored Ghost code.
20624 Mark_Ghost_Pragma (N, Typ);
20626 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20627 Error_Pragma ("pragma% must specify array or record type");
20630 Check_First_Subtype (Arg1);
20631 Check_Duplicate_Pragma (Typ);
20635 if Is_Array_Type (Typ) then
20636 Ctyp := Component_Type (Typ);
20638 -- Ignore pack that does nothing
20640 if Known_Static_Esize (Ctyp)
20641 and then Known_Static_RM_Size (Ctyp)
20642 and then Esize (Ctyp) = RM_Size (Ctyp)
20643 and then Addressable (Esize (Ctyp))
20648 -- Process OK pragma Pack. Note that if there is a separate
20649 -- component clause present, the Pack will be cancelled. This
20650 -- processing is in Freeze.
20652 if not Rep_Item_Too_Late (Typ, N) then
20654 -- In CodePeer mode, we do not need complex front-end
20655 -- expansions related to pragma Pack, so disable handling
20658 if CodePeer_Mode then
20661 -- Normal case where we do the pack action
20665 Set_Is_Packed (Base_Type (Typ));
20666 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20669 Set_Has_Pragma_Pack (Base_Type (Typ));
20673 -- For record types, the pack is always effective
20675 else pragma Assert (Is_Record_Type (Typ));
20676 if not Rep_Item_Too_Late (Typ, N) then
20677 Set_Is_Packed (Base_Type (Typ));
20678 Set_Has_Pragma_Pack (Base_Type (Typ));
20679 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20690 -- There is nothing to do here, since we did all the processing for
20691 -- this pragma in Par.Prag (so that it works properly even in syntax
20694 when Pragma_Page =>
20701 -- pragma Part_Of (ABSTRACT_STATE);
20703 -- ABSTRACT_STATE ::= NAME
20705 when Pragma_Part_Of => Part_Of : declare
20706 procedure Propagate_Part_Of
20707 (Pack_Id : Entity_Id;
20708 State_Id : Entity_Id;
20709 Instance : Node_Id);
20710 -- Propagate the Part_Of indicator to all abstract states and
20711 -- objects declared in the visible state space of a package
20712 -- denoted by Pack_Id. State_Id is the encapsulating state.
20713 -- Instance is the package instantiation node.
20715 -----------------------
20716 -- Propagate_Part_Of --
20717 -----------------------
20719 procedure Propagate_Part_Of
20720 (Pack_Id : Entity_Id;
20721 State_Id : Entity_Id;
20722 Instance : Node_Id)
20724 Has_Item : Boolean := False;
20725 -- Flag set when the visible state space contains at least one
20726 -- abstract state or variable.
20728 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20729 -- Propagate the Part_Of indicator to all abstract states and
20730 -- objects declared in the visible state space of a package
20731 -- denoted by Pack_Id.
20733 -----------------------
20734 -- Propagate_Part_Of --
20735 -----------------------
20737 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20738 Constits : Elist_Id;
20739 Item_Id : Entity_Id;
20742 -- Traverse the entity chain of the package and set relevant
20743 -- attributes of abstract states and objects declared in the
20744 -- visible state space of the package.
20746 Item_Id := First_Entity (Pack_Id);
20747 while Present (Item_Id)
20748 and then not In_Private_Part (Item_Id)
20750 -- Do not consider internally generated items
20752 if not Comes_From_Source (Item_Id) then
20755 -- Do not consider generic formals or their corresponding
20756 -- actuals because they are not part of a visible state.
20757 -- Note that both entities are marked as hidden.
20759 elsif Is_Hidden (Item_Id) then
20762 -- The Part_Of indicator turns an abstract state or an
20763 -- object into a constituent of the encapsulating state.
20764 -- Note that constants are considered here even though
20765 -- they may not depend on variable input. This check is
20766 -- left to the SPARK prover.
20768 elsif Ekind_In (Item_Id, E_Abstract_State,
20773 Constits := Part_Of_Constituents (State_Id);
20775 if No (Constits) then
20776 Constits := New_Elmt_List;
20777 Set_Part_Of_Constituents (State_Id, Constits);
20780 Append_Elmt (Item_Id, Constits);
20781 Set_Encapsulating_State (Item_Id, State_Id);
20783 -- Recursively handle nested packages and instantiations
20785 elsif Ekind (Item_Id) = E_Package then
20786 Propagate_Part_Of (Item_Id);
20789 Next_Entity (Item_Id);
20791 end Propagate_Part_Of;
20793 -- Start of processing for Propagate_Part_Of
20796 Propagate_Part_Of (Pack_Id);
20798 -- Detect a package instantiation that is subject to a Part_Of
20799 -- indicator, but has no visible state.
20801 if not Has_Item then
20803 ("package instantiation & has Part_Of indicator but "
20804 & "lacks visible state", Instance, Pack_Id);
20806 end Propagate_Part_Of;
20810 Constits : Elist_Id;
20812 Encap_Id : Entity_Id;
20813 Item_Id : Entity_Id;
20817 -- Start of processing for Part_Of
20821 Check_No_Identifiers;
20822 Check_Arg_Count (1);
20824 Stmt := Find_Related_Context (N, Do_Checks => True);
20826 -- Object declaration
20828 if Nkind (Stmt) = N_Object_Declaration then
20831 -- Package instantiation
20833 elsif Nkind (Stmt) = N_Package_Instantiation then
20836 -- Single concurrent type declaration
20838 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20841 -- Otherwise the pragma is associated with an illegal construct
20848 -- Extract the entity of the related object declaration or package
20849 -- instantiation. In the case of the instantiation, use the entity
20850 -- of the instance spec.
20852 if Nkind (Stmt) = N_Package_Instantiation then
20853 Stmt := Instance_Spec (Stmt);
20856 Item_Id := Defining_Entity (Stmt);
20858 -- A pragma that applies to a Ghost entity becomes Ghost for the
20859 -- purposes of legality checks and removal of ignored Ghost code.
20861 Mark_Ghost_Pragma (N, Item_Id);
20863 -- Chain the pragma on the contract for further processing by
20864 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20866 Add_Contract_Item (N, Item_Id);
20868 -- A variable may act as constituent of a single concurrent type
20869 -- which in turn could be declared after the variable. Due to this
20870 -- discrepancy, the full analysis of indicator Part_Of is delayed
20871 -- until the end of the enclosing declarative region (see routine
20872 -- Analyze_Part_Of_In_Decl_Part).
20874 if Ekind (Item_Id) = E_Variable then
20877 -- Otherwise indicator Part_Of applies to a constant or a package
20881 Encap := Get_Pragma_Arg (Arg1);
20883 -- Detect any discrepancies between the placement of the
20884 -- constant or package instantiation with respect to state
20885 -- space and the encapsulating state.
20889 Item_Id => Item_Id,
20891 Encap_Id => Encap_Id,
20895 pragma Assert (Present (Encap_Id));
20897 if Ekind (Item_Id) = E_Constant then
20898 Constits := Part_Of_Constituents (Encap_Id);
20900 if No (Constits) then
20901 Constits := New_Elmt_List;
20902 Set_Part_Of_Constituents (Encap_Id, Constits);
20905 Append_Elmt (Item_Id, Constits);
20906 Set_Encapsulating_State (Item_Id, Encap_Id);
20908 -- Propagate the Part_Of indicator to the visible state
20909 -- space of the package instantiation.
20913 (Pack_Id => Item_Id,
20914 State_Id => Encap_Id,
20921 ----------------------------------
20922 -- Partition_Elaboration_Policy --
20923 ----------------------------------
20925 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20927 when Pragma_Partition_Elaboration_Policy => PEP : declare
20928 subtype PEP_Range is Name_Id
20929 range First_Partition_Elaboration_Policy_Name
20930 .. Last_Partition_Elaboration_Policy_Name;
20931 PEP_Val : PEP_Range;
20936 Check_Arg_Count (1);
20937 Check_No_Identifiers;
20938 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20939 Check_Valid_Configuration_Pragma;
20940 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20943 when Name_Concurrent => PEP := 'C';
20944 when Name_Sequential => PEP := 'S';
20947 if Partition_Elaboration_Policy /= ' '
20948 and then Partition_Elaboration_Policy /= PEP
20950 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20952 ("partition elaboration policy incompatible with policy#");
20954 -- Set new policy, but always preserve System_Location since we
20955 -- like the error message with the run time name.
20958 Partition_Elaboration_Policy := PEP;
20960 if Partition_Elaboration_Policy_Sloc /= System_Location then
20961 Partition_Elaboration_Policy_Sloc := Loc;
20970 -- pragma Passive [(PASSIVE_FORM)];
20972 -- PASSIVE_FORM ::= Semaphore | No
20974 when Pragma_Passive =>
20977 if Nkind (Parent (N)) /= N_Task_Definition then
20978 Error_Pragma ("pragma% must be within task definition");
20981 if Arg_Count /= 0 then
20982 Check_Arg_Count (1);
20983 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20986 ----------------------------------
20987 -- Preelaborable_Initialization --
20988 ----------------------------------
20990 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20992 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20997 Check_Arg_Count (1);
20998 Check_No_Identifiers;
20999 Check_Arg_Is_Identifier (Arg1);
21000 Check_Arg_Is_Local_Name (Arg1);
21001 Check_First_Subtype (Arg1);
21002 Ent := Entity (Get_Pragma_Arg (Arg1));
21004 -- A pragma that applies to a Ghost entity becomes Ghost for the
21005 -- purposes of legality checks and removal of ignored Ghost code.
21007 Mark_Ghost_Pragma (N, Ent);
21009 -- The pragma may come from an aspect on a private declaration,
21010 -- even if the freeze point at which this is analyzed in the
21011 -- private part after the full view.
21013 if Has_Private_Declaration (Ent)
21014 and then From_Aspect_Specification (N)
21018 -- Check appropriate type argument
21020 elsif Is_Private_Type (Ent)
21021 or else Is_Protected_Type (Ent)
21022 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
21024 -- AI05-0028: The pragma applies to all composite types. Note
21025 -- that we apply this binding interpretation to earlier versions
21026 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21027 -- choice since there are other compilers that do the same.
21029 or else Is_Composite_Type (Ent)
21035 ("pragma % can only be applied to private, formal derived, "
21036 & "protected, or composite type", Arg1);
21039 -- Give an error if the pragma is applied to a protected type that
21040 -- does not qualify (due to having entries, or due to components
21041 -- that do not qualify).
21043 if Is_Protected_Type (Ent)
21044 and then not Has_Preelaborable_Initialization (Ent)
21047 ("protected type & does not have preelaborable "
21048 & "initialization", Ent);
21050 -- Otherwise mark the type as definitely having preelaborable
21054 Set_Known_To_Have_Preelab_Init (Ent);
21057 if Has_Pragma_Preelab_Init (Ent)
21058 and then Warn_On_Redundant_Constructs
21060 Error_Pragma ("?r?duplicate pragma%!");
21062 Set_Has_Pragma_Preelab_Init (Ent);
21066 --------------------
21067 -- Persistent_BSS --
21068 --------------------
21070 -- pragma Persistent_BSS [(object_NAME)];
21072 when Pragma_Persistent_BSS => Persistent_BSS : declare
21079 Check_At_Most_N_Arguments (1);
21081 -- Case of application to specific object (one argument)
21083 if Arg_Count = 1 then
21084 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21086 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
21088 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
21091 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
21094 Ent := Entity (Get_Pragma_Arg (Arg1));
21096 -- A pragma that applies to a Ghost entity becomes Ghost for
21097 -- the purposes of legality checks and removal of ignored Ghost
21100 Mark_Ghost_Pragma (N, Ent);
21102 -- Check for duplication before inserting in list of
21103 -- representation items.
21105 Check_Duplicate_Pragma (Ent);
21107 if Rep_Item_Too_Late (Ent, N) then
21111 Decl := Parent (Ent);
21113 if Present (Expression (Decl)) then
21115 ("object for pragma% cannot have initialization", Arg1);
21118 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
21120 ("object type for pragma% is not potentially persistent",
21125 Make_Linker_Section_Pragma
21126 (Ent, Sloc (N), ".persistent.bss");
21127 Insert_After (N, Prag);
21130 -- Case of use as configuration pragma with no arguments
21133 Check_Valid_Configuration_Pragma;
21134 Persistent_BSS_Mode := True;
21136 end Persistent_BSS;
21138 --------------------
21139 -- Rename_Pragma --
21140 --------------------
21142 -- pragma Rename_Pragma (
21143 -- [New_Name =>] IDENTIFIER,
21144 -- [Renamed =>] pragma_IDENTIFIER);
21146 when Pragma_Rename_Pragma => Rename_Pragma : declare
21147 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21148 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21152 Check_Valid_Configuration_Pragma;
21153 Check_Arg_Count (2);
21154 Check_Optional_Identifier (Arg1, Name_New_Name);
21155 Check_Optional_Identifier (Arg2, Name_Renamed);
21157 if Nkind (New_Name) /= N_Identifier then
21158 Error_Pragma_Arg ("identifier expected", Arg1);
21161 if Nkind (Old_Name) /= N_Identifier then
21162 Error_Pragma_Arg ("identifier expected", Arg2);
21165 -- The New_Name arg should not be an existing pragma (but we allow
21166 -- it; it's just a warning). The Old_Name arg must be an existing
21169 if Is_Pragma_Name (Chars (New_Name)) then
21170 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21173 if not Is_Pragma_Name (Chars (Old_Name)) then
21174 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21177 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21184 -- pragma Polling (ON | OFF);
21186 when Pragma_Polling =>
21188 Check_Arg_Count (1);
21189 Check_No_Identifiers;
21190 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21191 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
21193 -----------------------------------
21194 -- Post/Post_Class/Postcondition --
21195 -----------------------------------
21197 -- pragma Post (Boolean_EXPRESSION);
21198 -- pragma Post_Class (Boolean_EXPRESSION);
21199 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21200 -- [,[Message =>] String_EXPRESSION]);
21202 -- Characteristics:
21204 -- * Analysis - The annotation undergoes initial checks to verify
21205 -- the legal placement and context. Secondary checks preanalyze the
21208 -- Analyze_Pre_Post_Condition_In_Decl_Part
21210 -- * Expansion - The annotation is expanded during the expansion of
21211 -- the related subprogram [body] contract as performed in:
21213 -- Expand_Subprogram_Contract
21215 -- * Template - The annotation utilizes the generic template of the
21216 -- related subprogram [body] when it is:
21218 -- aspect on subprogram declaration
21219 -- aspect on stand-alone subprogram body
21220 -- pragma on stand-alone subprogram body
21222 -- The annotation must prepare its own template when it is:
21224 -- pragma on subprogram declaration
21226 -- * Globals - Capture of global references must occur after full
21229 -- * Instance - The annotation is instantiated automatically when
21230 -- the related generic subprogram [body] is instantiated except for
21231 -- the "pragma on subprogram declaration" case. In that scenario
21232 -- the annotation must instantiate itself.
21235 | Pragma_Post_Class
21236 | Pragma_Postcondition
21238 Analyze_Pre_Post_Condition;
21240 --------------------------------
21241 -- Pre/Pre_Class/Precondition --
21242 --------------------------------
21244 -- pragma Pre (Boolean_EXPRESSION);
21245 -- pragma Pre_Class (Boolean_EXPRESSION);
21246 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21247 -- [,[Message =>] String_EXPRESSION]);
21249 -- Characteristics:
21251 -- * Analysis - The annotation undergoes initial checks to verify
21252 -- the legal placement and context. Secondary checks preanalyze the
21255 -- Analyze_Pre_Post_Condition_In_Decl_Part
21257 -- * Expansion - The annotation is expanded during the expansion of
21258 -- the related subprogram [body] contract as performed in:
21260 -- Expand_Subprogram_Contract
21262 -- * Template - The annotation utilizes the generic template of the
21263 -- related subprogram [body] when it is:
21265 -- aspect on subprogram declaration
21266 -- aspect on stand-alone subprogram body
21267 -- pragma on stand-alone subprogram body
21269 -- The annotation must prepare its own template when it is:
21271 -- pragma on subprogram declaration
21273 -- * Globals - Capture of global references must occur after full
21276 -- * Instance - The annotation is instantiated automatically when
21277 -- the related generic subprogram [body] is instantiated except for
21278 -- the "pragma on subprogram declaration" case. In that scenario
21279 -- the annotation must instantiate itself.
21283 | Pragma_Precondition
21285 Analyze_Pre_Post_Condition;
21291 -- pragma Predicate
21292 -- ([Entity =>] type_LOCAL_NAME,
21293 -- [Check =>] boolean_EXPRESSION);
21295 when Pragma_Predicate => Predicate : declare
21302 Check_Arg_Count (2);
21303 Check_Optional_Identifier (Arg1, Name_Entity);
21304 Check_Optional_Identifier (Arg2, Name_Check);
21306 Check_Arg_Is_Local_Name (Arg1);
21308 Type_Id := Get_Pragma_Arg (Arg1);
21309 Find_Type (Type_Id);
21310 Typ := Entity (Type_Id);
21312 if Typ = Any_Type then
21316 -- A pragma that applies to a Ghost entity becomes Ghost for the
21317 -- purposes of legality checks and removal of ignored Ghost code.
21319 Mark_Ghost_Pragma (N, Typ);
21321 -- The remaining processing is simply to link the pragma on to
21322 -- the rep item chain, for processing when the type is frozen.
21323 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21324 -- mark the type as having predicates.
21326 -- If the current policy for predicate checking is Ignore mark the
21327 -- subtype accordingly. In the case of predicates we consider them
21328 -- enabled unless Ignore is specified (either directly or with a
21329 -- general Assertion_Policy pragma) to preserve existing warnings.
21331 Set_Has_Predicates (Typ);
21333 -- Indicate that the pragma must be processed at the point the
21334 -- type is frozen, as is done for the corresponding aspect.
21336 Set_Has_Delayed_Aspects (Typ);
21337 Set_Has_Delayed_Freeze (Typ);
21339 Set_Predicates_Ignored (Typ,
21340 Present (Check_Policy_List)
21342 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21343 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21346 -----------------------
21347 -- Predicate_Failure --
21348 -----------------------
21350 -- pragma Predicate_Failure
21351 -- ([Entity =>] type_LOCAL_NAME,
21352 -- [Message =>] string_EXPRESSION);
21354 when Pragma_Predicate_Failure => Predicate_Failure : declare
21361 Check_Arg_Count (2);
21362 Check_Optional_Identifier (Arg1, Name_Entity);
21363 Check_Optional_Identifier (Arg2, Name_Message);
21365 Check_Arg_Is_Local_Name (Arg1);
21367 Type_Id := Get_Pragma_Arg (Arg1);
21368 Find_Type (Type_Id);
21369 Typ := Entity (Type_Id);
21371 if Typ = Any_Type then
21375 -- A pragma that applies to a Ghost entity becomes Ghost for the
21376 -- purposes of legality checks and removal of ignored Ghost code.
21378 Mark_Ghost_Pragma (N, Typ);
21380 -- The remaining processing is simply to link the pragma on to
21381 -- the rep item chain, for processing when the type is frozen.
21382 -- This is accomplished by a call to Rep_Item_Too_Late.
21384 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21385 end Predicate_Failure;
21391 -- pragma Preelaborate [(library_unit_NAME)];
21393 -- Set the flag Is_Preelaborated of program unit name entity
21395 when Pragma_Preelaborate => Preelaborate : declare
21396 Pa : constant Node_Id := Parent (N);
21397 Pk : constant Node_Kind := Nkind (Pa);
21401 Check_Ada_83_Warning;
21402 Check_Valid_Library_Unit_Pragma;
21404 if Nkind (N) = N_Null_Statement then
21408 Ent := Find_Lib_Unit_Name;
21410 -- A pragma that applies to a Ghost entity becomes Ghost for the
21411 -- purposes of legality checks and removal of ignored Ghost code.
21413 Mark_Ghost_Pragma (N, Ent);
21414 Check_Duplicate_Pragma (Ent);
21416 -- This filters out pragmas inside generic parents that show up
21417 -- inside instantiations. Pragmas that come from aspects in the
21418 -- unit are not ignored.
21420 if Present (Ent) then
21421 if Pk = N_Package_Specification
21422 and then Present (Generic_Parent (Pa))
21423 and then not From_Aspect_Specification (N)
21428 if not Debug_Flag_U then
21429 Set_Is_Preelaborated (Ent);
21431 if Legacy_Elaboration_Checks then
21432 Set_Suppress_Elaboration_Warnings (Ent);
21439 -------------------------------
21440 -- Prefix_Exception_Messages --
21441 -------------------------------
21443 -- pragma Prefix_Exception_Messages;
21445 when Pragma_Prefix_Exception_Messages =>
21447 Check_Valid_Configuration_Pragma;
21448 Check_Arg_Count (0);
21449 Prefix_Exception_Messages := True;
21455 -- pragma Priority (EXPRESSION);
21457 when Pragma_Priority => Priority : declare
21458 P : constant Node_Id := Parent (N);
21463 Check_No_Identifiers;
21464 Check_Arg_Count (1);
21468 if Nkind (P) = N_Subprogram_Body then
21469 Check_In_Main_Program;
21471 Ent := Defining_Unit_Name (Specification (P));
21473 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21474 Ent := Defining_Identifier (Ent);
21477 Arg := Get_Pragma_Arg (Arg1);
21478 Analyze_And_Resolve (Arg, Standard_Integer);
21482 if not Is_OK_Static_Expression (Arg) then
21483 Flag_Non_Static_Expr
21484 ("main subprogram priority is not static!", Arg);
21487 -- If constraint error, then we already signalled an error
21489 elsif Raises_Constraint_Error (Arg) then
21492 -- Otherwise check in range except if Relaxed_RM_Semantics
21493 -- where we ignore the value if out of range.
21496 if not Relaxed_RM_Semantics
21497 and then not Is_In_Range (Arg, RTE (RE_Priority))
21500 ("main subprogram priority is out of range", Arg1);
21503 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21507 -- Load an arbitrary entity from System.Tasking.Stages or
21508 -- System.Tasking.Restricted.Stages (depending on the
21509 -- supported profile) to make sure that one of these packages
21510 -- is implicitly with'ed, since we need to have the tasking
21511 -- run time active for the pragma Priority to have any effect.
21512 -- Previously we with'ed the package System.Tasking, but this
21513 -- package does not trigger the required initialization of the
21514 -- run-time library.
21517 Discard : Entity_Id;
21518 pragma Warnings (Off, Discard);
21520 if Restricted_Profile then
21521 Discard := RTE (RE_Activate_Restricted_Tasks);
21523 Discard := RTE (RE_Activate_Tasks);
21527 -- Task or Protected, must be of type Integer
21529 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
21530 Arg := Get_Pragma_Arg (Arg1);
21531 Ent := Defining_Identifier (Parent (P));
21533 -- The expression must be analyzed in the special manner
21534 -- described in "Handling of Default and Per-Object
21535 -- Expressions" in sem.ads.
21537 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21539 if not Is_OK_Static_Expression (Arg) then
21540 Check_Restriction (Static_Priorities, Arg);
21543 -- Anything else is incorrect
21549 -- Check duplicate pragma before we chain the pragma in the Rep
21550 -- Item chain of Ent.
21552 Check_Duplicate_Pragma (Ent);
21553 Record_Rep_Item (Ent, N);
21556 -----------------------------------
21557 -- Priority_Specific_Dispatching --
21558 -----------------------------------
21560 -- pragma Priority_Specific_Dispatching (
21561 -- policy_IDENTIFIER,
21562 -- first_priority_EXPRESSION,
21563 -- last_priority_EXPRESSION);
21565 when Pragma_Priority_Specific_Dispatching =>
21566 Priority_Specific_Dispatching : declare
21567 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21568 -- This is the entity System.Any_Priority;
21571 Lower_Bound : Node_Id;
21572 Upper_Bound : Node_Id;
21578 Check_Arg_Count (3);
21579 Check_No_Identifiers;
21580 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21581 Check_Valid_Configuration_Pragma;
21582 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21583 DP := Fold_Upper (Name_Buffer (1));
21585 Lower_Bound := Get_Pragma_Arg (Arg2);
21586 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21587 Lower_Val := Expr_Value (Lower_Bound);
21589 Upper_Bound := Get_Pragma_Arg (Arg3);
21590 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21591 Upper_Val := Expr_Value (Upper_Bound);
21593 -- It is not allowed to use Task_Dispatching_Policy and
21594 -- Priority_Specific_Dispatching in the same partition.
21596 if Task_Dispatching_Policy /= ' ' then
21597 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21599 ("pragma% incompatible with Task_Dispatching_Policy#");
21601 -- Check lower bound in range
21603 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21605 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21608 ("first_priority is out of range", Arg2);
21610 -- Check upper bound in range
21612 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21614 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21617 ("last_priority is out of range", Arg3);
21619 -- Check that the priority range is valid
21621 elsif Lower_Val > Upper_Val then
21623 ("last_priority_expression must be greater than or equal to "
21624 & "first_priority_expression");
21626 -- Store the new policy, but always preserve System_Location since
21627 -- we like the error message with the run-time name.
21630 -- Check overlapping in the priority ranges specified in other
21631 -- Priority_Specific_Dispatching pragmas within the same
21632 -- partition. We can only check those we know about.
21635 Specific_Dispatching.First .. Specific_Dispatching.Last
21637 if Specific_Dispatching.Table (J).First_Priority in
21638 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21639 or else Specific_Dispatching.Table (J).Last_Priority in
21640 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21643 Specific_Dispatching.Table (J).Pragma_Loc;
21645 ("priority range overlaps with "
21646 & "Priority_Specific_Dispatching#");
21650 -- The use of Priority_Specific_Dispatching is incompatible
21651 -- with Task_Dispatching_Policy.
21653 if Task_Dispatching_Policy /= ' ' then
21654 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21656 ("Priority_Specific_Dispatching incompatible "
21657 & "with Task_Dispatching_Policy#");
21660 -- The use of Priority_Specific_Dispatching forces ceiling
21663 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21664 Error_Msg_Sloc := Locking_Policy_Sloc;
21666 ("Priority_Specific_Dispatching incompatible "
21667 & "with Locking_Policy#");
21669 -- Set the Ceiling_Locking policy, but preserve System_Location
21670 -- since we like the error message with the run time name.
21673 Locking_Policy := 'C';
21675 if Locking_Policy_Sloc /= System_Location then
21676 Locking_Policy_Sloc := Loc;
21680 -- Add entry in the table
21682 Specific_Dispatching.Append
21683 ((Dispatching_Policy => DP,
21684 First_Priority => UI_To_Int (Lower_Val),
21685 Last_Priority => UI_To_Int (Upper_Val),
21686 Pragma_Loc => Loc));
21688 end Priority_Specific_Dispatching;
21694 -- pragma Profile (profile_IDENTIFIER);
21696 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21698 when Pragma_Profile =>
21700 Check_Arg_Count (1);
21701 Check_Valid_Configuration_Pragma;
21702 Check_No_Identifiers;
21705 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21708 if Chars (Argx) = Name_Ravenscar then
21709 Set_Ravenscar_Profile (Ravenscar, N);
21711 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21712 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21714 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21715 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21717 elsif Chars (Argx) = Name_Restricted then
21718 Set_Profile_Restrictions
21720 N, Warn => Treat_Restrictions_As_Warnings);
21722 elsif Chars (Argx) = Name_Rational then
21723 Set_Rational_Profile;
21725 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21726 Set_Profile_Restrictions
21727 (No_Implementation_Extensions,
21728 N, Warn => Treat_Restrictions_As_Warnings);
21731 Error_Pragma_Arg ("& is not a valid profile", Argx);
21735 ----------------------
21736 -- Profile_Warnings --
21737 ----------------------
21739 -- pragma Profile_Warnings (profile_IDENTIFIER);
21741 -- profile_IDENTIFIER => Restricted | Ravenscar
21743 when Pragma_Profile_Warnings =>
21745 Check_Arg_Count (1);
21746 Check_Valid_Configuration_Pragma;
21747 Check_No_Identifiers;
21750 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21753 if Chars (Argx) = Name_Ravenscar then
21754 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21756 elsif Chars (Argx) = Name_Restricted then
21757 Set_Profile_Restrictions (Restricted, N, Warn => True);
21759 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21760 Set_Profile_Restrictions
21761 (No_Implementation_Extensions, N, Warn => True);
21764 Error_Pragma_Arg ("& is not a valid profile", Argx);
21768 --------------------------
21769 -- Propagate_Exceptions --
21770 --------------------------
21772 -- pragma Propagate_Exceptions;
21774 -- Note: this pragma is obsolete and has no effect
21776 when Pragma_Propagate_Exceptions =>
21778 Check_Arg_Count (0);
21780 if Warn_On_Obsolescent_Feature then
21782 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21783 "and has no effect?j?", N);
21786 -----------------------------
21787 -- Provide_Shift_Operators --
21788 -----------------------------
21790 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21792 when Pragma_Provide_Shift_Operators =>
21793 Provide_Shift_Operators : declare
21796 procedure Declare_Shift_Operator (Nam : Name_Id);
21797 -- Insert declaration and pragma Instrinsic for named shift op
21799 ----------------------------
21800 -- Declare_Shift_Operator --
21801 ----------------------------
21803 procedure Declare_Shift_Operator (Nam : Name_Id) is
21809 Make_Subprogram_Declaration (Loc,
21810 Make_Function_Specification (Loc,
21811 Defining_Unit_Name =>
21812 Make_Defining_Identifier (Loc, Chars => Nam),
21814 Result_Definition =>
21815 Make_Identifier (Loc, Chars => Chars (Ent)),
21817 Parameter_Specifications => New_List (
21818 Make_Parameter_Specification (Loc,
21819 Defining_Identifier =>
21820 Make_Defining_Identifier (Loc, Name_Value),
21822 Make_Identifier (Loc, Chars => Chars (Ent))),
21824 Make_Parameter_Specification (Loc,
21825 Defining_Identifier =>
21826 Make_Defining_Identifier (Loc, Name_Amount),
21828 New_Occurrence_Of (Standard_Natural, Loc)))));
21832 Chars => Name_Import,
21833 Pragma_Argument_Associations => New_List (
21834 Make_Pragma_Argument_Association (Loc,
21835 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21836 Make_Pragma_Argument_Association (Loc,
21837 Expression => Make_Identifier (Loc, Nam))));
21839 Insert_After (N, Import);
21840 Insert_After (N, Func);
21841 end Declare_Shift_Operator;
21843 -- Start of processing for Provide_Shift_Operators
21847 Check_Arg_Count (1);
21848 Check_Arg_Is_Local_Name (Arg1);
21850 Arg1 := Get_Pragma_Arg (Arg1);
21852 -- We must have an entity name
21854 if not Is_Entity_Name (Arg1) then
21856 ("pragma % must apply to integer first subtype", Arg1);
21859 -- If no Entity, means there was a prior error so ignore
21861 if Present (Entity (Arg1)) then
21862 Ent := Entity (Arg1);
21864 -- Apply error checks
21866 if not Is_First_Subtype (Ent) then
21868 ("cannot apply pragma %",
21869 "\& is not a first subtype",
21872 elsif not Is_Integer_Type (Ent) then
21874 ("cannot apply pragma %",
21875 "\& is not an integer type",
21878 elsif Has_Shift_Operator (Ent) then
21880 ("cannot apply pragma %",
21881 "\& already has declared shift operators",
21884 elsif Is_Frozen (Ent) then
21886 ("pragma % appears too late",
21887 "\& is already frozen",
21891 -- Now declare the operators. We do this during analysis rather
21892 -- than expansion, since we want the operators available if we
21893 -- are operating in -gnatc or ASIS mode.
21895 Declare_Shift_Operator (Name_Rotate_Left);
21896 Declare_Shift_Operator (Name_Rotate_Right);
21897 Declare_Shift_Operator (Name_Shift_Left);
21898 Declare_Shift_Operator (Name_Shift_Right);
21899 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21901 end Provide_Shift_Operators;
21907 -- pragma Psect_Object (
21908 -- [Internal =>] LOCAL_NAME,
21909 -- [, [External =>] EXTERNAL_SYMBOL]
21910 -- [, [Size =>] EXTERNAL_SYMBOL]);
21912 when Pragma_Common_Object
21913 | Pragma_Psect_Object
21915 Psect_Object : declare
21916 Args : Args_List (1 .. 3);
21917 Names : constant Name_List (1 .. 3) := (
21922 Internal : Node_Id renames Args (1);
21923 External : Node_Id renames Args (2);
21924 Size : Node_Id renames Args (3);
21926 Def_Id : Entity_Id;
21928 procedure Check_Arg (Arg : Node_Id);
21929 -- Checks that argument is either a string literal or an
21930 -- identifier, and posts error message if not.
21936 procedure Check_Arg (Arg : Node_Id) is
21938 if not Nkind_In (Original_Node (Arg),
21943 ("inappropriate argument for pragma %", Arg);
21947 -- Start of processing for Common_Object/Psect_Object
21951 Gather_Associations (Names, Args);
21952 Process_Extended_Import_Export_Internal_Arg (Internal);
21954 Def_Id := Entity (Internal);
21956 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
21958 ("pragma% must designate an object", Internal);
21961 Check_Arg (Internal);
21963 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21965 ("cannot use pragma% for imported/exported object",
21969 if Is_Concurrent_Type (Etype (Internal)) then
21971 ("cannot specify pragma % for task/protected object",
21975 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21977 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21979 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21982 if Ekind (Def_Id) = E_Constant then
21984 ("cannot specify pragma % for a constant", Internal);
21987 if Is_Record_Type (Etype (Internal)) then
21993 Ent := First_Entity (Etype (Internal));
21994 while Present (Ent) loop
21995 Decl := Declaration_Node (Ent);
21997 if Ekind (Ent) = E_Component
21998 and then Nkind (Decl) = N_Component_Declaration
21999 and then Present (Expression (Decl))
22000 and then Warn_On_Export_Import
22003 ("?x?object for pragma % has defaults", Internal);
22013 if Present (Size) then
22017 if Present (External) then
22018 Check_Arg_Is_External_Name (External);
22021 -- If all error tests pass, link pragma on to the rep item chain
22023 Record_Rep_Item (Def_Id, N);
22030 -- pragma Pure [(library_unit_NAME)];
22032 when Pragma_Pure => Pure : declare
22036 Check_Ada_83_Warning;
22038 -- If the pragma comes from a subprogram instantiation, nothing to
22039 -- check, this can happen at any level of nesting.
22041 if Is_Wrapper_Package (Current_Scope) then
22044 Check_Valid_Library_Unit_Pragma;
22047 if Nkind (N) = N_Null_Statement then
22051 Ent := Find_Lib_Unit_Name;
22053 -- A pragma that applies to a Ghost entity becomes Ghost for the
22054 -- purposes of legality checks and removal of ignored Ghost code.
22056 Mark_Ghost_Pragma (N, Ent);
22058 if not Debug_Flag_U then
22060 Set_Has_Pragma_Pure (Ent);
22062 if Legacy_Elaboration_Checks then
22063 Set_Suppress_Elaboration_Warnings (Ent);
22068 -------------------
22069 -- Pure_Function --
22070 -------------------
22072 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22074 when Pragma_Pure_Function => Pure_Function : declare
22075 Def_Id : Entity_Id;
22078 Effective : Boolean := False;
22079 Orig_Def : Entity_Id;
22080 Same_Decl : Boolean := False;
22084 Check_Arg_Count (1);
22085 Check_Optional_Identifier (Arg1, Name_Entity);
22086 Check_Arg_Is_Local_Name (Arg1);
22087 E_Id := Get_Pragma_Arg (Arg1);
22089 if Etype (E_Id) = Any_Type then
22093 -- Loop through homonyms (overloadings) of referenced entity
22095 E := Entity (E_Id);
22097 -- A pragma that applies to a Ghost entity becomes Ghost for the
22098 -- purposes of legality checks and removal of ignored Ghost code.
22100 Mark_Ghost_Pragma (N, E);
22102 if Present (E) then
22104 Def_Id := Get_Base_Subprogram (E);
22106 if not Ekind_In (Def_Id, E_Function,
22107 E_Generic_Function,
22111 ("pragma% requires a function name", Arg1);
22114 -- When we have a generic function we must jump up a level
22115 -- to the declaration of the wrapper package itself.
22117 Orig_Def := Def_Id;
22119 if Is_Generic_Instance (Def_Id) then
22120 while Nkind (Orig_Def) /= N_Package_Declaration loop
22121 Orig_Def := Parent (Orig_Def);
22125 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
22127 Set_Is_Pure (Def_Id);
22129 if not Has_Pragma_Pure_Function (Def_Id) then
22130 Set_Has_Pragma_Pure_Function (Def_Id);
22135 exit when From_Aspect_Specification (N);
22137 exit when No (E) or else Scope (E) /= Current_Scope;
22141 and then Warn_On_Redundant_Constructs
22144 ("pragma Pure_Function on& is redundant?r?",
22147 elsif not Same_Decl then
22149 ("pragma% argument must be in same declarative part",
22155 --------------------
22156 -- Queuing_Policy --
22157 --------------------
22159 -- pragma Queuing_Policy (policy_IDENTIFIER);
22161 when Pragma_Queuing_Policy => declare
22165 Check_Ada_83_Warning;
22166 Check_Arg_Count (1);
22167 Check_No_Identifiers;
22168 Check_Arg_Is_Queuing_Policy (Arg1);
22169 Check_Valid_Configuration_Pragma;
22170 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22171 QP := Fold_Upper (Name_Buffer (1));
22173 if Queuing_Policy /= ' '
22174 and then Queuing_Policy /= QP
22176 Error_Msg_Sloc := Queuing_Policy_Sloc;
22177 Error_Pragma ("queuing policy incompatible with policy#");
22179 -- Set new policy, but always preserve System_Location since we
22180 -- like the error message with the run time name.
22183 Queuing_Policy := QP;
22185 if Queuing_Policy_Sloc /= System_Location then
22186 Queuing_Policy_Sloc := Loc;
22195 -- pragma Rational, for compatibility with foreign compiler
22197 when Pragma_Rational =>
22198 Set_Rational_Profile;
22200 ---------------------
22201 -- Refined_Depends --
22202 ---------------------
22204 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22206 -- DEPENDENCY_RELATION ::=
22208 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22210 -- DEPENDENCY_CLAUSE ::=
22211 -- OUTPUT_LIST =>[+] INPUT_LIST
22212 -- | NULL_DEPENDENCY_CLAUSE
22214 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22216 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22218 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22220 -- OUTPUT ::= NAME | FUNCTION_RESULT
22223 -- where FUNCTION_RESULT is a function Result attribute_reference
22225 -- Characteristics:
22227 -- * Analysis - The annotation undergoes initial checks to verify
22228 -- the legal placement and context. Secondary checks fully analyze
22229 -- the dependency clauses/global list in:
22231 -- Analyze_Refined_Depends_In_Decl_Part
22233 -- * Expansion - None.
22235 -- * Template - The annotation utilizes the generic template of the
22236 -- related subprogram body.
22238 -- * Globals - Capture of global references must occur after full
22241 -- * Instance - The annotation is instantiated automatically when
22242 -- the related generic subprogram body is instantiated.
22244 when Pragma_Refined_Depends => Refined_Depends : declare
22245 Body_Id : Entity_Id;
22247 Spec_Id : Entity_Id;
22250 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22254 -- Chain the pragma on the contract for further processing by
22255 -- Analyze_Refined_Depends_In_Decl_Part.
22257 Add_Contract_Item (N, Body_Id);
22259 -- The legality checks of pragmas Refined_Depends and
22260 -- Refined_Global are affected by the SPARK mode in effect and
22261 -- the volatility of the context. In addition these two pragmas
22262 -- are subject to an inherent order:
22264 -- 1) Refined_Global
22265 -- 2) Refined_Depends
22267 -- Analyze all these pragmas in the order outlined above
22269 Analyze_If_Present (Pragma_SPARK_Mode);
22270 Analyze_If_Present (Pragma_Volatile_Function);
22271 Analyze_If_Present (Pragma_Refined_Global);
22272 Analyze_Refined_Depends_In_Decl_Part (N);
22274 end Refined_Depends;
22276 --------------------
22277 -- Refined_Global --
22278 --------------------
22280 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22282 -- GLOBAL_SPECIFICATION ::=
22285 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22287 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22289 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22290 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22291 -- GLOBAL_ITEM ::= NAME
22293 -- Characteristics:
22295 -- * Analysis - The annotation undergoes initial checks to verify
22296 -- the legal placement and context. Secondary checks fully analyze
22297 -- the dependency clauses/global list in:
22299 -- Analyze_Refined_Global_In_Decl_Part
22301 -- * Expansion - None.
22303 -- * Template - The annotation utilizes the generic template of the
22304 -- related subprogram body.
22306 -- * Globals - Capture of global references must occur after full
22309 -- * Instance - The annotation is instantiated automatically when
22310 -- the related generic subprogram body is instantiated.
22312 when Pragma_Refined_Global => Refined_Global : declare
22313 Body_Id : Entity_Id;
22315 Spec_Id : Entity_Id;
22318 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22322 -- Chain the pragma on the contract for further processing by
22323 -- Analyze_Refined_Global_In_Decl_Part.
22325 Add_Contract_Item (N, Body_Id);
22327 -- The legality checks of pragmas Refined_Depends and
22328 -- Refined_Global are affected by the SPARK mode in effect and
22329 -- the volatility of the context. In addition these two pragmas
22330 -- are subject to an inherent order:
22332 -- 1) Refined_Global
22333 -- 2) Refined_Depends
22335 -- Analyze all these pragmas in the order outlined above
22337 Analyze_If_Present (Pragma_SPARK_Mode);
22338 Analyze_If_Present (Pragma_Volatile_Function);
22339 Analyze_Refined_Global_In_Decl_Part (N);
22340 Analyze_If_Present (Pragma_Refined_Depends);
22342 end Refined_Global;
22348 -- pragma Refined_Post (boolean_EXPRESSION);
22350 -- Characteristics:
22352 -- * Analysis - The annotation is fully analyzed immediately upon
22353 -- elaboration as it cannot forward reference entities.
22355 -- * Expansion - The annotation is expanded during the expansion of
22356 -- the related subprogram body contract as performed in:
22358 -- Expand_Subprogram_Contract
22360 -- * Template - The annotation utilizes the generic template of the
22361 -- related subprogram body.
22363 -- * Globals - Capture of global references must occur after full
22366 -- * Instance - The annotation is instantiated automatically when
22367 -- the related generic subprogram body is instantiated.
22369 when Pragma_Refined_Post => Refined_Post : declare
22370 Body_Id : Entity_Id;
22372 Spec_Id : Entity_Id;
22375 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22377 -- Fully analyze the pragma when it appears inside a subprogram
22378 -- body because it cannot benefit from forward references.
22382 -- Chain the pragma on the contract for completeness
22384 Add_Contract_Item (N, Body_Id);
22386 -- The legality checks of pragma Refined_Post are affected by
22387 -- the SPARK mode in effect and the volatility of the context.
22388 -- Analyze all pragmas in a specific order.
22390 Analyze_If_Present (Pragma_SPARK_Mode);
22391 Analyze_If_Present (Pragma_Volatile_Function);
22392 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22394 -- Currently it is not possible to inline pre/postconditions on
22395 -- a subprogram subject to pragma Inline_Always.
22397 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22401 -------------------
22402 -- Refined_State --
22403 -------------------
22405 -- pragma Refined_State (REFINEMENT_LIST);
22407 -- REFINEMENT_LIST ::=
22408 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22410 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22412 -- CONSTITUENT_LIST ::=
22415 -- | (CONSTITUENT {, CONSTITUENT})
22417 -- CONSTITUENT ::= object_NAME | state_NAME
22419 -- Characteristics:
22421 -- * Analysis - The annotation undergoes initial checks to verify
22422 -- the legal placement and context. Secondary checks preanalyze the
22423 -- refinement clauses in:
22425 -- Analyze_Refined_State_In_Decl_Part
22427 -- * Expansion - None.
22429 -- * Template - The annotation utilizes the template of the related
22432 -- * Globals - Capture of global references must occur after full
22435 -- * Instance - The annotation is instantiated automatically when
22436 -- the related generic package body is instantiated.
22438 when Pragma_Refined_State => Refined_State : declare
22439 Pack_Decl : Node_Id;
22440 Spec_Id : Entity_Id;
22444 Check_No_Identifiers;
22445 Check_Arg_Count (1);
22447 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22449 if Nkind (Pack_Decl) /= N_Package_Body then
22454 Spec_Id := Corresponding_Spec (Pack_Decl);
22456 -- A pragma that applies to a Ghost entity becomes Ghost for the
22457 -- purposes of legality checks and removal of ignored Ghost code.
22459 Mark_Ghost_Pragma (N, Spec_Id);
22461 -- Chain the pragma on the contract for further processing by
22462 -- Analyze_Refined_State_In_Decl_Part.
22464 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22466 -- The legality checks of pragma Refined_State are affected by the
22467 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22469 Analyze_If_Present (Pragma_SPARK_Mode);
22471 -- State refinement is allowed only when the corresponding package
22472 -- declaration has non-null pragma Abstract_State. Refinement not
22473 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22475 if SPARK_Mode /= Off
22477 (No (Abstract_States (Spec_Id))
22478 or else Has_Null_Abstract_State (Spec_Id))
22481 ("useless refinement, package & does not define abstract "
22482 & "states", N, Spec_Id);
22487 -----------------------
22488 -- Relative_Deadline --
22489 -----------------------
22491 -- pragma Relative_Deadline (time_span_EXPRESSION);
22493 when Pragma_Relative_Deadline => Relative_Deadline : declare
22494 P : constant Node_Id := Parent (N);
22499 Check_No_Identifiers;
22500 Check_Arg_Count (1);
22502 Arg := Get_Pragma_Arg (Arg1);
22504 -- The expression must be analyzed in the special manner described
22505 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22507 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22511 if Nkind (P) = N_Subprogram_Body then
22512 Check_In_Main_Program;
22514 -- Only Task and subprogram cases allowed
22516 elsif Nkind (P) /= N_Task_Definition then
22520 -- Check duplicate pragma before we set the corresponding flag
22522 if Has_Relative_Deadline_Pragma (P) then
22523 Error_Pragma ("duplicate pragma% not allowed");
22526 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22527 -- Relative_Deadline pragma node cannot be inserted in the Rep
22528 -- Item chain of Ent since it is rewritten by the expander as a
22529 -- procedure call statement that will break the chain.
22531 Set_Has_Relative_Deadline_Pragma (P);
22532 end Relative_Deadline;
22534 ------------------------
22535 -- Remote_Access_Type --
22536 ------------------------
22538 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22540 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22545 Check_Arg_Count (1);
22546 Check_Optional_Identifier (Arg1, Name_Entity);
22547 Check_Arg_Is_Local_Name (Arg1);
22549 E := Entity (Get_Pragma_Arg (Arg1));
22551 -- A pragma that applies to a Ghost entity becomes Ghost for the
22552 -- purposes of legality checks and removal of ignored Ghost code.
22554 Mark_Ghost_Pragma (N, E);
22556 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22557 and then Ekind (E) = E_General_Access_Type
22558 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22559 and then Scope (Root_Type (Directly_Designated_Type (E)))
22561 and then Is_Valid_Remote_Object_Type
22562 (Root_Type (Directly_Designated_Type (E)))
22564 Set_Is_Remote_Types (E);
22568 ("pragma% applies only to formal access-to-class-wide types",
22571 end Remote_Access_Type;
22573 ---------------------------
22574 -- Remote_Call_Interface --
22575 ---------------------------
22577 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22579 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22580 Cunit_Node : Node_Id;
22581 Cunit_Ent : Entity_Id;
22585 Check_Ada_83_Warning;
22586 Check_Valid_Library_Unit_Pragma;
22588 if Nkind (N) = N_Null_Statement then
22592 Cunit_Node := Cunit (Current_Sem_Unit);
22593 K := Nkind (Unit (Cunit_Node));
22594 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22596 -- A pragma that applies to a Ghost entity becomes Ghost for the
22597 -- purposes of legality checks and removal of ignored Ghost code.
22599 Mark_Ghost_Pragma (N, Cunit_Ent);
22601 if K = N_Package_Declaration
22602 or else K = N_Generic_Package_Declaration
22603 or else K = N_Subprogram_Declaration
22604 or else K = N_Generic_Subprogram_Declaration
22605 or else (K = N_Subprogram_Body
22606 and then Acts_As_Spec (Unit (Cunit_Node)))
22611 "pragma% must apply to package or subprogram declaration");
22614 Set_Is_Remote_Call_Interface (Cunit_Ent);
22615 end Remote_Call_Interface;
22621 -- pragma Remote_Types [(library_unit_NAME)];
22623 when Pragma_Remote_Types => Remote_Types : declare
22624 Cunit_Node : Node_Id;
22625 Cunit_Ent : Entity_Id;
22628 Check_Ada_83_Warning;
22629 Check_Valid_Library_Unit_Pragma;
22631 if Nkind (N) = N_Null_Statement then
22635 Cunit_Node := Cunit (Current_Sem_Unit);
22636 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22638 -- A pragma that applies to a Ghost entity becomes Ghost for the
22639 -- purposes of legality checks and removal of ignored Ghost code.
22641 Mark_Ghost_Pragma (N, Cunit_Ent);
22643 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22644 N_Generic_Package_Declaration)
22647 ("pragma% can only apply to a package declaration");
22650 Set_Is_Remote_Types (Cunit_Ent);
22657 -- pragma Ravenscar;
22659 when Pragma_Ravenscar =>
22661 Check_Arg_Count (0);
22662 Check_Valid_Configuration_Pragma;
22663 Set_Ravenscar_Profile (Ravenscar, N);
22665 if Warn_On_Obsolescent_Feature then
22667 ("pragma Ravenscar is an obsolescent feature?j?", N);
22669 ("|use pragma Profile (Ravenscar) instead?j?", N);
22672 -------------------------
22673 -- Restricted_Run_Time --
22674 -------------------------
22676 -- pragma Restricted_Run_Time;
22678 when Pragma_Restricted_Run_Time =>
22680 Check_Arg_Count (0);
22681 Check_Valid_Configuration_Pragma;
22682 Set_Profile_Restrictions
22683 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22685 if Warn_On_Obsolescent_Feature then
22687 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22690 ("|use pragma Profile (Restricted) instead?j?", N);
22697 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22700 -- restriction_IDENTIFIER
22701 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22703 when Pragma_Restrictions =>
22704 Process_Restrictions_Or_Restriction_Warnings
22705 (Warn => Treat_Restrictions_As_Warnings);
22707 --------------------------
22708 -- Restriction_Warnings --
22709 --------------------------
22711 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22714 -- restriction_IDENTIFIER
22715 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22717 when Pragma_Restriction_Warnings =>
22719 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22725 -- pragma Reviewable;
22727 when Pragma_Reviewable =>
22728 Check_Ada_83_Warning;
22729 Check_Arg_Count (0);
22731 -- Call dummy debugging function rv. This is done to assist front
22732 -- end debugging. By placing a Reviewable pragma in the source
22733 -- program, a breakpoint on rv catches this place in the source,
22734 -- allowing convenient stepping to the point of interest.
22738 --------------------------
22739 -- Secondary_Stack_Size --
22740 --------------------------
22742 -- pragma Secondary_Stack_Size (EXPRESSION);
22744 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22745 P : constant Node_Id := Parent (N);
22751 Check_No_Identifiers;
22752 Check_Arg_Count (1);
22754 if Nkind (P) = N_Task_Definition then
22755 Arg := Get_Pragma_Arg (Arg1);
22756 Ent := Defining_Identifier (Parent (P));
22758 -- The expression must be analyzed in the special manner
22759 -- described in "Handling of Default Expressions" in sem.ads.
22761 Preanalyze_Spec_Expression (Arg, Any_Integer);
22763 -- The pragma cannot appear if the No_Secondary_Stack
22764 -- restriction is in effect.
22766 Check_Restriction (No_Secondary_Stack, Arg);
22768 -- Anything else is incorrect
22774 -- Check duplicate pragma before we chain the pragma in the Rep
22775 -- Item chain of Ent.
22777 Check_Duplicate_Pragma (Ent);
22778 Record_Rep_Item (Ent, N);
22779 end Secondary_Stack_Size;
22781 --------------------------
22782 -- Short_Circuit_And_Or --
22783 --------------------------
22785 -- pragma Short_Circuit_And_Or;
22787 when Pragma_Short_Circuit_And_Or =>
22789 Check_Arg_Count (0);
22790 Check_Valid_Configuration_Pragma;
22791 Short_Circuit_And_Or := True;
22793 -------------------
22794 -- Share_Generic --
22795 -------------------
22797 -- pragma Share_Generic (GNAME {, GNAME});
22799 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22801 when Pragma_Share_Generic =>
22803 Process_Generic_List;
22809 -- pragma Shared (LOCAL_NAME);
22811 when Pragma_Shared =>
22813 Process_Atomic_Independent_Shared_Volatile;
22815 --------------------
22816 -- Shared_Passive --
22817 --------------------
22819 -- pragma Shared_Passive [(library_unit_NAME)];
22821 -- Set the flag Is_Shared_Passive of program unit name entity
22823 when Pragma_Shared_Passive => Shared_Passive : declare
22824 Cunit_Node : Node_Id;
22825 Cunit_Ent : Entity_Id;
22828 Check_Ada_83_Warning;
22829 Check_Valid_Library_Unit_Pragma;
22831 if Nkind (N) = N_Null_Statement then
22835 Cunit_Node := Cunit (Current_Sem_Unit);
22836 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22838 -- A pragma that applies to a Ghost entity becomes Ghost for the
22839 -- purposes of legality checks and removal of ignored Ghost code.
22841 Mark_Ghost_Pragma (N, Cunit_Ent);
22843 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22844 N_Generic_Package_Declaration)
22847 ("pragma% can only apply to a package declaration");
22850 Set_Is_Shared_Passive (Cunit_Ent);
22851 end Shared_Passive;
22853 -----------------------
22854 -- Short_Descriptors --
22855 -----------------------
22857 -- pragma Short_Descriptors;
22859 -- Recognize and validate, but otherwise ignore
22861 when Pragma_Short_Descriptors =>
22863 Check_Arg_Count (0);
22864 Check_Valid_Configuration_Pragma;
22866 ------------------------------
22867 -- Simple_Storage_Pool_Type --
22868 ------------------------------
22870 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22872 when Pragma_Simple_Storage_Pool_Type =>
22873 Simple_Storage_Pool_Type : declare
22879 Check_Arg_Count (1);
22880 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22882 Type_Id := Get_Pragma_Arg (Arg1);
22883 Find_Type (Type_Id);
22884 Typ := Entity (Type_Id);
22886 if Typ = Any_Type then
22890 -- A pragma that applies to a Ghost entity becomes Ghost for the
22891 -- purposes of legality checks and removal of ignored Ghost code.
22893 Mark_Ghost_Pragma (N, Typ);
22895 -- We require the pragma to apply to a type declared in a package
22896 -- declaration, but not (immediately) within a package body.
22898 if Ekind (Current_Scope) /= E_Package
22899 or else In_Package_Body (Current_Scope)
22902 ("pragma% can only apply to type declared immediately "
22903 & "within a package declaration");
22906 -- A simple storage pool type must be an immutably limited record
22907 -- or private type. If the pragma is given for a private type,
22908 -- the full type is similarly restricted (which is checked later
22909 -- in Freeze_Entity).
22911 if Is_Record_Type (Typ)
22912 and then not Is_Limited_View (Typ)
22915 ("pragma% can only apply to explicitly limited record type");
22917 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22919 ("pragma% can only apply to a private type that is limited");
22921 elsif not Is_Record_Type (Typ)
22922 and then not Is_Private_Type (Typ)
22925 ("pragma% can only apply to limited record or private type");
22928 Record_Rep_Item (Typ, N);
22929 end Simple_Storage_Pool_Type;
22931 ----------------------
22932 -- Source_File_Name --
22933 ----------------------
22935 -- There are five forms for this pragma:
22937 -- pragma Source_File_Name (
22938 -- [UNIT_NAME =>] unit_NAME,
22939 -- BODY_FILE_NAME => STRING_LITERAL
22940 -- [, [INDEX =>] INTEGER_LITERAL]);
22942 -- pragma Source_File_Name (
22943 -- [UNIT_NAME =>] unit_NAME,
22944 -- SPEC_FILE_NAME => STRING_LITERAL
22945 -- [, [INDEX =>] INTEGER_LITERAL]);
22947 -- pragma Source_File_Name (
22948 -- BODY_FILE_NAME => STRING_LITERAL
22949 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22950 -- [, CASING => CASING_SPEC]);
22952 -- pragma Source_File_Name (
22953 -- SPEC_FILE_NAME => STRING_LITERAL
22954 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22955 -- [, CASING => CASING_SPEC]);
22957 -- pragma Source_File_Name (
22958 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22959 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22960 -- [, CASING => CASING_SPEC]);
22962 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22964 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22965 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22966 -- only be used when no project file is used, while SFNP can only be
22967 -- used when a project file is used.
22969 -- No processing here. Processing was completed during parsing, since
22970 -- we need to have file names set as early as possible. Units are
22971 -- loaded well before semantic processing starts.
22973 -- The only processing we defer to this point is the check for
22974 -- correct placement.
22976 when Pragma_Source_File_Name =>
22978 Check_Valid_Configuration_Pragma;
22980 ------------------------------
22981 -- Source_File_Name_Project --
22982 ------------------------------
22984 -- See Source_File_Name for syntax
22986 -- No processing here. Processing was completed during parsing, since
22987 -- we need to have file names set as early as possible. Units are
22988 -- loaded well before semantic processing starts.
22990 -- The only processing we defer to this point is the check for
22991 -- correct placement.
22993 when Pragma_Source_File_Name_Project =>
22995 Check_Valid_Configuration_Pragma;
22997 -- Check that a pragma Source_File_Name_Project is used only in a
22998 -- configuration pragmas file.
23000 -- Pragmas Source_File_Name_Project should only be generated by
23001 -- the Project Manager in configuration pragmas files.
23003 -- This is really an ugly test. It seems to depend on some
23004 -- accidental and undocumented property. At the very least it
23005 -- needs to be documented, but it would be better to have a
23006 -- clean way of testing if we are in a configuration file???
23008 if Present (Parent (N)) then
23010 ("pragma% can only appear in a configuration pragmas file");
23013 ----------------------
23014 -- Source_Reference --
23015 ----------------------
23017 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
23019 -- Nothing to do, all processing completed in Par.Prag, since we need
23020 -- the information for possible parser messages that are output.
23022 when Pragma_Source_Reference =>
23029 -- pragma SPARK_Mode [(On | Off)];
23031 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
23032 Mode_Id : SPARK_Mode_Type;
23034 procedure Check_Pragma_Conformance
23035 (Context_Pragma : Node_Id;
23036 Entity : Entity_Id;
23037 Entity_Pragma : Node_Id);
23038 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
23039 -- conformance of pragma N depending the following scenarios:
23041 -- If pragma Context_Pragma is not Empty, verify that pragma N is
23042 -- compatible with the pragma Context_Pragma that was inherited
23043 -- from the context:
23044 -- * If the mode of Context_Pragma is ON, then the new mode can
23046 -- * If the mode of Context_Pragma is OFF, then the only allowed
23047 -- new mode is also OFF. Emit error if this is not the case.
23049 -- If Entity is not Empty, verify that pragma N is compatible with
23050 -- pragma Entity_Pragma that belongs to Entity.
23051 -- * If Entity_Pragma is Empty, always issue an error as this
23052 -- corresponds to the case where a previous section of Entity
23053 -- has no SPARK_Mode set.
23054 -- * If the mode of Entity_Pragma is ON, then the new mode can
23056 -- * If the mode of Entity_Pragma is OFF, then the only allowed
23057 -- new mode is also OFF. Emit error if this is not the case.
23059 procedure Check_Library_Level_Entity (E : Entity_Id);
23060 -- Subsidiary to routines Process_xxx. Verify that the related
23061 -- entity E subject to pragma SPARK_Mode is library-level.
23063 procedure Process_Body (Decl : Node_Id);
23064 -- Verify the legality of pragma SPARK_Mode when it appears as the
23065 -- top of the body declarations of entry, package, protected unit,
23066 -- subprogram or task unit body denoted by Decl.
23068 procedure Process_Overloadable (Decl : Node_Id);
23069 -- Verify the legality of pragma SPARK_Mode when it applies to an
23070 -- entry or [generic] subprogram declaration denoted by Decl.
23072 procedure Process_Private_Part (Decl : Node_Id);
23073 -- Verify the legality of pragma SPARK_Mode when it appears at the
23074 -- top of the private declarations of a package spec, protected or
23075 -- task unit declaration denoted by Decl.
23077 procedure Process_Statement_Part (Decl : Node_Id);
23078 -- Verify the legality of pragma SPARK_Mode when it appears at the
23079 -- top of the statement sequence of a package body denoted by node
23082 procedure Process_Visible_Part (Decl : Node_Id);
23083 -- Verify the legality of pragma SPARK_Mode when it appears at the
23084 -- top of the visible declarations of a package spec, protected or
23085 -- task unit declaration denoted by Decl. The routine is also used
23086 -- on protected or task units declared without a definition.
23088 procedure Set_SPARK_Context;
23089 -- Subsidiary to routines Process_xxx. Set the global variables
23090 -- which represent the mode of the context from pragma N. Ensure
23091 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23093 ------------------------------
23094 -- Check_Pragma_Conformance --
23095 ------------------------------
23097 procedure Check_Pragma_Conformance
23098 (Context_Pragma : Node_Id;
23099 Entity : Entity_Id;
23100 Entity_Pragma : Node_Id)
23102 Err_Id : Entity_Id;
23106 -- The current pragma may appear without an argument. If this
23107 -- is the case, associate all error messages with the pragma
23110 if Present (Arg1) then
23116 -- The mode of the current pragma is compared against that of
23117 -- an enclosing context.
23119 if Present (Context_Pragma) then
23120 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
23122 -- Issue an error if the new mode is less restrictive than
23123 -- that of the context.
23125 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
23126 and then Get_SPARK_Mode_From_Annotation (N) = On
23129 ("cannot change SPARK_Mode from Off to On", Err_N);
23130 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
23131 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
23136 -- The mode of the current pragma is compared against that of
23137 -- an initial package, protected type, subprogram or task type
23140 if Present (Entity) then
23142 -- A simple protected or task type is transformed into an
23143 -- anonymous type whose name cannot be used to issue error
23144 -- messages. Recover the original entity of the type.
23146 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
23149 (Original_Node (Unit_Declaration_Node (Entity)));
23154 -- Both the initial declaration and the completion carry
23155 -- SPARK_Mode pragmas.
23157 if Present (Entity_Pragma) then
23158 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23160 -- Issue an error if the new mode is less restrictive
23161 -- than that of the initial declaration.
23163 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23164 and then Get_SPARK_Mode_From_Annotation (N) = On
23166 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23167 Error_Msg_Sloc := Sloc (Entity_Pragma);
23169 ("\value Off was set for SPARK_Mode on&#",
23174 -- Otherwise the initial declaration lacks a SPARK_Mode
23175 -- pragma in which case the current pragma is illegal as
23176 -- it cannot "complete".
23179 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23180 Error_Msg_Sloc := Sloc (Err_Id);
23182 ("\no value was set for SPARK_Mode on&#",
23187 end Check_Pragma_Conformance;
23189 --------------------------------
23190 -- Check_Library_Level_Entity --
23191 --------------------------------
23193 procedure Check_Library_Level_Entity (E : Entity_Id) is
23194 procedure Add_Entity_To_Name_Buffer;
23195 -- Add the E_Kind of entity E to the name buffer
23197 -------------------------------
23198 -- Add_Entity_To_Name_Buffer --
23199 -------------------------------
23201 procedure Add_Entity_To_Name_Buffer is
23203 if Ekind_In (E, E_Entry, E_Entry_Family) then
23204 Add_Str_To_Name_Buffer ("entry");
23206 elsif Ekind_In (E, E_Generic_Package,
23210 Add_Str_To_Name_Buffer ("package");
23212 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
23213 Add_Str_To_Name_Buffer ("protected type");
23215 elsif Ekind_In (E, E_Function,
23216 E_Generic_Function,
23217 E_Generic_Procedure,
23221 Add_Str_To_Name_Buffer ("subprogram");
23224 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
23225 Add_Str_To_Name_Buffer ("task type");
23227 end Add_Entity_To_Name_Buffer;
23231 Msg_1 : constant String := "incorrect placement of pragma%";
23234 -- Start of processing for Check_Library_Level_Entity
23237 -- A SPARK_Mode of On shall only apply to library-level
23238 -- entities, except for those in generic instances, which are
23239 -- ignored (even if the entity gets SPARK_Mode pragma attached
23240 -- in the AST, its effect is not taken into account unless the
23241 -- context already provides SPARK_Mode of On in GNATprove).
23243 if Get_SPARK_Mode_From_Annotation (N) = On
23244 and then not Is_Library_Level_Entity (E)
23245 and then Instantiation_Location (Sloc (N)) = No_Location
23247 Error_Msg_Name_1 := Pname;
23248 Error_Msg_N (Fix_Error (Msg_1), N);
23251 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23252 Add_Entity_To_Name_Buffer;
23254 Msg_2 := Name_Find;
23255 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23259 end Check_Library_Level_Entity;
23265 procedure Process_Body (Decl : Node_Id) is
23266 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23267 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23270 -- Ignore pragma when applied to the special body created for
23271 -- inlining, recognized by its internal name _Parent.
23273 if Chars (Body_Id) = Name_uParent then
23277 Check_Library_Level_Entity (Body_Id);
23279 -- For entry bodies, verify the legality against:
23280 -- * The mode of the context
23281 -- * The mode of the spec (if any)
23283 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
23285 -- A stand-alone subprogram body
23287 if Body_Id = Spec_Id then
23288 Check_Pragma_Conformance
23289 (Context_Pragma => SPARK_Pragma (Body_Id),
23291 Entity_Pragma => Empty);
23293 -- An entry or subprogram body that completes a previous
23297 Check_Pragma_Conformance
23298 (Context_Pragma => SPARK_Pragma (Body_Id),
23300 Entity_Pragma => SPARK_Pragma (Spec_Id));
23304 Set_SPARK_Pragma (Body_Id, N);
23305 Set_SPARK_Pragma_Inherited (Body_Id, False);
23307 -- For package bodies, verify the legality against:
23308 -- * The mode of the context
23309 -- * The mode of the private part
23311 -- This case is separated from protected and task bodies
23312 -- because the statement part of the package body inherits
23313 -- the mode of the body declarations.
23315 elsif Nkind (Decl) = N_Package_Body then
23316 Check_Pragma_Conformance
23317 (Context_Pragma => SPARK_Pragma (Body_Id),
23319 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23322 Set_SPARK_Pragma (Body_Id, N);
23323 Set_SPARK_Pragma_Inherited (Body_Id, False);
23324 Set_SPARK_Aux_Pragma (Body_Id, N);
23325 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23327 -- For protected and task bodies, verify the legality against:
23328 -- * The mode of the context
23329 -- * The mode of the private part
23333 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
23335 Check_Pragma_Conformance
23336 (Context_Pragma => SPARK_Pragma (Body_Id),
23338 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23341 Set_SPARK_Pragma (Body_Id, N);
23342 Set_SPARK_Pragma_Inherited (Body_Id, False);
23346 --------------------------
23347 -- Process_Overloadable --
23348 --------------------------
23350 procedure Process_Overloadable (Decl : Node_Id) is
23351 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23352 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23355 Check_Library_Level_Entity (Spec_Id);
23357 -- Verify the legality against:
23358 -- * The mode of the context
23360 Check_Pragma_Conformance
23361 (Context_Pragma => SPARK_Pragma (Spec_Id),
23363 Entity_Pragma => Empty);
23365 Set_SPARK_Pragma (Spec_Id, N);
23366 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23368 -- When the pragma applies to the anonymous object created for
23369 -- a single task type, decorate the type as well. This scenario
23370 -- arises when the single task type lacks a task definition,
23371 -- therefore there is no issue with respect to a potential
23372 -- pragma SPARK_Mode in the private part.
23374 -- task type Anon_Task_Typ;
23375 -- Obj : Anon_Task_Typ;
23376 -- pragma SPARK_Mode ...;
23378 if Is_Single_Task_Object (Spec_Id) then
23379 Set_SPARK_Pragma (Spec_Typ, N);
23380 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23381 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23382 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23384 end Process_Overloadable;
23386 --------------------------
23387 -- Process_Private_Part --
23388 --------------------------
23390 procedure Process_Private_Part (Decl : Node_Id) is
23391 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23394 Check_Library_Level_Entity (Spec_Id);
23396 -- Verify the legality against:
23397 -- * The mode of the visible declarations
23399 Check_Pragma_Conformance
23400 (Context_Pragma => Empty,
23402 Entity_Pragma => SPARK_Pragma (Spec_Id));
23405 Set_SPARK_Aux_Pragma (Spec_Id, N);
23406 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23407 end Process_Private_Part;
23409 ----------------------------
23410 -- Process_Statement_Part --
23411 ----------------------------
23413 procedure Process_Statement_Part (Decl : Node_Id) is
23414 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23417 Check_Library_Level_Entity (Body_Id);
23419 -- Verify the legality against:
23420 -- * The mode of the body declarations
23422 Check_Pragma_Conformance
23423 (Context_Pragma => Empty,
23425 Entity_Pragma => SPARK_Pragma (Body_Id));
23428 Set_SPARK_Aux_Pragma (Body_Id, N);
23429 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23430 end Process_Statement_Part;
23432 --------------------------
23433 -- Process_Visible_Part --
23434 --------------------------
23436 procedure Process_Visible_Part (Decl : Node_Id) is
23437 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23438 Obj_Id : Entity_Id;
23441 Check_Library_Level_Entity (Spec_Id);
23443 -- Verify the legality against:
23444 -- * The mode of the context
23446 Check_Pragma_Conformance
23447 (Context_Pragma => SPARK_Pragma (Spec_Id),
23449 Entity_Pragma => Empty);
23451 -- A task unit declared without a definition does not set the
23452 -- SPARK_Mode of the context because the task does not have any
23453 -- entries that could inherit the mode.
23455 if not Nkind_In (Decl, N_Single_Task_Declaration,
23456 N_Task_Type_Declaration)
23461 Set_SPARK_Pragma (Spec_Id, N);
23462 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23463 Set_SPARK_Aux_Pragma (Spec_Id, N);
23464 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23466 -- When the pragma applies to a single protected or task type,
23467 -- decorate the corresponding anonymous object as well.
23469 -- protected Anon_Prot_Typ is
23470 -- pragma SPARK_Mode ...;
23472 -- end Anon_Prot_Typ;
23474 -- Obj : Anon_Prot_Typ;
23476 if Is_Single_Concurrent_Type (Spec_Id) then
23477 Obj_Id := Anonymous_Object (Spec_Id);
23479 Set_SPARK_Pragma (Obj_Id, N);
23480 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23482 end Process_Visible_Part;
23484 -----------------------
23485 -- Set_SPARK_Context --
23486 -----------------------
23488 procedure Set_SPARK_Context is
23490 SPARK_Mode := Mode_Id;
23491 SPARK_Mode_Pragma := N;
23492 end Set_SPARK_Context;
23500 -- Start of processing for Do_SPARK_Mode
23503 -- When a SPARK_Mode pragma appears inside an instantiation whose
23504 -- enclosing context has SPARK_Mode set to "off", the pragma has
23505 -- no semantic effect.
23507 if Ignore_SPARK_Mode_Pragmas_In_Instance then
23508 Rewrite (N, Make_Null_Statement (Loc));
23514 Check_No_Identifiers;
23515 Check_At_Most_N_Arguments (1);
23517 -- Check the legality of the mode (no argument = ON)
23519 if Arg_Count = 1 then
23520 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23521 Mode := Chars (Get_Pragma_Arg (Arg1));
23526 Mode_Id := Get_SPARK_Mode_Type (Mode);
23527 Context := Parent (N);
23529 -- The pragma appears in a configuration file
23531 if No (Context) then
23532 Check_Valid_Configuration_Pragma;
23534 if Present (SPARK_Mode_Pragma) then
23537 Prev => SPARK_Mode_Pragma);
23543 -- The pragma acts as a configuration pragma in a compilation unit
23545 -- pragma SPARK_Mode ...;
23546 -- package Pack is ...;
23548 elsif Nkind (Context) = N_Compilation_Unit
23549 and then List_Containing (N) = Context_Items (Context)
23551 Check_Valid_Configuration_Pragma;
23554 -- Otherwise the placement of the pragma within the tree dictates
23555 -- its associated construct. Inspect the declarative list where
23556 -- the pragma resides to find a potential construct.
23560 while Present (Stmt) loop
23562 -- Skip prior pragmas, but check for duplicates. Note that
23563 -- this also takes care of pragmas generated for aspects.
23565 if Nkind (Stmt) = N_Pragma then
23566 if Pragma_Name (Stmt) = Pname then
23573 -- The pragma applies to an expression function that has
23574 -- already been rewritten into a subprogram declaration.
23576 -- function Expr_Func return ... is (...);
23577 -- pragma SPARK_Mode ...;
23579 elsif Nkind (Stmt) = N_Subprogram_Declaration
23580 and then Nkind (Original_Node (Stmt)) =
23581 N_Expression_Function
23583 Process_Overloadable (Stmt);
23586 -- The pragma applies to the anonymous object created for a
23587 -- single concurrent type.
23589 -- protected type Anon_Prot_Typ ...;
23590 -- Obj : Anon_Prot_Typ;
23591 -- pragma SPARK_Mode ...;
23593 elsif Nkind (Stmt) = N_Object_Declaration
23594 and then Is_Single_Concurrent_Object
23595 (Defining_Entity (Stmt))
23597 Process_Overloadable (Stmt);
23600 -- Skip internally generated code
23602 elsif not Comes_From_Source (Stmt) then
23605 -- The pragma applies to an entry or [generic] subprogram
23609 -- pragma SPARK_Mode ...;
23612 -- procedure Proc ...;
23613 -- pragma SPARK_Mode ...;
23615 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
23616 N_Subprogram_Declaration)
23617 or else (Nkind (Stmt) = N_Entry_Declaration
23618 and then Is_Protected_Type
23619 (Scope (Defining_Entity (Stmt))))
23621 Process_Overloadable (Stmt);
23624 -- Otherwise the pragma does not apply to a legal construct
23625 -- or it does not appear at the top of a declarative or a
23626 -- statement list. Issue an error and stop the analysis.
23636 -- The pragma applies to a package or a subprogram that acts as
23637 -- a compilation unit.
23639 -- procedure Proc ...;
23640 -- pragma SPARK_Mode ...;
23642 if Nkind (Context) = N_Compilation_Unit_Aux then
23643 Context := Unit (Parent (Context));
23646 -- The pragma appears at the top of entry, package, protected
23647 -- unit, subprogram or task unit body declarations.
23649 -- entry Ent when ... is
23650 -- pragma SPARK_Mode ...;
23652 -- package body Pack is
23653 -- pragma SPARK_Mode ...;
23655 -- procedure Proc ... is
23656 -- pragma SPARK_Mode;
23658 -- protected body Prot is
23659 -- pragma SPARK_Mode ...;
23661 if Nkind_In (Context, N_Entry_Body,
23667 Process_Body (Context);
23669 -- The pragma appears at the top of the visible or private
23670 -- declaration of a package spec, protected or task unit.
23673 -- pragma SPARK_Mode ...;
23675 -- pragma SPARK_Mode ...;
23677 -- protected [type] Prot is
23678 -- pragma SPARK_Mode ...;
23680 -- pragma SPARK_Mode ...;
23682 elsif Nkind_In (Context, N_Package_Specification,
23683 N_Protected_Definition,
23686 if List_Containing (N) = Visible_Declarations (Context) then
23687 Process_Visible_Part (Parent (Context));
23689 Process_Private_Part (Parent (Context));
23692 -- The pragma appears at the top of package body statements
23694 -- package body Pack is
23696 -- pragma SPARK_Mode;
23698 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23699 and then Nkind (Parent (Context)) = N_Package_Body
23701 Process_Statement_Part (Parent (Context));
23703 -- The pragma appeared as an aspect of a [generic] subprogram
23704 -- declaration that acts as a compilation unit.
23707 -- procedure Proc ...;
23708 -- pragma SPARK_Mode ...;
23710 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
23711 N_Subprogram_Declaration)
23713 Process_Overloadable (Context);
23715 -- The pragma does not apply to a legal construct, issue error
23723 --------------------------------
23724 -- Static_Elaboration_Desired --
23725 --------------------------------
23727 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23729 when Pragma_Static_Elaboration_Desired =>
23731 Check_At_Most_N_Arguments (1);
23733 if Is_Compilation_Unit (Current_Scope)
23734 and then Ekind (Current_Scope) = E_Package
23736 Set_Static_Elaboration_Desired (Current_Scope, True);
23738 Error_Pragma ("pragma% must apply to a library-level package");
23745 -- pragma Storage_Size (EXPRESSION);
23747 when Pragma_Storage_Size => Storage_Size : declare
23748 P : constant Node_Id := Parent (N);
23752 Check_No_Identifiers;
23753 Check_Arg_Count (1);
23755 -- The expression must be analyzed in the special manner described
23756 -- in "Handling of Default Expressions" in sem.ads.
23758 Arg := Get_Pragma_Arg (Arg1);
23759 Preanalyze_Spec_Expression (Arg, Any_Integer);
23761 if not Is_OK_Static_Expression (Arg) then
23762 Check_Restriction (Static_Storage_Size, Arg);
23765 if Nkind (P) /= N_Task_Definition then
23770 if Has_Storage_Size_Pragma (P) then
23771 Error_Pragma ("duplicate pragma% not allowed");
23773 Set_Has_Storage_Size_Pragma (P, True);
23776 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23784 -- pragma Storage_Unit (NUMERIC_LITERAL);
23786 -- Only permitted argument is System'Storage_Unit value
23788 when Pragma_Storage_Unit =>
23789 Check_No_Identifiers;
23790 Check_Arg_Count (1);
23791 Check_Arg_Is_Integer_Literal (Arg1);
23793 if Intval (Get_Pragma_Arg (Arg1)) /=
23794 UI_From_Int (Ttypes.System_Storage_Unit)
23796 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23798 ("the only allowed argument for pragma% is ^", Arg1);
23801 --------------------
23802 -- Stream_Convert --
23803 --------------------
23805 -- pragma Stream_Convert (
23806 -- [Entity =>] type_LOCAL_NAME,
23807 -- [Read =>] function_NAME,
23808 -- [Write =>] function NAME);
23810 when Pragma_Stream_Convert => Stream_Convert : declare
23811 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23812 -- Check that the given argument is the name of a local function
23813 -- of one argument that is not overloaded earlier in the current
23814 -- local scope. A check is also made that the argument is a
23815 -- function with one parameter.
23817 --------------------------------------
23818 -- Check_OK_Stream_Convert_Function --
23819 --------------------------------------
23821 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23825 Check_Arg_Is_Local_Name (Arg);
23826 Ent := Entity (Get_Pragma_Arg (Arg));
23828 if Has_Homonym (Ent) then
23830 ("argument for pragma% may not be overloaded", Arg);
23833 if Ekind (Ent) /= E_Function
23834 or else No (First_Formal (Ent))
23835 or else Present (Next_Formal (First_Formal (Ent)))
23838 ("argument for pragma% must be function of one argument",
23841 end Check_OK_Stream_Convert_Function;
23843 -- Start of processing for Stream_Convert
23847 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23848 Check_Arg_Count (3);
23849 Check_Optional_Identifier (Arg1, Name_Entity);
23850 Check_Optional_Identifier (Arg2, Name_Read);
23851 Check_Optional_Identifier (Arg3, Name_Write);
23852 Check_Arg_Is_Local_Name (Arg1);
23853 Check_OK_Stream_Convert_Function (Arg2);
23854 Check_OK_Stream_Convert_Function (Arg3);
23857 Typ : constant Entity_Id :=
23858 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23859 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23860 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23863 Check_First_Subtype (Arg1);
23865 -- Check for too early or too late. Note that we don't enforce
23866 -- the rule about primitive operations in this case, since, as
23867 -- is the case for explicit stream attributes themselves, these
23868 -- restrictions are not appropriate. Note that the chaining of
23869 -- the pragma by Rep_Item_Too_Late is actually the critical
23870 -- processing done for this pragma.
23872 if Rep_Item_Too_Early (Typ, N)
23874 Rep_Item_Too_Late (Typ, N, FOnly => True)
23879 -- Return if previous error
23881 if Etype (Typ) = Any_Type
23883 Etype (Read) = Any_Type
23885 Etype (Write) = Any_Type
23892 if Underlying_Type (Etype (Read)) /= Typ then
23894 ("incorrect return type for function&", Arg2);
23897 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23899 ("incorrect parameter type for function&", Arg3);
23902 if Underlying_Type (Etype (First_Formal (Read))) /=
23903 Underlying_Type (Etype (Write))
23906 ("result type of & does not match Read parameter type",
23910 end Stream_Convert;
23916 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23918 -- This is processed by the parser since some of the style checks
23919 -- take place during source scanning and parsing. This means that
23920 -- we don't need to issue error messages here.
23922 when Pragma_Style_Checks => Style_Checks : declare
23923 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23929 Check_No_Identifiers;
23931 -- Two argument form
23933 if Arg_Count = 2 then
23934 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23941 E_Id := Get_Pragma_Arg (Arg2);
23944 if not Is_Entity_Name (E_Id) then
23946 ("second argument of pragma% must be entity name",
23950 E := Entity (E_Id);
23952 if not Ignore_Style_Checks_Pragmas then
23957 Set_Suppress_Style_Checks
23958 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23959 exit when No (Homonym (E));
23966 -- One argument form
23969 Check_Arg_Count (1);
23971 if Nkind (A) = N_String_Literal then
23975 Slen : constant Natural := Natural (String_Length (S));
23976 Options : String (1 .. Slen);
23982 C := Get_String_Char (S, Pos (J));
23983 exit when not In_Character_Range (C);
23984 Options (J) := Get_Character (C);
23986 -- If at end of string, set options. As per discussion
23987 -- above, no need to check for errors, since we issued
23988 -- them in the parser.
23991 if not Ignore_Style_Checks_Pragmas then
23992 Set_Style_Check_Options (Options);
24002 elsif Nkind (A) = N_Identifier then
24003 if Chars (A) = Name_All_Checks then
24004 if not Ignore_Style_Checks_Pragmas then
24006 Set_GNAT_Style_Check_Options;
24008 Set_Default_Style_Check_Options;
24012 elsif Chars (A) = Name_On then
24013 if not Ignore_Style_Checks_Pragmas then
24014 Style_Check := True;
24017 elsif Chars (A) = Name_Off then
24018 if not Ignore_Style_Checks_Pragmas then
24019 Style_Check := False;
24030 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24032 when Pragma_Subtitle =>
24034 Check_Arg_Count (1);
24035 Check_Optional_Identifier (Arg1, Name_Subtitle);
24036 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24043 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24045 when Pragma_Suppress =>
24046 Process_Suppress_Unsuppress (Suppress_Case => True);
24052 -- pragma Suppress_All;
24054 -- The only check made here is that the pragma has no arguments.
24055 -- There are no placement rules, and the processing required (setting
24056 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24057 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24058 -- then creates and inserts a pragma Suppress (All_Checks).
24060 when Pragma_Suppress_All =>
24062 Check_Arg_Count (0);
24064 -------------------------
24065 -- Suppress_Debug_Info --
24066 -------------------------
24068 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24070 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24071 Nam_Id : Entity_Id;
24075 Check_Arg_Count (1);
24076 Check_Optional_Identifier (Arg1, Name_Entity);
24077 Check_Arg_Is_Local_Name (Arg1);
24079 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24081 -- A pragma that applies to a Ghost entity becomes Ghost for the
24082 -- purposes of legality checks and removal of ignored Ghost code.
24084 Mark_Ghost_Pragma (N, Nam_Id);
24085 Set_Debug_Info_Off (Nam_Id);
24086 end Suppress_Debug_Info;
24088 ----------------------------------
24089 -- Suppress_Exception_Locations --
24090 ----------------------------------
24092 -- pragma Suppress_Exception_Locations;
24094 when Pragma_Suppress_Exception_Locations =>
24096 Check_Arg_Count (0);
24097 Check_Valid_Configuration_Pragma;
24098 Exception_Locations_Suppressed := True;
24100 -----------------------------
24101 -- Suppress_Initialization --
24102 -----------------------------
24104 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24106 when Pragma_Suppress_Initialization => Suppress_Init : declare
24112 Check_Arg_Count (1);
24113 Check_Optional_Identifier (Arg1, Name_Entity);
24114 Check_Arg_Is_Local_Name (Arg1);
24116 E_Id := Get_Pragma_Arg (Arg1);
24118 if Etype (E_Id) = Any_Type then
24122 E := Entity (E_Id);
24124 -- A pragma that applies to a Ghost entity becomes Ghost for the
24125 -- purposes of legality checks and removal of ignored Ghost code.
24127 Mark_Ghost_Pragma (N, E);
24129 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24131 ("pragma% requires variable, type or subtype", Arg1);
24134 if Rep_Item_Too_Early (E, N)
24136 Rep_Item_Too_Late (E, N, FOnly => True)
24141 -- For incomplete/private type, set flag on full view
24143 if Is_Incomplete_Or_Private_Type (E) then
24144 if No (Full_View (Base_Type (E))) then
24146 ("argument of pragma% cannot be an incomplete type", Arg1);
24148 Set_Suppress_Initialization (Full_View (E));
24151 -- For first subtype, set flag on base type
24153 elsif Is_First_Subtype (E) then
24154 Set_Suppress_Initialization (Base_Type (E));
24156 -- For other than first subtype, set flag on subtype or variable
24159 Set_Suppress_Initialization (E);
24167 -- pragma System_Name (DIRECT_NAME);
24169 -- Syntax check: one argument, which must be the identifier GNAT or
24170 -- the identifier GCC, no other identifiers are acceptable.
24172 when Pragma_System_Name =>
24174 Check_No_Identifiers;
24175 Check_Arg_Count (1);
24176 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24178 -----------------------------
24179 -- Task_Dispatching_Policy --
24180 -----------------------------
24182 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24184 when Pragma_Task_Dispatching_Policy => declare
24188 Check_Ada_83_Warning;
24189 Check_Arg_Count (1);
24190 Check_No_Identifiers;
24191 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24192 Check_Valid_Configuration_Pragma;
24193 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24194 DP := Fold_Upper (Name_Buffer (1));
24196 if Task_Dispatching_Policy /= ' '
24197 and then Task_Dispatching_Policy /= DP
24199 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24201 ("task dispatching policy incompatible with policy#");
24203 -- Set new policy, but always preserve System_Location since we
24204 -- like the error message with the run time name.
24207 Task_Dispatching_Policy := DP;
24209 if Task_Dispatching_Policy_Sloc /= System_Location then
24210 Task_Dispatching_Policy_Sloc := Loc;
24219 -- pragma Task_Info (EXPRESSION);
24221 when Pragma_Task_Info => Task_Info : declare
24222 P : constant Node_Id := Parent (N);
24228 if Warn_On_Obsolescent_Feature then
24230 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24231 & "instead?j?", N);
24234 if Nkind (P) /= N_Task_Definition then
24235 Error_Pragma ("pragma% must appear in task definition");
24238 Check_No_Identifiers;
24239 Check_Arg_Count (1);
24241 Analyze_And_Resolve
24242 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24244 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24248 Ent := Defining_Identifier (Parent (P));
24250 -- Check duplicate pragma before we chain the pragma in the Rep
24251 -- Item chain of Ent.
24254 (Ent, Name_Task_Info, Check_Parents => False)
24256 Error_Pragma ("duplicate pragma% not allowed");
24259 Record_Rep_Item (Ent, N);
24266 -- pragma Task_Name (string_EXPRESSION);
24268 when Pragma_Task_Name => Task_Name : declare
24269 P : constant Node_Id := Parent (N);
24274 Check_No_Identifiers;
24275 Check_Arg_Count (1);
24277 Arg := Get_Pragma_Arg (Arg1);
24279 -- The expression is used in the call to Create_Task, and must be
24280 -- expanded there, not in the context of the current spec. It must
24281 -- however be analyzed to capture global references, in case it
24282 -- appears in a generic context.
24284 Preanalyze_And_Resolve (Arg, Standard_String);
24286 if Nkind (P) /= N_Task_Definition then
24290 Ent := Defining_Identifier (Parent (P));
24292 -- Check duplicate pragma before we chain the pragma in the Rep
24293 -- Item chain of Ent.
24296 (Ent, Name_Task_Name, Check_Parents => False)
24298 Error_Pragma ("duplicate pragma% not allowed");
24301 Record_Rep_Item (Ent, N);
24308 -- pragma Task_Storage (
24309 -- [Task_Type =>] LOCAL_NAME,
24310 -- [Top_Guard =>] static_integer_EXPRESSION);
24312 when Pragma_Task_Storage => Task_Storage : declare
24313 Args : Args_List (1 .. 2);
24314 Names : constant Name_List (1 .. 2) := (
24318 Task_Type : Node_Id renames Args (1);
24319 Top_Guard : Node_Id renames Args (2);
24325 Gather_Associations (Names, Args);
24327 if No (Task_Type) then
24329 ("missing task_type argument for pragma%");
24332 Check_Arg_Is_Local_Name (Task_Type);
24334 Ent := Entity (Task_Type);
24336 if not Is_Task_Type (Ent) then
24338 ("argument for pragma% must be task type", Task_Type);
24341 if No (Top_Guard) then
24343 ("pragma% takes two arguments", Task_Type);
24345 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24348 Check_First_Subtype (Task_Type);
24350 if Rep_Item_Too_Late (Ent, N) then
24359 -- pragma Test_Case
24360 -- ([Name =>] Static_String_EXPRESSION
24361 -- ,[Mode =>] MODE_TYPE
24362 -- [, Requires => Boolean_EXPRESSION]
24363 -- [, Ensures => Boolean_EXPRESSION]);
24365 -- MODE_TYPE ::= Nominal | Robustness
24367 -- Characteristics:
24369 -- * Analysis - The annotation undergoes initial checks to verify
24370 -- the legal placement and context. Secondary checks preanalyze the
24373 -- Analyze_Test_Case_In_Decl_Part
24375 -- * Expansion - None.
24377 -- * Template - The annotation utilizes the generic template of the
24378 -- related subprogram when it is:
24380 -- aspect on subprogram declaration
24382 -- The annotation must prepare its own template when it is:
24384 -- pragma on subprogram declaration
24386 -- * Globals - Capture of global references must occur after full
24389 -- * Instance - The annotation is instantiated automatically when
24390 -- the related generic subprogram is instantiated except for the
24391 -- "pragma on subprogram declaration" case. In that scenario the
24392 -- annotation must instantiate itself.
24394 when Pragma_Test_Case => Test_Case : declare
24395 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24396 -- Ensure that the contract of subprogram Subp_Id does not contain
24397 -- another Test_Case pragma with the same Name as the current one.
24399 -------------------------
24400 -- Check_Distinct_Name --
24401 -------------------------
24403 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24404 Items : constant Node_Id := Contract (Subp_Id);
24405 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24409 -- Inspect all Test_Case pragma of the related subprogram
24410 -- looking for one with a duplicate "Name" argument.
24412 if Present (Items) then
24413 Prag := Contract_Test_Cases (Items);
24414 while Present (Prag) loop
24415 if Pragma_Name (Prag) = Name_Test_Case
24417 and then String_Equal
24418 (Name, Get_Name_From_CTC_Pragma (Prag))
24420 Error_Msg_Sloc := Sloc (Prag);
24421 Error_Pragma ("name for pragma % is already used #");
24424 Prag := Next_Pragma (Prag);
24427 end Check_Distinct_Name;
24431 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24434 Subp_Decl : Node_Id;
24435 Subp_Id : Entity_Id;
24437 -- Start of processing for Test_Case
24441 Check_At_Least_N_Arguments (2);
24442 Check_At_Most_N_Arguments (4);
24444 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24448 Check_Optional_Identifier (Arg1, Name_Name);
24449 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24453 Check_Optional_Identifier (Arg2, Name_Mode);
24454 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24456 -- Arguments "Requires" and "Ensures"
24458 if Present (Arg3) then
24459 if Present (Arg4) then
24460 Check_Identifier (Arg3, Name_Requires);
24461 Check_Identifier (Arg4, Name_Ensures);
24463 Check_Identifier_Is_One_Of
24464 (Arg3, Name_Requires, Name_Ensures);
24468 -- Pragma Test_Case must be associated with a subprogram declared
24469 -- in a library-level package. First determine whether the current
24470 -- compilation unit is a legal context.
24472 if Nkind_In (Pack_Decl, N_Package_Declaration,
24473 N_Generic_Package_Declaration)
24477 -- Otherwise the placement is illegal
24481 ("pragma % must be specified within a package declaration");
24485 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24487 -- Find the enclosing context
24489 Context := Parent (Subp_Decl);
24491 if Present (Context) then
24492 Context := Parent (Context);
24495 -- Verify the placement of the pragma
24497 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24499 ("pragma % cannot be applied to abstract subprogram");
24502 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24503 Error_Pragma ("pragma % cannot be applied to entry");
24506 -- The context is a [generic] subprogram declared at the top level
24507 -- of the [generic] package unit.
24509 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
24510 N_Subprogram_Declaration)
24511 and then Present (Context)
24512 and then Nkind_In (Context, N_Generic_Package_Declaration,
24513 N_Package_Declaration)
24517 -- Otherwise the placement is illegal
24521 ("pragma % must be applied to a library-level subprogram "
24526 Subp_Id := Defining_Entity (Subp_Decl);
24528 -- A pragma that applies to a Ghost entity becomes Ghost for the
24529 -- purposes of legality checks and removal of ignored Ghost code.
24531 Mark_Ghost_Pragma (N, Subp_Id);
24533 -- Chain the pragma on the contract for further processing by
24534 -- Analyze_Test_Case_In_Decl_Part.
24536 Add_Contract_Item (N, Subp_Id);
24538 -- Preanalyze the original aspect argument "Name" for ASIS or for
24539 -- a generic subprogram to properly capture global references.
24541 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
24542 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24544 if Present (Asp_Arg) then
24546 -- The argument appears with an identifier in association
24549 if Nkind (Asp_Arg) = N_Component_Association then
24550 Asp_Arg := Expression (Asp_Arg);
24553 Check_Expr_Is_OK_Static_Expression
24554 (Asp_Arg, Standard_String);
24558 -- Ensure that the all Test_Case pragmas of the related subprogram
24559 -- have distinct names.
24561 Check_Distinct_Name (Subp_Id);
24563 -- Fully analyze the pragma when it appears inside an entry
24564 -- or subprogram body because it cannot benefit from forward
24567 if Nkind_In (Subp_Decl, N_Entry_Body,
24569 N_Subprogram_Body_Stub)
24571 -- The legality checks of pragma Test_Case are affected by the
24572 -- SPARK mode in effect and the volatility of the context.
24573 -- Analyze all pragmas in a specific order.
24575 Analyze_If_Present (Pragma_SPARK_Mode);
24576 Analyze_If_Present (Pragma_Volatile_Function);
24577 Analyze_Test_Case_In_Decl_Part (N);
24581 --------------------------
24582 -- Thread_Local_Storage --
24583 --------------------------
24585 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24587 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24593 Check_Arg_Count (1);
24594 Check_Optional_Identifier (Arg1, Name_Entity);
24595 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24597 Id := Get_Pragma_Arg (Arg1);
24600 if not Is_Entity_Name (Id)
24601 or else Ekind (Entity (Id)) /= E_Variable
24603 Error_Pragma_Arg ("local variable name required", Arg1);
24608 -- A pragma that applies to a Ghost entity becomes Ghost for the
24609 -- purposes of legality checks and removal of ignored Ghost code.
24611 Mark_Ghost_Pragma (N, E);
24613 if Rep_Item_Too_Early (E, N)
24615 Rep_Item_Too_Late (E, N)
24620 Set_Has_Pragma_Thread_Local_Storage (E);
24621 Set_Has_Gigi_Rep_Item (E);
24622 end Thread_Local_Storage;
24628 -- pragma Time_Slice (static_duration_EXPRESSION);
24630 when Pragma_Time_Slice => Time_Slice : declare
24636 Check_Arg_Count (1);
24637 Check_No_Identifiers;
24638 Check_In_Main_Program;
24639 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24641 if not Error_Posted (Arg1) then
24643 while Present (Nod) loop
24644 if Nkind (Nod) = N_Pragma
24645 and then Pragma_Name (Nod) = Name_Time_Slice
24647 Error_Msg_Name_1 := Pname;
24648 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24655 -- Process only if in main unit
24657 if Get_Source_Unit (Loc) = Main_Unit then
24658 Opt.Time_Slice_Set := True;
24659 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24661 if Val <= Ureal_0 then
24662 Opt.Time_Slice_Value := 0;
24664 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24665 Opt.Time_Slice_Value := 1_000_000_000;
24668 Opt.Time_Slice_Value :=
24669 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24678 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24680 -- TITLING_OPTION ::=
24681 -- [Title =>] STRING_LITERAL
24682 -- | [Subtitle =>] STRING_LITERAL
24684 when Pragma_Title => Title : declare
24685 Args : Args_List (1 .. 2);
24686 Names : constant Name_List (1 .. 2) := (
24692 Gather_Associations (Names, Args);
24695 for J in 1 .. 2 loop
24696 if Present (Args (J)) then
24697 Check_Arg_Is_OK_Static_Expression
24698 (Args (J), Standard_String);
24703 ----------------------------
24704 -- Type_Invariant[_Class] --
24705 ----------------------------
24707 -- pragma Type_Invariant[_Class]
24708 -- ([Entity =>] type_LOCAL_NAME,
24709 -- [Check =>] EXPRESSION);
24711 when Pragma_Type_Invariant
24712 | Pragma_Type_Invariant_Class
24714 Type_Invariant : declare
24715 I_Pragma : Node_Id;
24718 Check_Arg_Count (2);
24720 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24721 -- setting Class_Present for the Type_Invariant_Class case.
24723 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24724 I_Pragma := New_Copy (N);
24725 Set_Pragma_Identifier
24726 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24727 Rewrite (N, I_Pragma);
24728 Set_Analyzed (N, False);
24730 end Type_Invariant;
24732 ---------------------
24733 -- Unchecked_Union --
24734 ---------------------
24736 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24738 when Pragma_Unchecked_Union => Unchecked_Union : declare
24739 Assoc : constant Node_Id := Arg1;
24740 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24750 Check_No_Identifiers;
24751 Check_Arg_Count (1);
24752 Check_Arg_Is_Local_Name (Arg1);
24754 Find_Type (Type_Id);
24756 Typ := Entity (Type_Id);
24758 -- A pragma that applies to a Ghost entity becomes Ghost for the
24759 -- purposes of legality checks and removal of ignored Ghost code.
24761 Mark_Ghost_Pragma (N, Typ);
24764 or else Rep_Item_Too_Early (Typ, N)
24768 Typ := Underlying_Type (Typ);
24771 if Rep_Item_Too_Late (Typ, N) then
24775 Check_First_Subtype (Arg1);
24777 -- Note remaining cases are references to a type in the current
24778 -- declarative part. If we find an error, we post the error on
24779 -- the relevant type declaration at an appropriate point.
24781 if not Is_Record_Type (Typ) then
24782 Error_Msg_N ("unchecked union must be record type", Typ);
24785 elsif Is_Tagged_Type (Typ) then
24786 Error_Msg_N ("unchecked union must not be tagged", Typ);
24789 elsif not Has_Discriminants (Typ) then
24791 ("unchecked union must have one discriminant", Typ);
24794 -- Note: in previous versions of GNAT we used to check for limited
24795 -- types and give an error, but in fact the standard does allow
24796 -- Unchecked_Union on limited types, so this check was removed.
24798 -- Similarly, GNAT used to require that all discriminants have
24799 -- default values, but this is not mandated by the RM.
24801 -- Proceed with basic error checks completed
24804 Tdef := Type_Definition (Declaration_Node (Typ));
24805 Clist := Component_List (Tdef);
24807 -- Check presence of component list and variant part
24809 if No (Clist) or else No (Variant_Part (Clist)) then
24811 ("unchecked union must have variant part", Tdef);
24815 -- Check components
24817 Comp := First_Non_Pragma (Component_Items (Clist));
24818 while Present (Comp) loop
24819 Check_Component (Comp, Typ);
24820 Next_Non_Pragma (Comp);
24823 -- Check variant part
24825 Vpart := Variant_Part (Clist);
24827 Variant := First_Non_Pragma (Variants (Vpart));
24828 while Present (Variant) loop
24829 Check_Variant (Variant, Typ);
24830 Next_Non_Pragma (Variant);
24834 Set_Is_Unchecked_Union (Typ);
24835 Set_Convention (Typ, Convention_C);
24836 Set_Has_Unchecked_Union (Base_Type (Typ));
24837 Set_Is_Unchecked_Union (Base_Type (Typ));
24838 end Unchecked_Union;
24840 ----------------------------
24841 -- Unevaluated_Use_Of_Old --
24842 ----------------------------
24844 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24846 when Pragma_Unevaluated_Use_Of_Old =>
24848 Check_Arg_Count (1);
24849 Check_No_Identifiers;
24850 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24852 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24853 -- a declarative part or a package spec.
24855 if not Is_Configuration_Pragma then
24856 Check_Is_In_Decl_Part_Or_Package_Spec;
24859 -- Store proper setting of Uneval_Old
24861 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24862 Uneval_Old := Fold_Upper (Name_Buffer (1));
24864 ------------------------
24865 -- Unimplemented_Unit --
24866 ------------------------
24868 -- pragma Unimplemented_Unit;
24870 -- Note: this only gives an error if we are generating code, or if
24871 -- we are in a generic library unit (where the pragma appears in the
24872 -- body, not in the spec).
24874 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24875 Cunitent : constant Entity_Id :=
24876 Cunit_Entity (Get_Source_Unit (Loc));
24877 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24881 Check_Arg_Count (0);
24883 if Operating_Mode = Generate_Code
24884 or else Ent_Kind = E_Generic_Function
24885 or else Ent_Kind = E_Generic_Procedure
24886 or else Ent_Kind = E_Generic_Package
24888 Get_Name_String (Chars (Cunitent));
24889 Set_Casing (Mixed_Case);
24890 Write_Str (Name_Buffer (1 .. Name_Len));
24891 Write_Str (" is not supported in this configuration");
24893 raise Unrecoverable_Error;
24895 end Unimplemented_Unit;
24897 ------------------------
24898 -- Universal_Aliasing --
24899 ------------------------
24901 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24903 when Pragma_Universal_Aliasing => Universal_Alias : declare
24909 Check_Arg_Count (1);
24910 Check_Optional_Identifier (Arg2, Name_Entity);
24911 Check_Arg_Is_Local_Name (Arg1);
24912 E_Id := Get_Pragma_Arg (Arg1);
24914 if Etype (E_Id) = Any_Type then
24918 E := Entity (E_Id);
24920 if not Is_Type (E) then
24921 Error_Pragma_Arg ("pragma% requires type", Arg1);
24924 -- A pragma that applies to a Ghost entity becomes Ghost for the
24925 -- purposes of legality checks and removal of ignored Ghost code.
24927 Mark_Ghost_Pragma (N, E);
24928 Set_Universal_Aliasing (Base_Type (E));
24929 Record_Rep_Item (E, N);
24930 end Universal_Alias;
24932 --------------------
24933 -- Universal_Data --
24934 --------------------
24936 -- pragma Universal_Data [(library_unit_NAME)];
24938 when Pragma_Universal_Data =>
24940 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24946 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24948 when Pragma_Unmodified =>
24949 Analyze_Unmodified_Or_Unused;
24955 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24957 -- or when used in a context clause:
24959 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24961 when Pragma_Unreferenced =>
24962 Analyze_Unreferenced_Or_Unused;
24964 --------------------------
24965 -- Unreferenced_Objects --
24966 --------------------------
24968 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24970 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24972 Arg_Expr : Node_Id;
24973 Arg_Id : Entity_Id;
24975 Ghost_Error_Posted : Boolean := False;
24976 -- Flag set when an error concerning the illegal mix of Ghost and
24977 -- non-Ghost types is emitted.
24979 Ghost_Id : Entity_Id := Empty;
24980 -- The entity of the first Ghost type encountered while processing
24981 -- the arguments of the pragma.
24985 Check_At_Least_N_Arguments (1);
24988 while Present (Arg) loop
24989 Check_No_Identifier (Arg);
24990 Check_Arg_Is_Local_Name (Arg);
24991 Arg_Expr := Get_Pragma_Arg (Arg);
24993 if Is_Entity_Name (Arg_Expr) then
24994 Arg_Id := Entity (Arg_Expr);
24996 if Is_Type (Arg_Id) then
24997 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24999 -- A pragma that applies to a Ghost entity becomes Ghost
25000 -- for the purposes of legality checks and removal of
25001 -- ignored Ghost code.
25003 Mark_Ghost_Pragma (N, Arg_Id);
25005 -- Capture the entity of the first Ghost type being
25006 -- processed for error detection purposes.
25008 if Is_Ghost_Entity (Arg_Id) then
25009 if No (Ghost_Id) then
25010 Ghost_Id := Arg_Id;
25013 -- Otherwise the type is non-Ghost. It is illegal to mix
25014 -- references to Ghost and non-Ghost entities
25017 elsif Present (Ghost_Id)
25018 and then not Ghost_Error_Posted
25020 Ghost_Error_Posted := True;
25022 Error_Msg_Name_1 := Pname;
25024 ("pragma % cannot mention ghost and non-ghost types",
25027 Error_Msg_Sloc := Sloc (Ghost_Id);
25028 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25030 Error_Msg_Sloc := Sloc (Arg_Id);
25031 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25035 ("argument for pragma% must be type or subtype", Arg);
25039 ("argument for pragma% must be type or subtype", Arg);
25044 end Unreferenced_Objects;
25046 ------------------------------
25047 -- Unreserve_All_Interrupts --
25048 ------------------------------
25050 -- pragma Unreserve_All_Interrupts;
25052 when Pragma_Unreserve_All_Interrupts =>
25054 Check_Arg_Count (0);
25056 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25057 Unreserve_All_Interrupts := True;
25064 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25066 when Pragma_Unsuppress =>
25068 Process_Suppress_Unsuppress (Suppress_Case => False);
25074 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25076 when Pragma_Unused =>
25077 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25078 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25080 -------------------
25081 -- Use_VADS_Size --
25082 -------------------
25084 -- pragma Use_VADS_Size;
25086 when Pragma_Use_VADS_Size =>
25088 Check_Arg_Count (0);
25089 Check_Valid_Configuration_Pragma;
25090 Use_VADS_Size := True;
25092 ---------------------
25093 -- Validity_Checks --
25094 ---------------------
25096 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25098 when Pragma_Validity_Checks => Validity_Checks : declare
25099 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25105 Check_Arg_Count (1);
25106 Check_No_Identifiers;
25108 -- Pragma always active unless in CodePeer or GNATprove modes,
25109 -- which use a fixed configuration of validity checks.
25111 if not (CodePeer_Mode or GNATprove_Mode) then
25112 if Nkind (A) = N_String_Literal then
25116 Slen : constant Natural := Natural (String_Length (S));
25117 Options : String (1 .. Slen);
25121 -- Couldn't we use a for loop here over Options'Range???
25125 C := Get_String_Char (S, Pos (J));
25127 -- This is a weird test, it skips setting validity
25128 -- checks entirely if any element of S is out of
25129 -- range of Character, what is that about ???
25131 exit when not In_Character_Range (C);
25132 Options (J) := Get_Character (C);
25135 Set_Validity_Check_Options (Options);
25143 elsif Nkind (A) = N_Identifier then
25144 if Chars (A) = Name_All_Checks then
25145 Set_Validity_Check_Options ("a");
25146 elsif Chars (A) = Name_On then
25147 Validity_Checks_On := True;
25148 elsif Chars (A) = Name_Off then
25149 Validity_Checks_On := False;
25153 end Validity_Checks;
25159 -- pragma Volatile (LOCAL_NAME);
25161 when Pragma_Volatile =>
25162 Process_Atomic_Independent_Shared_Volatile;
25164 -------------------------
25165 -- Volatile_Components --
25166 -------------------------
25168 -- pragma Volatile_Components (array_LOCAL_NAME);
25170 -- Volatile is handled by the same circuit as Atomic_Components
25172 --------------------------
25173 -- Volatile_Full_Access --
25174 --------------------------
25176 -- pragma Volatile_Full_Access (LOCAL_NAME);
25178 when Pragma_Volatile_Full_Access =>
25180 Process_Atomic_Independent_Shared_Volatile;
25182 -----------------------
25183 -- Volatile_Function --
25184 -----------------------
25186 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25188 when Pragma_Volatile_Function => Volatile_Function : declare
25189 Over_Id : Entity_Id;
25190 Spec_Id : Entity_Id;
25191 Subp_Decl : Node_Id;
25195 Check_No_Identifiers;
25196 Check_At_Most_N_Arguments (1);
25199 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25201 -- Generic subprogram
25203 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25206 -- Body acts as spec
25208 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25209 and then No (Corresponding_Spec (Subp_Decl))
25213 -- Body stub acts as spec
25215 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25216 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25222 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25230 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25232 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
25237 -- A pragma that applies to a Ghost entity becomes Ghost for the
25238 -- purposes of legality checks and removal of ignored Ghost code.
25240 Mark_Ghost_Pragma (N, Spec_Id);
25242 -- Chain the pragma on the contract for completeness
25244 Add_Contract_Item (N, Spec_Id);
25246 -- The legality checks of pragma Volatile_Function are affected by
25247 -- the SPARK mode in effect. Analyze all pragmas in a specific
25250 Analyze_If_Present (Pragma_SPARK_Mode);
25252 -- A volatile function cannot override a non-volatile function
25253 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25254 -- in New_Overloaded_Entity, however at that point the pragma has
25255 -- not been processed yet.
25257 Over_Id := Overridden_Operation (Spec_Id);
25259 if Present (Over_Id)
25260 and then not Is_Volatile_Function (Over_Id)
25263 ("incompatible volatile function values in effect", Spec_Id);
25265 Error_Msg_Sloc := Sloc (Over_Id);
25267 ("\& declared # with Volatile_Function value False",
25270 Error_Msg_Sloc := Sloc (Spec_Id);
25272 ("\overridden # with Volatile_Function value True",
25276 -- Analyze the Boolean expression (if any)
25278 if Present (Arg1) then
25279 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25281 end Volatile_Function;
25283 ----------------------
25284 -- Warning_As_Error --
25285 ----------------------
25287 -- pragma Warning_As_Error (static_string_EXPRESSION);
25289 when Pragma_Warning_As_Error =>
25291 Check_Arg_Count (1);
25292 Check_No_Identifiers;
25293 Check_Valid_Configuration_Pragma;
25295 if not Is_Static_String_Expression (Arg1) then
25297 ("argument of pragma% must be static string expression",
25300 -- OK static string expression
25303 Acquire_Warning_Match_String (Arg1);
25304 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25305 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25306 new String'(Name_Buffer (1 .. Name_Len));
25313 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25315 -- DETAILS ::= On | Off
25316 -- DETAILS ::= On | Off, local_NAME
25317 -- DETAILS ::= static_string_EXPRESSION
25318 -- DETAILS ::= On | Off, static_string_EXPRESSION
25320 -- TOOL_NAME ::= GNAT | GNATProve
25322 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25324 -- Note: If the first argument matches an allowed tool name, it is
25325 -- always considered to be a tool name, even if there is a string
25326 -- variable of that name.
25328 -- Note if the second argument of DETAILS is a local_NAME then the
25329 -- second form is always understood. If the intention is to use
25330 -- the fourth form, then you can write NAME & "" to force the
25331 -- intepretation as a static_string_EXPRESSION.
25333 when Pragma_Warnings => Warnings : declare
25334 Reason : String_Id;
25338 Check_At_Least_N_Arguments (1);
25340 -- See if last argument is labeled Reason. If so, make sure we
25341 -- have a string literal or a concatenation of string literals,
25342 -- and acquire the REASON string. Then remove the REASON argument
25343 -- by decreasing Num_Args by one; Remaining processing looks only
25344 -- at first Num_Args arguments).
25347 Last_Arg : constant Node_Id :=
25348 Last (Pragma_Argument_Associations (N));
25351 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25352 and then Chars (Last_Arg) = Name_Reason
25355 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25356 Reason := End_String;
25357 Arg_Count := Arg_Count - 1;
25359 -- Not allowed in compiler units (bootstrap issues)
25361 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25363 -- No REASON string, set null string as reason
25366 Reason := Null_String_Id;
25370 -- Now proceed with REASON taken care of and eliminated
25372 Check_No_Identifiers;
25374 -- If debug flag -gnatd.i is set, pragma is ignored
25376 if Debug_Flag_Dot_I then
25380 -- Process various forms of the pragma
25383 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25384 Shifted_Args : List_Id;
25387 -- See if first argument is a tool name, currently either
25388 -- GNAT or GNATprove. If so, either ignore the pragma if the
25389 -- tool used does not match, or continue as if no tool name
25390 -- was given otherwise, by shifting the arguments.
25392 if Nkind (Argx) = N_Identifier
25393 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25395 if Chars (Argx) = Name_Gnat then
25396 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25397 Rewrite (N, Make_Null_Statement (Loc));
25402 elsif Chars (Argx) = Name_Gnatprove then
25403 if not GNATprove_Mode then
25404 Rewrite (N, Make_Null_Statement (Loc));
25410 raise Program_Error;
25413 -- At this point, the pragma Warnings applies to the tool,
25414 -- so continue with shifted arguments.
25416 Arg_Count := Arg_Count - 1;
25418 if Arg_Count = 1 then
25419 Shifted_Args := New_List (New_Copy (Arg2));
25420 elsif Arg_Count = 2 then
25421 Shifted_Args := New_List (New_Copy (Arg2),
25423 elsif Arg_Count = 3 then
25424 Shifted_Args := New_List (New_Copy (Arg2),
25428 raise Program_Error;
25433 Chars => Name_Warnings,
25434 Pragma_Argument_Associations => Shifted_Args));
25439 -- One argument case
25441 if Arg_Count = 1 then
25443 -- On/Off one argument case was processed by parser
25445 if Nkind (Argx) = N_Identifier
25446 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25450 -- One argument case must be ON/OFF or static string expr
25452 elsif not Is_Static_String_Expression (Arg1) then
25454 ("argument of pragma% must be On/Off or static string "
25455 & "expression", Arg1);
25457 -- One argument string expression case
25461 Lit : constant Node_Id := Expr_Value_S (Argx);
25462 Str : constant String_Id := Strval (Lit);
25463 Len : constant Nat := String_Length (Str);
25471 while J <= Len loop
25472 C := Get_String_Char (Str, J);
25473 OK := In_Character_Range (C);
25476 Chr := Get_Character (C);
25478 -- Dash case: only -Wxxx is accepted
25485 C := Get_String_Char (Str, J);
25486 Chr := Get_Character (C);
25487 exit when Chr = 'W';
25492 elsif J < Len and then Chr = '.' then
25494 C := Get_String_Char (Str, J);
25495 Chr := Get_Character (C);
25497 if not Set_Dot_Warning_Switch (Chr) then
25499 ("invalid warning switch character "
25500 & '.' & Chr, Arg1);
25506 OK := Set_Warning_Switch (Chr);
25511 ("invalid warning switch character " & Chr,
25517 ("invalid wide character in warning switch ",
25526 -- Two or more arguments (must be two)
25529 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25530 Check_Arg_Count (2);
25538 E_Id := Get_Pragma_Arg (Arg2);
25541 -- In the expansion of an inlined body, a reference to
25542 -- the formal may be wrapped in a conversion if the
25543 -- actual is a conversion. Retrieve the real entity name.
25545 if (In_Instance_Body or In_Inlined_Body)
25546 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25548 E_Id := Expression (E_Id);
25551 -- Entity name case
25553 if Is_Entity_Name (E_Id) then
25554 E := Entity (E_Id);
25561 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25564 -- Suppress elaboration warnings if the entity
25565 -- denotes an elaboration target.
25567 if Is_Elaboration_Target (E) then
25568 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25571 -- For OFF case, make entry in warnings off
25572 -- pragma table for later processing. But we do
25573 -- not do that within an instance, since these
25574 -- warnings are about what is needed in the
25575 -- template, not an instance of it.
25577 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25578 and then Warn_On_Warnings_Off
25579 and then not In_Instance
25581 Warnings_Off_Pragmas.Append ((N, E, Reason));
25584 if Is_Enumeration_Type (E) then
25588 Lit := First_Literal (E);
25589 while Present (Lit) loop
25590 Set_Warnings_Off (Lit);
25591 Next_Literal (Lit);
25596 exit when No (Homonym (E));
25601 -- Error if not entity or static string expression case
25603 elsif not Is_Static_String_Expression (Arg2) then
25605 ("second argument of pragma% must be entity name "
25606 & "or static string expression", Arg2);
25608 -- Static string expression case
25611 Acquire_Warning_Match_String (Arg2);
25613 -- Note on configuration pragma case: If this is a
25614 -- configuration pragma, then for an OFF pragma, we
25615 -- just set Config True in the call, which is all
25616 -- that needs to be done. For the case of ON, this
25617 -- is normally an error, unless it is canceling the
25618 -- effect of a previous OFF pragma in the same file.
25619 -- In any other case, an error will be signalled (ON
25620 -- with no matching OFF).
25622 -- Note: We set Used if we are inside a generic to
25623 -- disable the test that the non-config case actually
25624 -- cancels a warning. That's because we can't be sure
25625 -- there isn't an instantiation in some other unit
25626 -- where a warning is suppressed.
25628 -- We could do a little better here by checking if the
25629 -- generic unit we are inside is public, but for now
25630 -- we don't bother with that refinement.
25632 if Chars (Argx) = Name_Off then
25633 Set_Specific_Warning_Off
25634 (Loc, Name_Buffer (1 .. Name_Len), Reason,
25635 Config => Is_Configuration_Pragma,
25636 Used => Inside_A_Generic or else In_Instance);
25638 elsif Chars (Argx) = Name_On then
25639 Set_Specific_Warning_On
25640 (Loc, Name_Buffer (1 .. Name_Len), Err);
25644 ("??pragma Warnings On with no matching "
25645 & "Warnings Off", Loc);
25654 -------------------
25655 -- Weak_External --
25656 -------------------
25658 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25660 when Pragma_Weak_External => Weak_External : declare
25665 Check_Arg_Count (1);
25666 Check_Optional_Identifier (Arg1, Name_Entity);
25667 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25668 Ent := Entity (Get_Pragma_Arg (Arg1));
25670 if Rep_Item_Too_Early (Ent, N) then
25673 Ent := Underlying_Type (Ent);
25676 -- The pragma applies to entities with addresses
25678 if Is_Type (Ent) then
25679 Error_Pragma ("pragma applies to objects and subprograms");
25682 -- The only processing required is to link this item on to the
25683 -- list of rep items for the given entity. This is accomplished
25684 -- by the call to Rep_Item_Too_Late (when no error is detected
25685 -- and False is returned).
25687 if Rep_Item_Too_Late (Ent, N) then
25690 Set_Has_Gigi_Rep_Item (Ent);
25694 -----------------------------
25695 -- Wide_Character_Encoding --
25696 -----------------------------
25698 -- pragma Wide_Character_Encoding (IDENTIFIER);
25700 when Pragma_Wide_Character_Encoding =>
25703 -- Nothing to do, handled in parser. Note that we do not enforce
25704 -- configuration pragma placement, this pragma can appear at any
25705 -- place in the source, allowing mixed encodings within a single
25710 --------------------
25711 -- Unknown_Pragma --
25712 --------------------
25714 -- Should be impossible, since the case of an unknown pragma is
25715 -- separately processed before the case statement is entered.
25717 when Unknown_Pragma =>
25718 raise Program_Error;
25721 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25722 -- until AI is formally approved.
25724 -- Check_Order_Dependence;
25727 when Pragma_Exit => null;
25728 end Analyze_Pragma;
25730 ---------------------------------------------
25731 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25732 ---------------------------------------------
25734 -- WARNING: This routine manages Ghost regions. Return statements must be
25735 -- replaced by gotos which jump to the end of the routine and restore the
25738 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25740 Freeze_Id : Entity_Id := Empty)
25742 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25743 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25745 Disp_Typ : Entity_Id;
25746 -- The dispatching type of the subprogram subject to the pre- or
25749 function Check_References (Nod : Node_Id) return Traverse_Result;
25750 -- Check that expression Nod does not mention non-primitives of the
25751 -- type, global objects of the type, or other illegalities described
25752 -- and implied by AI12-0113.
25754 ----------------------
25755 -- Check_References --
25756 ----------------------
25758 function Check_References (Nod : Node_Id) return Traverse_Result is
25760 if Nkind (Nod) = N_Function_Call
25761 and then Is_Entity_Name (Name (Nod))
25764 Func : constant Entity_Id := Entity (Name (Nod));
25768 -- An operation of the type must be a primitive
25770 if No (Find_Dispatching_Type (Func)) then
25771 Form := First_Formal (Func);
25772 while Present (Form) loop
25773 if Etype (Form) = Disp_Typ then
25775 ("operation in class-wide condition must be "
25776 & "primitive of &", Nod, Disp_Typ);
25779 Next_Formal (Form);
25782 -- A return object of the type is illegal as well
25784 if Etype (Func) = Disp_Typ
25785 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25788 ("operation in class-wide condition must be primitive "
25789 & "of &", Nod, Disp_Typ);
25792 -- Otherwise we have a call to an overridden primitive, and we
25793 -- will create a common class-wide clone for the body of
25794 -- original operation and its eventual inherited versions. If
25795 -- the original operation dispatches on result it is never
25796 -- inherited and there is no need for a clone. There is not
25797 -- need for a clone either in GNATprove mode, as cases that
25798 -- would require it are rejected (when an inherited primitive
25799 -- calls an overridden operation in a class-wide contract), and
25800 -- the clone would make proof impossible in some cases.
25802 elsif not Is_Abstract_Subprogram (Spec_Id)
25803 and then No (Class_Wide_Clone (Spec_Id))
25804 and then not Has_Controlling_Result (Spec_Id)
25805 and then not GNATprove_Mode
25807 Build_Class_Wide_Clone_Decl (Spec_Id);
25811 elsif Is_Entity_Name (Nod)
25813 (Etype (Nod) = Disp_Typ
25814 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25815 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25818 ("object in class-wide condition must be formal of type &",
25821 elsif Nkind (Nod) = N_Explicit_Dereference
25822 and then (Etype (Nod) = Disp_Typ
25823 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25824 and then (not Is_Entity_Name (Prefix (Nod))
25825 or else not Is_Formal (Entity (Prefix (Nod))))
25828 ("operation in class-wide condition must be primitive of &",
25833 end Check_References;
25835 procedure Check_Class_Wide_Condition is
25836 new Traverse_Proc (Check_References);
25840 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25842 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25843 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25844 -- Save the Ghost-related attributes to restore on exit
25847 Restore_Scope : Boolean := False;
25849 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25852 -- Do not analyze the pragma multiple times
25854 if Is_Analyzed_Pragma (N) then
25858 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25859 -- analysis of the pragma, the Ghost mode at point of declaration and
25860 -- point of analysis may not necessarily be the same. Use the mode in
25861 -- effect at the point of declaration.
25863 Set_Ghost_Mode (N);
25865 -- Ensure that the subprogram and its formals are visible when analyzing
25866 -- the expression of the pragma.
25868 if not In_Open_Scopes (Spec_Id) then
25869 Restore_Scope := True;
25870 Push_Scope (Spec_Id);
25872 if Is_Generic_Subprogram (Spec_Id) then
25873 Install_Generic_Formals (Spec_Id);
25875 Install_Formals (Spec_Id);
25879 Errors := Serious_Errors_Detected;
25880 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25882 -- Emit a clarification message when the expression contains at least
25883 -- one undefined reference, possibly due to contract freezing.
25885 if Errors /= Serious_Errors_Detected
25886 and then Present (Freeze_Id)
25887 and then Has_Undefined_Reference (Expr)
25889 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25892 if Class_Present (N) then
25894 -- Verify that a class-wide condition is legal, i.e. the operation is
25895 -- a primitive of a tagged type. Note that a generic subprogram is
25896 -- not a primitive operation.
25898 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25900 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25901 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25903 if From_Aspect_Specification (N) then
25905 ("aspect % can only be specified for a primitive operation "
25906 & "of a tagged type", Corresponding_Aspect (N));
25908 -- The pragma is a source construct
25912 ("pragma % can only be specified for a primitive operation "
25913 & "of a tagged type", N);
25916 -- Remaining semantic checks require a full tree traversal
25919 Check_Class_Wide_Condition (Expr);
25924 if Restore_Scope then
25928 -- If analysis of the condition indicates that a class-wide clone
25929 -- has been created, build and analyze its declaration.
25931 if Is_Subprogram (Spec_Id)
25932 and then Present (Class_Wide_Clone (Spec_Id))
25934 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25937 -- Currently it is not possible to inline pre/postconditions on a
25938 -- subprogram subject to pragma Inline_Always.
25940 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25941 Set_Is_Analyzed_Pragma (N);
25943 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25944 end Analyze_Pre_Post_Condition_In_Decl_Part;
25946 ------------------------------------------
25947 -- Analyze_Refined_Depends_In_Decl_Part --
25948 ------------------------------------------
25950 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25951 procedure Check_Dependency_Clause
25952 (Spec_Id : Entity_Id;
25953 Dep_Clause : Node_Id;
25954 Dep_States : Elist_Id;
25955 Refinements : List_Id;
25956 Matched_Items : in out Elist_Id);
25957 -- Try to match a single dependency clause Dep_Clause against one or
25958 -- more refinement clauses found in list Refinements. Each successful
25959 -- match eliminates at least one refinement clause from Refinements.
25960 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25961 -- denotes the entities of all abstract states which appear in pragma
25962 -- Depends. Matched_Items contains the entities of all successfully
25963 -- matched items found in pragma Depends.
25965 procedure Check_Output_States
25966 (Spec_Id : Entity_Id;
25967 Spec_Inputs : Elist_Id;
25968 Spec_Outputs : Elist_Id;
25969 Body_Inputs : Elist_Id;
25970 Body_Outputs : Elist_Id);
25971 -- Determine whether pragma Depends contains an output state with a
25972 -- visible refinement and if so, ensure that pragma Refined_Depends
25973 -- mentions all its constituents as outputs. Spec_Id is the entity of
25974 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25975 -- inputs and outputs of the subprogram spec synthesized from pragma
25976 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25977 -- of the subprogram body synthesized from pragma Refined_Depends.
25979 function Collect_States (Clauses : List_Id) return Elist_Id;
25980 -- Given a normalized list of dependencies obtained from calling
25981 -- Normalize_Clauses, return a list containing the entities of all
25982 -- states appearing in dependencies. It helps in checking refinements
25983 -- involving a state and a corresponding constituent which is not a
25984 -- direct constituent of the state.
25986 procedure Normalize_Clauses (Clauses : List_Id);
25987 -- Given a list of dependence or refinement clauses Clauses, normalize
25988 -- each clause by creating multiple dependencies with exactly one input
25991 procedure Remove_Extra_Clauses
25992 (Clauses : List_Id;
25993 Matched_Items : Elist_Id);
25994 -- Given a list of refinement clauses Clauses, remove all clauses whose
25995 -- inputs and/or outputs have been previously matched. See the body for
25996 -- all special cases. Matched_Items contains the entities of all matched
25997 -- items found in pragma Depends.
25999 procedure Report_Extra_Clauses
26000 (Spec_Id : Entity_Id;
26001 Clauses : List_Id);
26002 -- Emit an error for each extra clause found in list Clauses. Spec_Id
26003 -- denotes the entity of the related subprogram.
26005 -----------------------------
26006 -- Check_Dependency_Clause --
26007 -----------------------------
26009 procedure Check_Dependency_Clause
26010 (Spec_Id : Entity_Id;
26011 Dep_Clause : Node_Id;
26012 Dep_States : Elist_Id;
26013 Refinements : List_Id;
26014 Matched_Items : in out Elist_Id)
26016 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26017 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26019 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26020 -- Determine whether dependency item Dep_Item has been matched in a
26021 -- previous clause.
26023 function Is_In_Out_State_Clause return Boolean;
26024 -- Determine whether dependence clause Dep_Clause denotes an abstract
26025 -- state that depends on itself (State => State).
26027 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26028 -- Determine whether item Item denotes an abstract state with visible
26029 -- null refinement.
26031 procedure Match_Items
26032 (Dep_Item : Node_Id;
26033 Ref_Item : Node_Id;
26034 Matched : out Boolean);
26035 -- Try to match dependence item Dep_Item against refinement item
26036 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26037 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26038 -- the following conformance scenarios is in effect:
26039 -- 1) Both items denote null
26040 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26041 -- 3) Both items denote attribute 'Result
26042 -- 4) Both items denote the same object
26043 -- 5) Both items denote the same formal parameter
26044 -- 6) Both items denote the same current instance of a type
26045 -- 7) Both items denote the same discriminant
26046 -- 8) Dep_Item is an abstract state with visible null refinement
26047 -- and Ref_Item denotes null.
26048 -- 9) Dep_Item is an abstract state with visible null refinement
26049 -- and Ref_Item is Empty (special case).
26050 -- 10) Dep_Item is an abstract state with full or partial visible
26051 -- non-null refinement and Ref_Item denotes one of its
26053 -- 11) Dep_Item is an abstract state without a full visible
26054 -- refinement and Ref_Item denotes the same state.
26055 -- When scenario 10 is in effect, the entity of the abstract state
26056 -- denoted by Dep_Item is added to list Refined_States.
26058 procedure Record_Item (Item_Id : Entity_Id);
26059 -- Store the entity of an item denoted by Item_Id in Matched_Items
26061 ------------------------
26062 -- Is_Already_Matched --
26063 ------------------------
26065 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26066 Item_Id : Entity_Id := Empty;
26069 -- When the dependency item denotes attribute 'Result, check for
26070 -- the entity of the related subprogram.
26072 if Is_Attribute_Result (Dep_Item) then
26073 Item_Id := Spec_Id;
26075 elsif Is_Entity_Name (Dep_Item) then
26076 Item_Id := Available_View (Entity_Of (Dep_Item));
26080 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26081 end Is_Already_Matched;
26083 ----------------------------
26084 -- Is_In_Out_State_Clause --
26085 ----------------------------
26087 function Is_In_Out_State_Clause return Boolean is
26088 Dep_Input_Id : Entity_Id;
26089 Dep_Output_Id : Entity_Id;
26092 -- Detect the following clause:
26095 if Is_Entity_Name (Dep_Input)
26096 and then Is_Entity_Name (Dep_Output)
26098 -- Handle abstract views generated for limited with clauses
26100 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26101 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26104 Ekind (Dep_Input_Id) = E_Abstract_State
26105 and then Dep_Input_Id = Dep_Output_Id;
26109 end Is_In_Out_State_Clause;
26111 ---------------------------
26112 -- Is_Null_Refined_State --
26113 ---------------------------
26115 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26116 Item_Id : Entity_Id;
26119 if Is_Entity_Name (Item) then
26121 -- Handle abstract views generated for limited with clauses
26123 Item_Id := Available_View (Entity_Of (Item));
26126 Ekind (Item_Id) = E_Abstract_State
26127 and then Has_Null_Visible_Refinement (Item_Id);
26131 end Is_Null_Refined_State;
26137 procedure Match_Items
26138 (Dep_Item : Node_Id;
26139 Ref_Item : Node_Id;
26140 Matched : out Boolean)
26142 Dep_Item_Id : Entity_Id;
26143 Ref_Item_Id : Entity_Id;
26146 -- Assume that the two items do not match
26150 -- A null matches null or Empty (special case)
26152 if Nkind (Dep_Item) = N_Null
26153 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26157 -- Attribute 'Result matches attribute 'Result
26159 elsif Is_Attribute_Result (Dep_Item)
26160 and then Is_Attribute_Result (Ref_Item)
26162 -- Put the entity of the related function on the list of
26163 -- matched items because attribute 'Result does not carry
26164 -- an entity similar to states and constituents.
26166 Record_Item (Spec_Id);
26169 -- Abstract states, current instances of concurrent types,
26170 -- discriminants, formal parameters and objects.
26172 elsif Is_Entity_Name (Dep_Item) then
26174 -- Handle abstract views generated for limited with clauses
26176 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26178 if Ekind (Dep_Item_Id) = E_Abstract_State then
26180 -- An abstract state with visible null refinement matches
26181 -- null or Empty (special case).
26183 if Has_Null_Visible_Refinement (Dep_Item_Id)
26184 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26186 Record_Item (Dep_Item_Id);
26189 -- An abstract state with visible non-null refinement
26190 -- matches one of its constituents, or itself for an
26191 -- abstract state with partial visible refinement.
26193 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26194 if Is_Entity_Name (Ref_Item) then
26195 Ref_Item_Id := Entity_Of (Ref_Item);
26197 if Ekind_In (Ref_Item_Id, E_Abstract_State,
26200 and then Present (Encapsulating_State (Ref_Item_Id))
26201 and then Find_Encapsulating_State
26202 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26204 Record_Item (Dep_Item_Id);
26207 elsif not Has_Visible_Refinement (Dep_Item_Id)
26208 and then Ref_Item_Id = Dep_Item_Id
26210 Record_Item (Dep_Item_Id);
26215 -- An abstract state without a visible refinement matches
26218 elsif Is_Entity_Name (Ref_Item)
26219 and then Entity_Of (Ref_Item) = Dep_Item_Id
26221 Record_Item (Dep_Item_Id);
26225 -- A current instance of a concurrent type, discriminant,
26226 -- formal parameter or an object matches itself.
26228 elsif Is_Entity_Name (Ref_Item)
26229 and then Entity_Of (Ref_Item) = Dep_Item_Id
26231 Record_Item (Dep_Item_Id);
26241 procedure Record_Item (Item_Id : Entity_Id) is
26243 if No (Matched_Items) then
26244 Matched_Items := New_Elmt_List;
26247 Append_Unique_Elmt (Item_Id, Matched_Items);
26252 Clause_Matched : Boolean := False;
26253 Dummy : Boolean := False;
26254 Inputs_Match : Boolean;
26255 Next_Ref_Clause : Node_Id;
26256 Outputs_Match : Boolean;
26257 Ref_Clause : Node_Id;
26258 Ref_Input : Node_Id;
26259 Ref_Output : Node_Id;
26261 -- Start of processing for Check_Dependency_Clause
26264 -- Do not perform this check in an instance because it was already
26265 -- performed successfully in the generic template.
26267 if Is_Generic_Instance (Spec_Id) then
26271 -- Examine all refinement clauses and compare them against the
26272 -- dependence clause.
26274 Ref_Clause := First (Refinements);
26275 while Present (Ref_Clause) loop
26276 Next_Ref_Clause := Next (Ref_Clause);
26278 -- Obtain the attributes of the current refinement clause
26280 Ref_Input := Expression (Ref_Clause);
26281 Ref_Output := First (Choices (Ref_Clause));
26283 -- The current refinement clause matches the dependence clause
26284 -- when both outputs match and both inputs match. See routine
26285 -- Match_Items for all possible conformance scenarios.
26287 -- Depends Dep_Output => Dep_Input
26291 -- Refined_Depends Ref_Output => Ref_Input
26294 (Dep_Item => Dep_Input,
26295 Ref_Item => Ref_Input,
26296 Matched => Inputs_Match);
26299 (Dep_Item => Dep_Output,
26300 Ref_Item => Ref_Output,
26301 Matched => Outputs_Match);
26303 -- An In_Out state clause may be matched against a refinement with
26304 -- a null input or null output as long as the non-null side of the
26305 -- relation contains a valid constituent of the In_Out_State.
26307 if Is_In_Out_State_Clause then
26309 -- Depends => (State => State)
26310 -- Refined_Depends => (null => Constit) -- OK
26313 and then not Outputs_Match
26314 and then Nkind (Ref_Output) = N_Null
26316 Outputs_Match := True;
26319 -- Depends => (State => State)
26320 -- Refined_Depends => (Constit => null) -- OK
26322 if not Inputs_Match
26323 and then Outputs_Match
26324 and then Nkind (Ref_Input) = N_Null
26326 Inputs_Match := True;
26330 -- The current refinement clause is legally constructed following
26331 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26332 -- the pool of candidates. The seach continues because a single
26333 -- dependence clause may have multiple matching refinements.
26335 if Inputs_Match and Outputs_Match then
26336 Clause_Matched := True;
26337 Remove (Ref_Clause);
26340 Ref_Clause := Next_Ref_Clause;
26343 -- Depending on the order or composition of refinement clauses, an
26344 -- In_Out state clause may not be directly refinable.
26346 -- Refined_State => (State => (Constit_1, Constit_2))
26347 -- Depends => ((Output, State) => (Input, State))
26348 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26350 -- Matching normalized clause (State => State) fails because there is
26351 -- no direct refinement capable of satisfying this relation. Another
26352 -- similar case arises when clauses (Constit_1 => Input) and (Output
26353 -- => Constit_2) are matched first, leaving no candidates for clause
26354 -- (State => State). Both scenarios are legal as long as one of the
26355 -- previous clauses mentioned a valid constituent of State.
26357 if not Clause_Matched
26358 and then Is_In_Out_State_Clause
26359 and then Is_Already_Matched (Dep_Input)
26361 Clause_Matched := True;
26364 -- A clause where the input is an abstract state with visible null
26365 -- refinement or a 'Result attribute is implicitly matched when the
26366 -- output has already been matched in a previous clause.
26368 -- Refined_State => (State => null)
26369 -- Depends => (Output => State) -- implicitly OK
26370 -- Refined_Depends => (Output => ...)
26371 -- Depends => (...'Result => State) -- implicitly OK
26372 -- Refined_Depends => (...'Result => ...)
26374 if not Clause_Matched
26375 and then Is_Null_Refined_State (Dep_Input)
26376 and then Is_Already_Matched (Dep_Output)
26378 Clause_Matched := True;
26381 -- A clause where the output is an abstract state with visible null
26382 -- refinement is implicitly matched when the input has already been
26383 -- matched in a previous clause.
26385 -- Refined_State => (State => null)
26386 -- Depends => (State => Input) -- implicitly OK
26387 -- Refined_Depends => (... => Input)
26389 if not Clause_Matched
26390 and then Is_Null_Refined_State (Dep_Output)
26391 and then Is_Already_Matched (Dep_Input)
26393 Clause_Matched := True;
26396 -- At this point either all refinement clauses have been examined or
26397 -- pragma Refined_Depends contains a solitary null. Only an abstract
26398 -- state with null refinement can possibly match these cases.
26400 -- Refined_State => (State => null)
26401 -- Depends => (State => null)
26402 -- Refined_Depends => null -- OK
26404 if not Clause_Matched then
26406 (Dep_Item => Dep_Input,
26408 Matched => Inputs_Match);
26411 (Dep_Item => Dep_Output,
26413 Matched => Outputs_Match);
26415 Clause_Matched := Inputs_Match and Outputs_Match;
26418 -- If the contents of Refined_Depends are legal, then the current
26419 -- dependence clause should be satisfied either by an explicit match
26420 -- or by one of the special cases.
26422 if not Clause_Matched then
26424 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26425 & "matching refinement in body"), Dep_Clause, Spec_Id);
26427 end Check_Dependency_Clause;
26429 -------------------------
26430 -- Check_Output_States --
26431 -------------------------
26433 procedure Check_Output_States
26434 (Spec_Id : Entity_Id;
26435 Spec_Inputs : Elist_Id;
26436 Spec_Outputs : Elist_Id;
26437 Body_Inputs : Elist_Id;
26438 Body_Outputs : Elist_Id)
26440 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26441 -- Determine whether all constituents of state State_Id with full
26442 -- visible refinement are used as outputs in pragma Refined_Depends.
26443 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26445 -----------------------------
26446 -- Check_Constituent_Usage --
26447 -----------------------------
26449 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26450 Constits : constant Elist_Id :=
26451 Partial_Refinement_Constituents (State_Id);
26452 Constit_Elmt : Elmt_Id;
26453 Constit_Id : Entity_Id;
26454 Only_Partial : constant Boolean :=
26455 not Has_Visible_Refinement (State_Id);
26456 Posted : Boolean := False;
26459 if Present (Constits) then
26460 Constit_Elmt := First_Elmt (Constits);
26461 while Present (Constit_Elmt) loop
26462 Constit_Id := Node (Constit_Elmt);
26464 -- Issue an error when a constituent of State_Id is used,
26465 -- and State_Id has only partial visible refinement
26466 -- (SPARK RM 7.2.4(3d)).
26468 if Only_Partial then
26469 if (Present (Body_Inputs)
26470 and then Appears_In (Body_Inputs, Constit_Id))
26472 (Present (Body_Outputs)
26473 and then Appears_In (Body_Outputs, Constit_Id))
26475 Error_Msg_Name_1 := Chars (State_Id);
26477 ("constituent & of state % cannot be used in "
26478 & "dependence refinement", N, Constit_Id);
26479 Error_Msg_Name_1 := Chars (State_Id);
26480 SPARK_Msg_N ("\use state % instead", N);
26483 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26485 elsif Present (Body_Inputs)
26486 and then Appears_In (Body_Inputs, Constit_Id)
26488 Error_Msg_Name_1 := Chars (State_Id);
26490 ("constituent & of state % must act as output in "
26491 & "dependence refinement", N, Constit_Id);
26493 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26495 elsif No (Body_Outputs)
26496 or else not Appears_In (Body_Outputs, Constit_Id)
26501 ("output state & must be replaced by all its "
26502 & "constituents in dependence refinement",
26507 ("\constituent & is missing in output list",
26511 Next_Elmt (Constit_Elmt);
26514 end Check_Constituent_Usage;
26519 Item_Elmt : Elmt_Id;
26520 Item_Id : Entity_Id;
26522 -- Start of processing for Check_Output_States
26525 -- Do not perform this check in an instance because it was already
26526 -- performed successfully in the generic template.
26528 if Is_Generic_Instance (Spec_Id) then
26531 -- Inspect the outputs of pragma Depends looking for a state with a
26532 -- visible refinement.
26534 elsif Present (Spec_Outputs) then
26535 Item_Elmt := First_Elmt (Spec_Outputs);
26536 while Present (Item_Elmt) loop
26537 Item := Node (Item_Elmt);
26539 -- Deal with the mixed nature of the input and output lists
26541 if Nkind (Item) = N_Defining_Identifier then
26544 Item_Id := Available_View (Entity_Of (Item));
26547 if Ekind (Item_Id) = E_Abstract_State then
26549 -- The state acts as an input-output, skip it
26551 if Present (Spec_Inputs)
26552 and then Appears_In (Spec_Inputs, Item_Id)
26556 -- Ensure that all of the constituents are utilized as
26557 -- outputs in pragma Refined_Depends.
26559 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26560 Check_Constituent_Usage (Item_Id);
26564 Next_Elmt (Item_Elmt);
26567 end Check_Output_States;
26569 --------------------
26570 -- Collect_States --
26571 --------------------
26573 function Collect_States (Clauses : List_Id) return Elist_Id is
26574 procedure Collect_State
26576 States : in out Elist_Id);
26577 -- Add the entity of Item to list States when it denotes to a state
26579 -------------------
26580 -- Collect_State --
26581 -------------------
26583 procedure Collect_State
26585 States : in out Elist_Id)
26590 if Is_Entity_Name (Item) then
26591 Id := Entity_Of (Item);
26593 if Ekind (Id) = E_Abstract_State then
26594 if No (States) then
26595 States := New_Elmt_List;
26598 Append_Unique_Elmt (Id, States);
26608 States : Elist_Id := No_Elist;
26610 -- Start of processing for Collect_States
26613 Clause := First (Clauses);
26614 while Present (Clause) loop
26615 Input := Expression (Clause);
26616 Output := First (Choices (Clause));
26618 Collect_State (Input, States);
26619 Collect_State (Output, States);
26625 end Collect_States;
26627 -----------------------
26628 -- Normalize_Clauses --
26629 -----------------------
26631 procedure Normalize_Clauses (Clauses : List_Id) is
26632 procedure Normalize_Inputs (Clause : Node_Id);
26633 -- Normalize clause Clause by creating multiple clauses for each
26634 -- input item of Clause. It is assumed that Clause has exactly one
26635 -- output. The transformation is as follows:
26637 -- Output => (Input_1, Input_2) -- original
26639 -- Output => Input_1 -- normalizations
26640 -- Output => Input_2
26642 procedure Normalize_Outputs (Clause : Node_Id);
26643 -- Normalize clause Clause by creating multiple clause for each
26644 -- output item of Clause. The transformation is as follows:
26646 -- (Output_1, Output_2) => Input -- original
26648 -- Output_1 => Input -- normalization
26649 -- Output_2 => Input
26651 ----------------------
26652 -- Normalize_Inputs --
26653 ----------------------
26655 procedure Normalize_Inputs (Clause : Node_Id) is
26656 Inputs : constant Node_Id := Expression (Clause);
26657 Loc : constant Source_Ptr := Sloc (Clause);
26658 Output : constant List_Id := Choices (Clause);
26659 Last_Input : Node_Id;
26661 New_Clause : Node_Id;
26662 Next_Input : Node_Id;
26665 -- Normalization is performed only when the original clause has
26666 -- more than one input. Multiple inputs appear as an aggregate.
26668 if Nkind (Inputs) = N_Aggregate then
26669 Last_Input := Last (Expressions (Inputs));
26671 -- Create a new clause for each input
26673 Input := First (Expressions (Inputs));
26674 while Present (Input) loop
26675 Next_Input := Next (Input);
26677 -- Unhook the current input from the original input list
26678 -- because it will be relocated to a new clause.
26682 -- Special processing for the last input. At this point the
26683 -- original aggregate has been stripped down to one element.
26684 -- Replace the aggregate by the element itself.
26686 if Input = Last_Input then
26687 Rewrite (Inputs, Input);
26689 -- Generate a clause of the form:
26694 Make_Component_Association (Loc,
26695 Choices => New_Copy_List_Tree (Output),
26696 Expression => Input);
26698 -- The new clause contains replicated content that has
26699 -- already been analyzed, mark the clause as analyzed.
26701 Set_Analyzed (New_Clause);
26702 Insert_After (Clause, New_Clause);
26705 Input := Next_Input;
26708 end Normalize_Inputs;
26710 -----------------------
26711 -- Normalize_Outputs --
26712 -----------------------
26714 procedure Normalize_Outputs (Clause : Node_Id) is
26715 Inputs : constant Node_Id := Expression (Clause);
26716 Loc : constant Source_Ptr := Sloc (Clause);
26717 Outputs : constant Node_Id := First (Choices (Clause));
26718 Last_Output : Node_Id;
26719 New_Clause : Node_Id;
26720 Next_Output : Node_Id;
26724 -- Multiple outputs appear as an aggregate. Nothing to do when
26725 -- the clause has exactly one output.
26727 if Nkind (Outputs) = N_Aggregate then
26728 Last_Output := Last (Expressions (Outputs));
26730 -- Create a clause for each output. Note that each time a new
26731 -- clause is created, the original output list slowly shrinks
26732 -- until there is one item left.
26734 Output := First (Expressions (Outputs));
26735 while Present (Output) loop
26736 Next_Output := Next (Output);
26738 -- Unhook the output from the original output list as it
26739 -- will be relocated to a new clause.
26743 -- Special processing for the last output. At this point
26744 -- the original aggregate has been stripped down to one
26745 -- element. Replace the aggregate by the element itself.
26747 if Output = Last_Output then
26748 Rewrite (Outputs, Output);
26751 -- Generate a clause of the form:
26752 -- (Output => Inputs)
26755 Make_Component_Association (Loc,
26756 Choices => New_List (Output),
26757 Expression => New_Copy_Tree (Inputs));
26759 -- The new clause contains replicated content that has
26760 -- already been analyzed. There is not need to reanalyze
26763 Set_Analyzed (New_Clause);
26764 Insert_After (Clause, New_Clause);
26767 Output := Next_Output;
26770 end Normalize_Outputs;
26776 -- Start of processing for Normalize_Clauses
26779 Clause := First (Clauses);
26780 while Present (Clause) loop
26781 Normalize_Outputs (Clause);
26785 Clause := First (Clauses);
26786 while Present (Clause) loop
26787 Normalize_Inputs (Clause);
26790 end Normalize_Clauses;
26792 --------------------------
26793 -- Remove_Extra_Clauses --
26794 --------------------------
26796 procedure Remove_Extra_Clauses
26797 (Clauses : List_Id;
26798 Matched_Items : Elist_Id)
26802 Input_Id : Entity_Id;
26803 Next_Clause : Node_Id;
26805 State_Id : Entity_Id;
26808 Clause := First (Clauses);
26809 while Present (Clause) loop
26810 Next_Clause := Next (Clause);
26812 Input := Expression (Clause);
26813 Output := First (Choices (Clause));
26815 -- Recognize a clause of the form
26819 -- where Input is a constituent of a state which was already
26820 -- successfully matched. This clause must be removed because it
26821 -- simply indicates that some of the constituents of the state
26824 -- Refined_State => (State => (Constit_1, Constit_2))
26825 -- Depends => (Output => State)
26826 -- Refined_Depends => ((Output => Constit_1), -- State matched
26827 -- (null => Constit_2)) -- OK
26829 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26831 -- Handle abstract views generated for limited with clauses
26833 Input_Id := Available_View (Entity_Of (Input));
26835 -- The input must be a constituent of a state
26837 if Ekind_In (Input_Id, E_Abstract_State,
26840 and then Present (Encapsulating_State (Input_Id))
26842 State_Id := Encapsulating_State (Input_Id);
26844 -- The state must have a non-null visible refinement and be
26845 -- matched in a previous clause.
26847 if Has_Non_Null_Visible_Refinement (State_Id)
26848 and then Contains (Matched_Items, State_Id)
26854 -- Recognize a clause of the form
26858 -- where Output is an arbitrary item. This clause must be removed
26859 -- because a null input legitimately matches anything.
26861 elsif Nkind (Input) = N_Null then
26865 Clause := Next_Clause;
26867 end Remove_Extra_Clauses;
26869 --------------------------
26870 -- Report_Extra_Clauses --
26871 --------------------------
26873 procedure Report_Extra_Clauses
26874 (Spec_Id : Entity_Id;
26880 -- Do not perform this check in an instance because it was already
26881 -- performed successfully in the generic template.
26883 if Is_Generic_Instance (Spec_Id) then
26886 elsif Present (Clauses) then
26887 Clause := First (Clauses);
26888 while Present (Clause) loop
26890 ("unmatched or extra clause in dependence refinement",
26896 end Report_Extra_Clauses;
26900 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26901 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26902 Errors : constant Nat := Serious_Errors_Detected;
26909 Body_Inputs : Elist_Id := No_Elist;
26910 Body_Outputs : Elist_Id := No_Elist;
26911 -- The inputs and outputs of the subprogram body synthesized from pragma
26912 -- Refined_Depends.
26914 Dependencies : List_Id := No_List;
26916 -- The corresponding Depends pragma along with its clauses
26918 Matched_Items : Elist_Id := No_Elist;
26919 -- A list containing the entities of all successfully matched items
26920 -- found in pragma Depends.
26922 Refinements : List_Id := No_List;
26923 -- The clauses of pragma Refined_Depends
26925 Spec_Id : Entity_Id;
26926 -- The entity of the subprogram subject to pragma Refined_Depends
26928 Spec_Inputs : Elist_Id := No_Elist;
26929 Spec_Outputs : Elist_Id := No_Elist;
26930 -- The inputs and outputs of the subprogram spec synthesized from pragma
26933 States : Elist_Id := No_Elist;
26934 -- A list containing the entities of all states whose constituents
26935 -- appear in pragma Depends.
26937 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26940 -- Do not analyze the pragma multiple times
26942 if Is_Analyzed_Pragma (N) then
26946 Spec_Id := Unique_Defining_Entity (Body_Decl);
26948 -- Use the anonymous object as the proper spec when Refined_Depends
26949 -- applies to the body of a single task type. The object carries the
26950 -- proper Chars as well as all non-refined versions of pragmas.
26952 if Is_Single_Concurrent_Type (Spec_Id) then
26953 Spec_Id := Anonymous_Object (Spec_Id);
26956 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26958 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26959 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26961 if No (Depends) then
26963 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26964 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26968 Deps := Expression (Get_Argument (Depends, Spec_Id));
26970 -- A null dependency relation renders the refinement useless because it
26971 -- cannot possibly mention abstract states with visible refinement. Note
26972 -- that the inverse is not true as states may be refined to null
26973 -- (SPARK RM 7.2.5(2)).
26975 if Nkind (Deps) = N_Null then
26977 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26978 & "depend on abstract state with visible refinement"), N, Spec_Id);
26982 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26983 -- This ensures that the categorization of all refined dependency items
26984 -- is consistent with their role.
26986 Analyze_Depends_In_Decl_Part (N);
26988 -- Do not match dependencies against refinements if Refined_Depends is
26989 -- illegal to avoid emitting misleading error.
26991 if Serious_Errors_Detected = Errors then
26993 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26994 -- the inputs and outputs of the subprogram spec and body to verify
26995 -- the use of states with visible refinement and their constituents.
26997 if No (Get_Pragma (Spec_Id, Pragma_Global))
26998 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
27000 Collect_Subprogram_Inputs_Outputs
27001 (Subp_Id => Spec_Id,
27002 Synthesize => True,
27003 Subp_Inputs => Spec_Inputs,
27004 Subp_Outputs => Spec_Outputs,
27005 Global_Seen => Dummy);
27007 Collect_Subprogram_Inputs_Outputs
27008 (Subp_Id => Body_Id,
27009 Synthesize => True,
27010 Subp_Inputs => Body_Inputs,
27011 Subp_Outputs => Body_Outputs,
27012 Global_Seen => Dummy);
27014 -- For an output state with a visible refinement, ensure that all
27015 -- constituents appear as outputs in the dependency refinement.
27017 Check_Output_States
27018 (Spec_Id => Spec_Id,
27019 Spec_Inputs => Spec_Inputs,
27020 Spec_Outputs => Spec_Outputs,
27021 Body_Inputs => Body_Inputs,
27022 Body_Outputs => Body_Outputs);
27025 -- Matching is disabled in ASIS because clauses are not normalized as
27026 -- this is a tree altering activity similar to expansion.
27032 -- Multiple dependency clauses appear as component associations of an
27033 -- aggregate. Note that the clauses are copied because the algorithm
27034 -- modifies them and this should not be visible in Depends.
27036 pragma Assert (Nkind (Deps) = N_Aggregate);
27037 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
27038 Normalize_Clauses (Dependencies);
27040 -- Gather all states which appear in Depends
27042 States := Collect_States (Dependencies);
27044 Refs := Expression (Get_Argument (N, Spec_Id));
27046 if Nkind (Refs) = N_Null then
27047 Refinements := No_List;
27049 -- Multiple dependency clauses appear as component associations of an
27050 -- aggregate. Note that the clauses are copied because the algorithm
27051 -- modifies them and this should not be visible in Refined_Depends.
27053 else pragma Assert (Nkind (Refs) = N_Aggregate);
27054 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27055 Normalize_Clauses (Refinements);
27058 -- At this point the clauses of pragmas Depends and Refined_Depends
27059 -- have been normalized into simple dependencies between one output
27060 -- and one input. Examine all clauses of pragma Depends looking for
27061 -- matching clauses in pragma Refined_Depends.
27063 Clause := First (Dependencies);
27064 while Present (Clause) loop
27065 Check_Dependency_Clause
27066 (Spec_Id => Spec_Id,
27067 Dep_Clause => Clause,
27068 Dep_States => States,
27069 Refinements => Refinements,
27070 Matched_Items => Matched_Items);
27075 -- Pragma Refined_Depends may contain multiple clarification clauses
27076 -- which indicate that certain constituents do not influence the data
27077 -- flow in any way. Such clauses must be removed as long as the state
27078 -- has been matched, otherwise they will be incorrectly flagged as
27081 -- Refined_State => (State => (Constit_1, Constit_2))
27082 -- Depends => (Output => State)
27083 -- Refined_Depends => ((Output => Constit_1), -- State matched
27084 -- (null => Constit_2)) -- must be removed
27086 Remove_Extra_Clauses (Refinements, Matched_Items);
27088 if Serious_Errors_Detected = Errors then
27089 Report_Extra_Clauses (Spec_Id, Refinements);
27094 Set_Is_Analyzed_Pragma (N);
27095 end Analyze_Refined_Depends_In_Decl_Part;
27097 -----------------------------------------
27098 -- Analyze_Refined_Global_In_Decl_Part --
27099 -----------------------------------------
27101 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27103 -- The corresponding Global pragma
27105 Has_In_State : Boolean := False;
27106 Has_In_Out_State : Boolean := False;
27107 Has_Out_State : Boolean := False;
27108 Has_Proof_In_State : Boolean := False;
27109 -- These flags are set when the corresponding Global pragma has a state
27110 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27113 Has_Null_State : Boolean := False;
27114 -- This flag is set when the corresponding Global pragma has at least
27115 -- one state with a null refinement.
27117 In_Constits : Elist_Id := No_Elist;
27118 In_Out_Constits : Elist_Id := No_Elist;
27119 Out_Constits : Elist_Id := No_Elist;
27120 Proof_In_Constits : Elist_Id := No_Elist;
27121 -- These lists contain the entities of all Input, In_Out, Output and
27122 -- Proof_In constituents that appear in Refined_Global and participate
27123 -- in state refinement.
27125 In_Items : Elist_Id := No_Elist;
27126 In_Out_Items : Elist_Id := No_Elist;
27127 Out_Items : Elist_Id := No_Elist;
27128 Proof_In_Items : Elist_Id := No_Elist;
27129 -- These lists contain the entities of all Input, In_Out, Output and
27130 -- Proof_In items defined in the corresponding Global pragma.
27132 Repeat_Items : Elist_Id := No_Elist;
27133 -- A list of all global items without full visible refinement found
27134 -- in pragma Global. These states should be repeated in the global
27135 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27136 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27138 Spec_Id : Entity_Id;
27139 -- The entity of the subprogram subject to pragma Refined_Global
27141 States : Elist_Id := No_Elist;
27142 -- A list of all states with full or partial visible refinement found in
27145 procedure Check_In_Out_States;
27146 -- Determine whether the corresponding Global pragma mentions In_Out
27147 -- states with visible refinement and if so, ensure that one of the
27148 -- following completions apply to the constituents of the state:
27149 -- 1) there is at least one constituent of mode In_Out
27150 -- 2) there is at least one Input and one Output constituent
27151 -- 3) not all constituents are present and one of them is of mode
27153 -- This routine may remove elements from In_Constits, In_Out_Constits,
27154 -- Out_Constits and Proof_In_Constits.
27156 procedure Check_Input_States;
27157 -- Determine whether the corresponding Global pragma mentions Input
27158 -- states with visible refinement and if so, ensure that at least one of
27159 -- its constituents appears as an Input item in Refined_Global.
27160 -- This routine may remove elements from In_Constits, In_Out_Constits,
27161 -- Out_Constits and Proof_In_Constits.
27163 procedure Check_Output_States;
27164 -- Determine whether the corresponding Global pragma mentions Output
27165 -- states with visible refinement and if so, ensure that all of its
27166 -- constituents appear as Output items in Refined_Global.
27167 -- This routine may remove elements from In_Constits, In_Out_Constits,
27168 -- Out_Constits and Proof_In_Constits.
27170 procedure Check_Proof_In_States;
27171 -- Determine whether the corresponding Global pragma mentions Proof_In
27172 -- states with visible refinement and if so, ensure that at least one of
27173 -- its constituents appears as a Proof_In item in Refined_Global.
27174 -- This routine may remove elements from In_Constits, In_Out_Constits,
27175 -- Out_Constits and Proof_In_Constits.
27177 procedure Check_Refined_Global_List
27179 Global_Mode : Name_Id := Name_Input);
27180 -- Verify the legality of a single global list declaration. Global_Mode
27181 -- denotes the current mode in effect.
27183 procedure Collect_Global_Items
27185 Mode : Name_Id := Name_Input);
27186 -- Gather all Input, In_Out, Output and Proof_In items from node List
27187 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27188 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27189 -- and Has_Proof_In_State are set when there is at least one abstract
27190 -- state with full or partial visible refinement available in the
27191 -- corresponding mode. Flag Has_Null_State is set when at least state
27192 -- has a null refinement. Mode denotes the current global mode in
27195 function Present_Then_Remove
27197 Item : Entity_Id) return Boolean;
27198 -- Search List for a particular entity Item. If Item has been found,
27199 -- remove it from List. This routine is used to strip lists In_Constits,
27200 -- In_Out_Constits and Out_Constits of valid constituents.
27202 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27203 -- Same as function Present_Then_Remove, but do not report the presence
27204 -- of Item in List.
27206 procedure Report_Extra_Constituents;
27207 -- Emit an error for each constituent found in lists In_Constits,
27208 -- In_Out_Constits and Out_Constits.
27210 procedure Report_Missing_Items;
27211 -- Emit an error for each global item not repeated found in list
27214 -------------------------
27215 -- Check_In_Out_States --
27216 -------------------------
27218 procedure Check_In_Out_States is
27219 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27220 -- Determine whether one of the following coverage scenarios is in
27222 -- 1) there is at least one constituent of mode In_Out or Output
27223 -- 2) there is at least one pair of constituents with modes Input
27224 -- and Output, or Proof_In and Output.
27225 -- 3) there is at least one constituent of mode Output and not all
27226 -- constituents are present.
27227 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27229 -----------------------------
27230 -- Check_Constituent_Usage --
27231 -----------------------------
27233 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27234 Constits : constant Elist_Id :=
27235 Partial_Refinement_Constituents (State_Id);
27236 Constit_Elmt : Elmt_Id;
27237 Constit_Id : Entity_Id;
27238 Has_Missing : Boolean := False;
27239 In_Out_Seen : Boolean := False;
27240 Input_Seen : Boolean := False;
27241 Output_Seen : Boolean := False;
27242 Proof_In_Seen : Boolean := False;
27245 -- Process all the constituents of the state and note their modes
27246 -- within the global refinement.
27248 if Present (Constits) then
27249 Constit_Elmt := First_Elmt (Constits);
27250 while Present (Constit_Elmt) loop
27251 Constit_Id := Node (Constit_Elmt);
27253 if Present_Then_Remove (In_Constits, Constit_Id) then
27254 Input_Seen := True;
27256 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27257 In_Out_Seen := True;
27259 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27260 Output_Seen := True;
27262 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27264 Proof_In_Seen := True;
27267 Has_Missing := True;
27270 Next_Elmt (Constit_Elmt);
27274 -- An In_Out constituent is a valid completion
27276 if In_Out_Seen then
27279 -- A pair of one Input/Proof_In and one Output constituent is a
27280 -- valid completion.
27282 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27285 elsif Output_Seen then
27287 -- A single Output constituent is a valid completion only when
27288 -- some of the other constituents are missing.
27290 if Has_Missing then
27293 -- Otherwise all constituents are of mode Output
27297 ("global refinement of state & must include at least one "
27298 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27302 -- The state lacks a completion. When full refinement is visible,
27303 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27304 -- refinement is visible, emit an error if the abstract state
27305 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27306 -- both are utilized, Check_State_And_Constituent_Use. will issue
27309 elsif not Input_Seen
27310 and then not In_Out_Seen
27311 and then not Output_Seen
27312 and then not Proof_In_Seen
27314 if Has_Visible_Refinement (State_Id)
27315 or else Contains (Repeat_Items, State_Id)
27318 ("missing global refinement of state &", N, State_Id);
27321 -- Otherwise the state has a malformed completion where at least
27322 -- one of the constituents has a different mode.
27326 ("global refinement of state & redefines the mode of its "
27327 & "constituents", N, State_Id);
27329 end Check_Constituent_Usage;
27333 Item_Elmt : Elmt_Id;
27334 Item_Id : Entity_Id;
27336 -- Start of processing for Check_In_Out_States
27339 -- Do not perform this check in an instance because it was already
27340 -- performed successfully in the generic template.
27342 if Is_Generic_Instance (Spec_Id) then
27345 -- Inspect the In_Out items of the corresponding Global pragma
27346 -- looking for a state with a visible refinement.
27348 elsif Has_In_Out_State and then Present (In_Out_Items) then
27349 Item_Elmt := First_Elmt (In_Out_Items);
27350 while Present (Item_Elmt) loop
27351 Item_Id := Node (Item_Elmt);
27353 -- Ensure that one of the three coverage variants is satisfied
27355 if Ekind (Item_Id) = E_Abstract_State
27356 and then Has_Non_Null_Visible_Refinement (Item_Id)
27358 Check_Constituent_Usage (Item_Id);
27361 Next_Elmt (Item_Elmt);
27364 end Check_In_Out_States;
27366 ------------------------
27367 -- Check_Input_States --
27368 ------------------------
27370 procedure Check_Input_States is
27371 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27372 -- Determine whether at least one constituent of state State_Id with
27373 -- full or partial visible refinement is used and has mode Input.
27374 -- Ensure that the remaining constituents do not have In_Out or
27375 -- Output modes. Emit an error if this is not the case
27376 -- (SPARK RM 7.2.4(5)).
27378 -----------------------------
27379 -- Check_Constituent_Usage --
27380 -----------------------------
27382 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27383 Constits : constant Elist_Id :=
27384 Partial_Refinement_Constituents (State_Id);
27385 Constit_Elmt : Elmt_Id;
27386 Constit_Id : Entity_Id;
27387 In_Seen : Boolean := False;
27390 if Present (Constits) then
27391 Constit_Elmt := First_Elmt (Constits);
27392 while Present (Constit_Elmt) loop
27393 Constit_Id := Node (Constit_Elmt);
27395 -- At least one of the constituents appears as an Input
27397 if Present_Then_Remove (In_Constits, Constit_Id) then
27400 -- A Proof_In constituent can refine an Input state as long
27401 -- as there is at least one Input constituent present.
27403 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27407 -- The constituent appears in the global refinement, but has
27408 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27410 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27411 or else Present_Then_Remove (Out_Constits, Constit_Id)
27413 Error_Msg_Name_1 := Chars (State_Id);
27415 ("constituent & of state % must have mode `Input` in "
27416 & "global refinement", N, Constit_Id);
27419 Next_Elmt (Constit_Elmt);
27423 -- Not one of the constituents appeared as Input. Always emit an
27424 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27425 -- When only partial refinement is visible, emit an error if the
27426 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27427 -- the case where both are utilized, an error will be issued in
27428 -- Check_State_And_Constituent_Use.
27431 and then (Has_Visible_Refinement (State_Id)
27432 or else Contains (Repeat_Items, State_Id))
27435 ("global refinement of state & must include at least one "
27436 & "constituent of mode `Input`", N, State_Id);
27438 end Check_Constituent_Usage;
27442 Item_Elmt : Elmt_Id;
27443 Item_Id : Entity_Id;
27445 -- Start of processing for Check_Input_States
27448 -- Do not perform this check in an instance because it was already
27449 -- performed successfully in the generic template.
27451 if Is_Generic_Instance (Spec_Id) then
27454 -- Inspect the Input items of the corresponding Global pragma looking
27455 -- for a state with a visible refinement.
27457 elsif Has_In_State and then Present (In_Items) then
27458 Item_Elmt := First_Elmt (In_Items);
27459 while Present (Item_Elmt) loop
27460 Item_Id := Node (Item_Elmt);
27462 -- When full refinement is visible, ensure that at least one of
27463 -- the constituents is utilized and is of mode Input. When only
27464 -- partial refinement is visible, ensure that either one of
27465 -- the constituents is utilized and is of mode Input, or the
27466 -- abstract state is repeated and no constituent is utilized.
27468 if Ekind (Item_Id) = E_Abstract_State
27469 and then Has_Non_Null_Visible_Refinement (Item_Id)
27471 Check_Constituent_Usage (Item_Id);
27474 Next_Elmt (Item_Elmt);
27477 end Check_Input_States;
27479 -------------------------
27480 -- Check_Output_States --
27481 -------------------------
27483 procedure Check_Output_States is
27484 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27485 -- Determine whether all constituents of state State_Id with full
27486 -- visible refinement are used and have mode Output. Emit an error
27487 -- if this is not the case (SPARK RM 7.2.4(5)).
27489 -----------------------------
27490 -- Check_Constituent_Usage --
27491 -----------------------------
27493 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27494 Constits : constant Elist_Id :=
27495 Partial_Refinement_Constituents (State_Id);
27496 Only_Partial : constant Boolean :=
27497 not Has_Visible_Refinement (State_Id);
27498 Constit_Elmt : Elmt_Id;
27499 Constit_Id : Entity_Id;
27500 Posted : Boolean := False;
27503 if Present (Constits) then
27504 Constit_Elmt := First_Elmt (Constits);
27505 while Present (Constit_Elmt) loop
27506 Constit_Id := Node (Constit_Elmt);
27508 -- Issue an error when a constituent of State_Id is utilized
27509 -- and State_Id has only partial visible refinement
27510 -- (SPARK RM 7.2.4(3d)).
27512 if Only_Partial then
27513 if Present_Then_Remove (Out_Constits, Constit_Id)
27514 or else Present_Then_Remove (In_Constits, Constit_Id)
27516 Present_Then_Remove (In_Out_Constits, Constit_Id)
27518 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27520 Error_Msg_Name_1 := Chars (State_Id);
27522 ("constituent & of state % cannot be used in global "
27523 & "refinement", N, Constit_Id);
27524 Error_Msg_Name_1 := Chars (State_Id);
27525 SPARK_Msg_N ("\use state % instead", N);
27528 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27531 -- The constituent appears in the global refinement, but has
27532 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27534 elsif Present_Then_Remove (In_Constits, Constit_Id)
27535 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27536 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27538 Error_Msg_Name_1 := Chars (State_Id);
27540 ("constituent & of state % must have mode `Output` in "
27541 & "global refinement", N, Constit_Id);
27543 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27549 ("`Output` state & must be replaced by all its "
27550 & "constituents in global refinement", N, State_Id);
27554 ("\constituent & is missing in output list",
27558 Next_Elmt (Constit_Elmt);
27561 end Check_Constituent_Usage;
27565 Item_Elmt : Elmt_Id;
27566 Item_Id : Entity_Id;
27568 -- Start of processing for Check_Output_States
27571 -- Do not perform this check in an instance because it was already
27572 -- performed successfully in the generic template.
27574 if Is_Generic_Instance (Spec_Id) then
27577 -- Inspect the Output items of the corresponding Global pragma
27578 -- looking for a state with a visible refinement.
27580 elsif Has_Out_State and then Present (Out_Items) then
27581 Item_Elmt := First_Elmt (Out_Items);
27582 while Present (Item_Elmt) loop
27583 Item_Id := Node (Item_Elmt);
27585 -- When full refinement is visible, ensure that all of the
27586 -- constituents are utilized and they have mode Output. When
27587 -- only partial refinement is visible, ensure that no
27588 -- constituent is utilized.
27590 if Ekind (Item_Id) = E_Abstract_State
27591 and then Has_Non_Null_Visible_Refinement (Item_Id)
27593 Check_Constituent_Usage (Item_Id);
27596 Next_Elmt (Item_Elmt);
27599 end Check_Output_States;
27601 ---------------------------
27602 -- Check_Proof_In_States --
27603 ---------------------------
27605 procedure Check_Proof_In_States is
27606 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27607 -- Determine whether at least one constituent of state State_Id with
27608 -- full or partial visible refinement is used and has mode Proof_In.
27609 -- Ensure that the remaining constituents do not have Input, In_Out,
27610 -- or Output modes. Emit an error if this is not the case
27611 -- (SPARK RM 7.2.4(5)).
27613 -----------------------------
27614 -- Check_Constituent_Usage --
27615 -----------------------------
27617 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27618 Constits : constant Elist_Id :=
27619 Partial_Refinement_Constituents (State_Id);
27620 Constit_Elmt : Elmt_Id;
27621 Constit_Id : Entity_Id;
27622 Proof_In_Seen : Boolean := False;
27625 if Present (Constits) then
27626 Constit_Elmt := First_Elmt (Constits);
27627 while Present (Constit_Elmt) loop
27628 Constit_Id := Node (Constit_Elmt);
27630 -- At least one of the constituents appears as Proof_In
27632 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27633 Proof_In_Seen := True;
27635 -- The constituent appears in the global refinement, but has
27636 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27638 elsif Present_Then_Remove (In_Constits, Constit_Id)
27639 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27640 or else Present_Then_Remove (Out_Constits, Constit_Id)
27642 Error_Msg_Name_1 := Chars (State_Id);
27644 ("constituent & of state % must have mode `Proof_In` "
27645 & "in global refinement", N, Constit_Id);
27648 Next_Elmt (Constit_Elmt);
27652 -- Not one of the constituents appeared as Proof_In. Always emit
27653 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27654 -- When only partial refinement is visible, emit an error if the
27655 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27656 -- the case where both are utilized, an error will be issued by
27657 -- Check_State_And_Constituent_Use.
27659 if not Proof_In_Seen
27660 and then (Has_Visible_Refinement (State_Id)
27661 or else Contains (Repeat_Items, State_Id))
27664 ("global refinement of state & must include at least one "
27665 & "constituent of mode `Proof_In`", N, State_Id);
27667 end Check_Constituent_Usage;
27671 Item_Elmt : Elmt_Id;
27672 Item_Id : Entity_Id;
27674 -- Start of processing for Check_Proof_In_States
27677 -- Do not perform this check in an instance because it was already
27678 -- performed successfully in the generic template.
27680 if Is_Generic_Instance (Spec_Id) then
27683 -- Inspect the Proof_In items of the corresponding Global pragma
27684 -- looking for a state with a visible refinement.
27686 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27687 Item_Elmt := First_Elmt (Proof_In_Items);
27688 while Present (Item_Elmt) loop
27689 Item_Id := Node (Item_Elmt);
27691 -- Ensure that at least one of the constituents is utilized
27692 -- and is of mode Proof_In. When only partial refinement is
27693 -- visible, ensure that either one of the constituents is
27694 -- utilized and is of mode Proof_In, or the abstract state
27695 -- is repeated and no constituent is utilized.
27697 if Ekind (Item_Id) = E_Abstract_State
27698 and then Has_Non_Null_Visible_Refinement (Item_Id)
27700 Check_Constituent_Usage (Item_Id);
27703 Next_Elmt (Item_Elmt);
27706 end Check_Proof_In_States;
27708 -------------------------------
27709 -- Check_Refined_Global_List --
27710 -------------------------------
27712 procedure Check_Refined_Global_List
27714 Global_Mode : Name_Id := Name_Input)
27716 procedure Check_Refined_Global_Item
27718 Global_Mode : Name_Id);
27719 -- Verify the legality of a single global item declaration. Parameter
27720 -- Global_Mode denotes the current mode in effect.
27722 -------------------------------
27723 -- Check_Refined_Global_Item --
27724 -------------------------------
27726 procedure Check_Refined_Global_Item
27728 Global_Mode : Name_Id)
27730 Item_Id : constant Entity_Id := Entity_Of (Item);
27732 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27733 -- Issue a common error message for all mode mismatches. Expect
27734 -- denotes the expected mode.
27736 -----------------------------
27737 -- Inconsistent_Mode_Error --
27738 -----------------------------
27740 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27743 ("global item & has inconsistent modes", Item, Item_Id);
27745 Error_Msg_Name_1 := Global_Mode;
27746 Error_Msg_Name_2 := Expect;
27747 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27748 end Inconsistent_Mode_Error;
27752 Enc_State : Entity_Id := Empty;
27753 -- Encapsulating state for constituent, Empty otherwise
27755 -- Start of processing for Check_Refined_Global_Item
27758 if Ekind_In (Item_Id, E_Abstract_State,
27762 Enc_State := Find_Encapsulating_State (States, Item_Id);
27765 -- When the state or object acts as a constituent of another
27766 -- state with a visible refinement, collect it for the state
27767 -- completeness checks performed later on. Note that the item
27768 -- acts as a constituent only when the encapsulating state is
27769 -- present in pragma Global.
27771 if Present (Enc_State)
27772 and then (Has_Visible_Refinement (Enc_State)
27773 or else Has_Partial_Visible_Refinement (Enc_State))
27774 and then Contains (States, Enc_State)
27776 -- If the state has only partial visible refinement, remove it
27777 -- from the list of items that should be repeated from pragma
27780 if not Has_Visible_Refinement (Enc_State) then
27781 Present_Then_Remove (Repeat_Items, Enc_State);
27784 if Global_Mode = Name_Input then
27785 Append_New_Elmt (Item_Id, In_Constits);
27787 elsif Global_Mode = Name_In_Out then
27788 Append_New_Elmt (Item_Id, In_Out_Constits);
27790 elsif Global_Mode = Name_Output then
27791 Append_New_Elmt (Item_Id, Out_Constits);
27793 elsif Global_Mode = Name_Proof_In then
27794 Append_New_Elmt (Item_Id, Proof_In_Constits);
27797 -- When not a constituent, ensure that both occurrences of the
27798 -- item in pragmas Global and Refined_Global match. Also remove
27799 -- it when present from the list of items that should be repeated
27800 -- from pragma Global.
27803 Present_Then_Remove (Repeat_Items, Item_Id);
27805 if Contains (In_Items, Item_Id) then
27806 if Global_Mode /= Name_Input then
27807 Inconsistent_Mode_Error (Name_Input);
27810 elsif Contains (In_Out_Items, Item_Id) then
27811 if Global_Mode /= Name_In_Out then
27812 Inconsistent_Mode_Error (Name_In_Out);
27815 elsif Contains (Out_Items, Item_Id) then
27816 if Global_Mode /= Name_Output then
27817 Inconsistent_Mode_Error (Name_Output);
27820 elsif Contains (Proof_In_Items, Item_Id) then
27823 -- The item does not appear in the corresponding Global pragma,
27824 -- it must be an extra (SPARK RM 7.2.4(3)).
27827 pragma Assert (Present (Global));
27828 Error_Msg_Sloc := Sloc (Global);
27830 ("extra global item & does not refine or repeat any "
27831 & "global item #", Item, Item_Id);
27834 end Check_Refined_Global_Item;
27840 -- Start of processing for Check_Refined_Global_List
27843 -- Do not perform this check in an instance because it was already
27844 -- performed successfully in the generic template.
27846 if Is_Generic_Instance (Spec_Id) then
27849 elsif Nkind (List) = N_Null then
27852 -- Single global item declaration
27854 elsif Nkind_In (List, N_Expanded_Name,
27856 N_Selected_Component)
27858 Check_Refined_Global_Item (List, Global_Mode);
27860 -- Simple global list or moded global list declaration
27862 elsif Nkind (List) = N_Aggregate then
27864 -- The declaration of a simple global list appear as a collection
27867 if Present (Expressions (List)) then
27868 Item := First (Expressions (List));
27869 while Present (Item) loop
27870 Check_Refined_Global_Item (Item, Global_Mode);
27874 -- The declaration of a moded global list appears as a collection
27875 -- of component associations where individual choices denote
27878 elsif Present (Component_Associations (List)) then
27879 Item := First (Component_Associations (List));
27880 while Present (Item) loop
27881 Check_Refined_Global_List
27882 (List => Expression (Item),
27883 Global_Mode => Chars (First (Choices (Item))));
27891 raise Program_Error;
27897 raise Program_Error;
27899 end Check_Refined_Global_List;
27901 --------------------------
27902 -- Collect_Global_Items --
27903 --------------------------
27905 procedure Collect_Global_Items
27907 Mode : Name_Id := Name_Input)
27909 procedure Collect_Global_Item
27911 Item_Mode : Name_Id);
27912 -- Add a single item to the appropriate list. Item_Mode denotes the
27913 -- current mode in effect.
27915 -------------------------
27916 -- Collect_Global_Item --
27917 -------------------------
27919 procedure Collect_Global_Item
27921 Item_Mode : Name_Id)
27923 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27924 -- The above handles abstract views of variables and states built
27925 -- for limited with clauses.
27928 -- Signal that the global list contains at least one abstract
27929 -- state with a visible refinement. Note that the refinement may
27930 -- be null in which case there are no constituents.
27932 if Ekind (Item_Id) = E_Abstract_State then
27933 if Has_Null_Visible_Refinement (Item_Id) then
27934 Has_Null_State := True;
27936 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27937 Append_New_Elmt (Item_Id, States);
27939 if Item_Mode = Name_Input then
27940 Has_In_State := True;
27941 elsif Item_Mode = Name_In_Out then
27942 Has_In_Out_State := True;
27943 elsif Item_Mode = Name_Output then
27944 Has_Out_State := True;
27945 elsif Item_Mode = Name_Proof_In then
27946 Has_Proof_In_State := True;
27951 -- Record global items without full visible refinement found in
27952 -- pragma Global which should be repeated in the global refinement
27953 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27955 if Ekind (Item_Id) /= E_Abstract_State
27956 or else not Has_Visible_Refinement (Item_Id)
27958 Append_New_Elmt (Item_Id, Repeat_Items);
27961 -- Add the item to the proper list
27963 if Item_Mode = Name_Input then
27964 Append_New_Elmt (Item_Id, In_Items);
27965 elsif Item_Mode = Name_In_Out then
27966 Append_New_Elmt (Item_Id, In_Out_Items);
27967 elsif Item_Mode = Name_Output then
27968 Append_New_Elmt (Item_Id, Out_Items);
27969 elsif Item_Mode = Name_Proof_In then
27970 Append_New_Elmt (Item_Id, Proof_In_Items);
27972 end Collect_Global_Item;
27978 -- Start of processing for Collect_Global_Items
27981 if Nkind (List) = N_Null then
27984 -- Single global item declaration
27986 elsif Nkind_In (List, N_Expanded_Name,
27988 N_Selected_Component)
27990 Collect_Global_Item (List, Mode);
27992 -- Single global list or moded global list declaration
27994 elsif Nkind (List) = N_Aggregate then
27996 -- The declaration of a simple global list appear as a collection
27999 if Present (Expressions (List)) then
28000 Item := First (Expressions (List));
28001 while Present (Item) loop
28002 Collect_Global_Item (Item, Mode);
28006 -- The declaration of a moded global list appears as a collection
28007 -- of component associations where individual choices denote mode.
28009 elsif Present (Component_Associations (List)) then
28010 Item := First (Component_Associations (List));
28011 while Present (Item) loop
28012 Collect_Global_Items
28013 (List => Expression (Item),
28014 Mode => Chars (First (Choices (Item))));
28022 raise Program_Error;
28025 -- To accommodate partial decoration of disabled SPARK features, this
28026 -- routine may be called with illegal input. If this is the case, do
28027 -- not raise Program_Error.
28032 end Collect_Global_Items;
28034 -------------------------
28035 -- Present_Then_Remove --
28036 -------------------------
28038 function Present_Then_Remove
28040 Item : Entity_Id) return Boolean
28045 if Present (List) then
28046 Elmt := First_Elmt (List);
28047 while Present (Elmt) loop
28048 if Node (Elmt) = Item then
28049 Remove_Elmt (List, Elmt);
28058 end Present_Then_Remove;
28060 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28063 Ignore := Present_Then_Remove (List, Item);
28064 end Present_Then_Remove;
28066 -------------------------------
28067 -- Report_Extra_Constituents --
28068 -------------------------------
28070 procedure Report_Extra_Constituents is
28071 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28072 -- Emit an error for every element of List
28074 ---------------------------------------
28075 -- Report_Extra_Constituents_In_List --
28076 ---------------------------------------
28078 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28079 Constit_Elmt : Elmt_Id;
28082 if Present (List) then
28083 Constit_Elmt := First_Elmt (List);
28084 while Present (Constit_Elmt) loop
28085 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28086 Next_Elmt (Constit_Elmt);
28089 end Report_Extra_Constituents_In_List;
28091 -- Start of processing for Report_Extra_Constituents
28094 -- Do not perform this check in an instance because it was already
28095 -- performed successfully in the generic template.
28097 if Is_Generic_Instance (Spec_Id) then
28101 Report_Extra_Constituents_In_List (In_Constits);
28102 Report_Extra_Constituents_In_List (In_Out_Constits);
28103 Report_Extra_Constituents_In_List (Out_Constits);
28104 Report_Extra_Constituents_In_List (Proof_In_Constits);
28106 end Report_Extra_Constituents;
28108 --------------------------
28109 -- Report_Missing_Items --
28110 --------------------------
28112 procedure Report_Missing_Items is
28113 Item_Elmt : Elmt_Id;
28114 Item_Id : Entity_Id;
28117 -- Do not perform this check in an instance because it was already
28118 -- performed successfully in the generic template.
28120 if Is_Generic_Instance (Spec_Id) then
28124 if Present (Repeat_Items) then
28125 Item_Elmt := First_Elmt (Repeat_Items);
28126 while Present (Item_Elmt) loop
28127 Item_Id := Node (Item_Elmt);
28128 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28129 Next_Elmt (Item_Elmt);
28133 end Report_Missing_Items;
28137 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28138 Errors : constant Nat := Serious_Errors_Detected;
28140 No_Constit : Boolean;
28142 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28145 -- Do not analyze the pragma multiple times
28147 if Is_Analyzed_Pragma (N) then
28151 Spec_Id := Unique_Defining_Entity (Body_Decl);
28153 -- Use the anonymous object as the proper spec when Refined_Global
28154 -- applies to the body of a single task type. The object carries the
28155 -- proper Chars as well as all non-refined versions of pragmas.
28157 if Is_Single_Concurrent_Type (Spec_Id) then
28158 Spec_Id := Anonymous_Object (Spec_Id);
28161 Global := Get_Pragma (Spec_Id, Pragma_Global);
28162 Items := Expression (Get_Argument (N, Spec_Id));
28164 -- The subprogram declaration lacks pragma Global. This renders
28165 -- Refined_Global useless as there is nothing to refine.
28167 if No (Global) then
28169 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28170 & "& lacks aspect or pragma Global"), N, Spec_Id);
28174 -- Extract all relevant items from the corresponding Global pragma
28176 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28178 -- Package and subprogram bodies are instantiated individually in
28179 -- a separate compiler pass. Due to this mode of instantiation, the
28180 -- refinement of a state may no longer be visible when a subprogram
28181 -- body contract is instantiated. Since the generic template is legal,
28182 -- do not perform this check in the instance to circumvent this oddity.
28184 if Is_Generic_Instance (Spec_Id) then
28187 -- Non-instance case
28190 -- The corresponding Global pragma must mention at least one
28191 -- state with a visible refinement at the point Refined_Global
28192 -- is processed. States with null refinements need Refined_Global
28193 -- pragma (SPARK RM 7.2.4(2)).
28195 if not Has_In_State
28196 and then not Has_In_Out_State
28197 and then not Has_Out_State
28198 and then not Has_Proof_In_State
28199 and then not Has_Null_State
28202 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28203 & "depend on abstract state with visible refinement"),
28207 -- The global refinement of inputs and outputs cannot be null when
28208 -- the corresponding Global pragma contains at least one item except
28209 -- in the case where we have states with null refinements.
28211 elsif Nkind (Items) = N_Null
28213 (Present (In_Items)
28214 or else Present (In_Out_Items)
28215 or else Present (Out_Items)
28216 or else Present (Proof_In_Items))
28217 and then not Has_Null_State
28220 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28221 & "global items"), N, Spec_Id);
28226 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28227 -- This ensures that the categorization of all refined global items is
28228 -- consistent with their role.
28230 Analyze_Global_In_Decl_Part (N);
28232 -- Perform all refinement checks with respect to completeness and mode
28235 if Serious_Errors_Detected = Errors then
28236 Check_Refined_Global_List (Items);
28239 -- Store the information that no constituent is used in the global
28240 -- refinement, prior to calling checking procedures which remove items
28241 -- from the list of constituents.
28245 and then No (In_Out_Constits)
28246 and then No (Out_Constits)
28247 and then No (Proof_In_Constits);
28249 -- For Input states with visible refinement, at least one constituent
28250 -- must be used as an Input in the global refinement.
28252 if Serious_Errors_Detected = Errors then
28253 Check_Input_States;
28256 -- Verify all possible completion variants for In_Out states with
28257 -- visible refinement.
28259 if Serious_Errors_Detected = Errors then
28260 Check_In_Out_States;
28263 -- For Output states with visible refinement, all constituents must be
28264 -- used as Outputs in the global refinement.
28266 if Serious_Errors_Detected = Errors then
28267 Check_Output_States;
28270 -- For Proof_In states with visible refinement, at least one constituent
28271 -- must be used as Proof_In in the global refinement.
28273 if Serious_Errors_Detected = Errors then
28274 Check_Proof_In_States;
28277 -- Emit errors for all constituents that belong to other states with
28278 -- visible refinement that do not appear in Global.
28280 if Serious_Errors_Detected = Errors then
28281 Report_Extra_Constituents;
28284 -- Emit errors for all items in Global that are not repeated in the
28285 -- global refinement and for which there is no full visible refinement
28286 -- and, in the case of states with partial visible refinement, no
28287 -- constituent is mentioned in the global refinement.
28289 if Serious_Errors_Detected = Errors then
28290 Report_Missing_Items;
28293 -- Emit an error if no constituent is used in the global refinement
28294 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28295 -- one may be issued by the checking procedures. Do not perform this
28296 -- check in an instance because it was already performed successfully
28297 -- in the generic template.
28299 if Serious_Errors_Detected = Errors
28300 and then not Is_Generic_Instance (Spec_Id)
28301 and then not Has_Null_State
28302 and then No_Constit
28304 SPARK_Msg_N ("missing refinement", N);
28308 Set_Is_Analyzed_Pragma (N);
28309 end Analyze_Refined_Global_In_Decl_Part;
28311 ----------------------------------------
28312 -- Analyze_Refined_State_In_Decl_Part --
28313 ----------------------------------------
28315 procedure Analyze_Refined_State_In_Decl_Part
28317 Freeze_Id : Entity_Id := Empty)
28319 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28320 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28321 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28323 Available_States : Elist_Id := No_Elist;
28324 -- A list of all abstract states defined in the package declaration that
28325 -- are available for refinement. The list is used to report unrefined
28328 Body_States : Elist_Id := No_Elist;
28329 -- A list of all hidden states that appear in the body of the related
28330 -- package. The list is used to report unused hidden states.
28332 Constituents_Seen : Elist_Id := No_Elist;
28333 -- A list that contains all constituents processed so far. The list is
28334 -- used to detect multiple uses of the same constituent.
28336 Freeze_Posted : Boolean := False;
28337 -- A flag that controls the output of a freezing-related error (see use
28340 Refined_States_Seen : Elist_Id := No_Elist;
28341 -- A list that contains all refined states processed so far. The list is
28342 -- used to detect duplicate refinements.
28344 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28345 -- Perform full analysis of a single refinement clause
28347 procedure Report_Unrefined_States (States : Elist_Id);
28348 -- Emit errors for all unrefined abstract states found in list States
28350 -------------------------------
28351 -- Analyze_Refinement_Clause --
28352 -------------------------------
28354 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28355 AR_Constit : Entity_Id := Empty;
28356 AW_Constit : Entity_Id := Empty;
28357 ER_Constit : Entity_Id := Empty;
28358 EW_Constit : Entity_Id := Empty;
28359 -- The entities of external constituents that contain one of the
28360 -- following enabled properties: Async_Readers, Async_Writers,
28361 -- Effective_Reads and Effective_Writes.
28363 External_Constit_Seen : Boolean := False;
28364 -- Flag used to mark when at least one external constituent is part
28365 -- of the state refinement.
28367 Non_Null_Seen : Boolean := False;
28368 Null_Seen : Boolean := False;
28369 -- Flags used to detect multiple uses of null in a single clause or a
28370 -- mixture of null and non-null constituents.
28372 Part_Of_Constits : Elist_Id := No_Elist;
28373 -- A list of all candidate constituents subject to indicator Part_Of
28374 -- where the encapsulating state is the current state.
28377 State_Id : Entity_Id;
28378 -- The current state being refined
28380 procedure Analyze_Constituent (Constit : Node_Id);
28381 -- Perform full analysis of a single constituent
28383 procedure Check_External_Property
28384 (Prop_Nam : Name_Id;
28386 Constit : Entity_Id);
28387 -- Determine whether a property denoted by name Prop_Nam is present
28388 -- in the refined state. Emit an error if this is not the case. Flag
28389 -- Enabled should be set when the property applies to the refined
28390 -- state. Constit denotes the constituent (if any) which introduces
28391 -- the property in the refinement.
28393 procedure Match_State;
28394 -- Determine whether the state being refined appears in list
28395 -- Available_States. Emit an error when attempting to re-refine the
28396 -- state or when the state is not defined in the package declaration,
28397 -- otherwise remove the state from Available_States.
28399 procedure Report_Unused_Constituents (Constits : Elist_Id);
28400 -- Emit errors for all unused Part_Of constituents in list Constits
28402 -------------------------
28403 -- Analyze_Constituent --
28404 -------------------------
28406 procedure Analyze_Constituent (Constit : Node_Id) is
28407 procedure Match_Constituent (Constit_Id : Entity_Id);
28408 -- Determine whether constituent Constit denoted by its entity
28409 -- Constit_Id appears in Body_States. Emit an error when the
28410 -- constituent is not a valid hidden state of the related package
28411 -- or when it is used more than once. Otherwise remove the
28412 -- constituent from Body_States.
28414 -----------------------
28415 -- Match_Constituent --
28416 -----------------------
28418 procedure Match_Constituent (Constit_Id : Entity_Id) is
28419 procedure Collect_Constituent;
28420 -- Verify the legality of constituent Constit_Id and add it to
28421 -- the refinements of State_Id.
28423 -------------------------
28424 -- Collect_Constituent --
28425 -------------------------
28427 procedure Collect_Constituent is
28428 Constits : Elist_Id;
28431 -- The Ghost policy in effect at the point of abstract state
28432 -- declaration and constituent must match (SPARK RM 6.9(15))
28434 Check_Ghost_Refinement
28435 (State, State_Id, Constit, Constit_Id);
28437 -- A synchronized state must be refined by a synchronized
28438 -- object or another synchronized state (SPARK RM 9.6).
28440 if Is_Synchronized_State (State_Id)
28441 and then not Is_Synchronized_Object (Constit_Id)
28442 and then not Is_Synchronized_State (Constit_Id)
28445 ("constituent of synchronized state & must be "
28446 & "synchronized", Constit, State_Id);
28449 -- Add the constituent to the list of processed items to aid
28450 -- with the detection of duplicates.
28452 Append_New_Elmt (Constit_Id, Constituents_Seen);
28454 -- Collect the constituent in the list of refinement items
28455 -- and establish a relation between the refined state and
28458 Constits := Refinement_Constituents (State_Id);
28460 if No (Constits) then
28461 Constits := New_Elmt_List;
28462 Set_Refinement_Constituents (State_Id, Constits);
28465 Append_Elmt (Constit_Id, Constits);
28466 Set_Encapsulating_State (Constit_Id, State_Id);
28468 -- The state has at least one legal constituent, mark the
28469 -- start of the refinement region. The region ends when the
28470 -- body declarations end (see routine Analyze_Declarations).
28472 Set_Has_Visible_Refinement (State_Id);
28474 -- When the constituent is external, save its relevant
28475 -- property for further checks.
28477 if Async_Readers_Enabled (Constit_Id) then
28478 AR_Constit := Constit_Id;
28479 External_Constit_Seen := True;
28482 if Async_Writers_Enabled (Constit_Id) then
28483 AW_Constit := Constit_Id;
28484 External_Constit_Seen := True;
28487 if Effective_Reads_Enabled (Constit_Id) then
28488 ER_Constit := Constit_Id;
28489 External_Constit_Seen := True;
28492 if Effective_Writes_Enabled (Constit_Id) then
28493 EW_Constit := Constit_Id;
28494 External_Constit_Seen := True;
28496 end Collect_Constituent;
28500 State_Elmt : Elmt_Id;
28502 -- Start of processing for Match_Constituent
28505 -- Detect a duplicate use of a constituent
28507 if Contains (Constituents_Seen, Constit_Id) then
28509 ("duplicate use of constituent &", Constit, Constit_Id);
28513 -- The constituent is subject to a Part_Of indicator
28515 if Present (Encapsulating_State (Constit_Id)) then
28516 if Encapsulating_State (Constit_Id) = State_Id then
28517 Remove (Part_Of_Constits, Constit_Id);
28518 Collect_Constituent;
28520 -- The constituent is part of another state and is used
28521 -- incorrectly in the refinement of the current state.
28524 Error_Msg_Name_1 := Chars (State_Id);
28526 ("& cannot act as constituent of state %",
28527 Constit, Constit_Id);
28529 ("\Part_Of indicator specifies encapsulator &",
28530 Constit, Encapsulating_State (Constit_Id));
28533 -- The only other source of legal constituents is the body
28534 -- state space of the related package.
28537 if Present (Body_States) then
28538 State_Elmt := First_Elmt (Body_States);
28539 while Present (State_Elmt) loop
28541 -- Consume a valid constituent to signal that it has
28542 -- been encountered.
28544 if Node (State_Elmt) = Constit_Id then
28545 Remove_Elmt (Body_States, State_Elmt);
28546 Collect_Constituent;
28550 Next_Elmt (State_Elmt);
28554 -- At this point it is known that the constituent is not
28555 -- part of the package hidden state and cannot be used in
28556 -- a refinement (SPARK RM 7.2.2(9)).
28558 Error_Msg_Name_1 := Chars (Spec_Id);
28560 ("cannot use & in refinement, constituent is not a hidden "
28561 & "state of package %", Constit, Constit_Id);
28563 end Match_Constituent;
28567 Constit_Id : Entity_Id;
28568 Constits : Elist_Id;
28570 -- Start of processing for Analyze_Constituent
28573 -- Detect multiple uses of null in a single refinement clause or a
28574 -- mixture of null and non-null constituents.
28576 if Nkind (Constit) = N_Null then
28579 ("multiple null constituents not allowed", Constit);
28581 elsif Non_Null_Seen then
28583 ("cannot mix null and non-null constituents", Constit);
28588 -- Collect the constituent in the list of refinement items
28590 Constits := Refinement_Constituents (State_Id);
28592 if No (Constits) then
28593 Constits := New_Elmt_List;
28594 Set_Refinement_Constituents (State_Id, Constits);
28597 Append_Elmt (Constit, Constits);
28599 -- The state has at least one legal constituent, mark the
28600 -- start of the refinement region. The region ends when the
28601 -- body declarations end (see Analyze_Declarations).
28603 Set_Has_Visible_Refinement (State_Id);
28606 -- Non-null constituents
28609 Non_Null_Seen := True;
28613 ("cannot mix null and non-null constituents", Constit);
28617 Resolve_State (Constit);
28619 -- Ensure that the constituent denotes a valid state or a
28620 -- whole object (SPARK RM 7.2.2(5)).
28622 if Is_Entity_Name (Constit) then
28623 Constit_Id := Entity_Of (Constit);
28625 -- When a constituent is declared after a subprogram body
28626 -- that caused freezing of the related contract where
28627 -- pragma Refined_State resides, the constituent appears
28628 -- undefined and carries Any_Id as its entity.
28630 -- package body Pack
28631 -- with Refined_State => (State => Constit)
28634 -- with Refined_Global => (Input => Constit)
28642 if Constit_Id = Any_Id then
28643 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28645 -- Emit a specialized info message when the contract of
28646 -- the related package body was "frozen" by another body.
28647 -- Note that it is not possible to precisely identify why
28648 -- the constituent is undefined because it is not visible
28649 -- when pragma Refined_State is analyzed. This message is
28650 -- a reasonable approximation.
28652 if Present (Freeze_Id) and then not Freeze_Posted then
28653 Freeze_Posted := True;
28655 Error_Msg_Name_1 := Chars (Body_Id);
28656 Error_Msg_Sloc := Sloc (Freeze_Id);
28658 ("body & declared # freezes the contract of %",
28661 ("\all constituents must be declared before body #",
28664 -- A misplaced constituent is a critical error because
28665 -- pragma Refined_Depends or Refined_Global depends on
28666 -- the proper link between a state and a constituent.
28667 -- Stop the compilation, as this leads to a multitude
28668 -- of misleading cascaded errors.
28670 raise Unrecoverable_Error;
28673 -- The constituent is a valid state or object
28675 elsif Ekind_In (Constit_Id, E_Abstract_State,
28679 Match_Constituent (Constit_Id);
28681 -- The variable may eventually become a constituent of a
28682 -- single protected/task type. Record the reference now
28683 -- and verify its legality when analyzing the contract of
28684 -- the variable (SPARK RM 9.3).
28686 if Ekind (Constit_Id) = E_Variable then
28687 Record_Possible_Part_Of_Reference
28688 (Var_Id => Constit_Id,
28692 -- Otherwise the constituent is illegal
28696 ("constituent & must denote object or state",
28697 Constit, Constit_Id);
28700 -- The constituent is illegal
28703 SPARK_Msg_N ("malformed constituent", Constit);
28706 end Analyze_Constituent;
28708 -----------------------------
28709 -- Check_External_Property --
28710 -----------------------------
28712 procedure Check_External_Property
28713 (Prop_Nam : Name_Id;
28715 Constit : Entity_Id)
28718 -- The property is missing in the declaration of the state, but
28719 -- a constituent is introducing it in the state refinement
28720 -- (SPARK RM 7.2.8(2)).
28722 if not Enabled and then Present (Constit) then
28723 Error_Msg_Name_1 := Prop_Nam;
28724 Error_Msg_Name_2 := Chars (State_Id);
28726 ("constituent & introduces external property % in refinement "
28727 & "of state %", State, Constit);
28729 Error_Msg_Sloc := Sloc (State_Id);
28731 ("\property is missing in abstract state declaration #",
28734 end Check_External_Property;
28740 procedure Match_State is
28741 State_Elmt : Elmt_Id;
28744 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28746 if Contains (Refined_States_Seen, State_Id) then
28748 ("duplicate refinement of state &", State, State_Id);
28752 -- Inspect the abstract states defined in the package declaration
28753 -- looking for a match.
28755 State_Elmt := First_Elmt (Available_States);
28756 while Present (State_Elmt) loop
28758 -- A valid abstract state is being refined in the body. Add
28759 -- the state to the list of processed refined states to aid
28760 -- with the detection of duplicate refinements. Remove the
28761 -- state from Available_States to signal that it has already
28764 if Node (State_Elmt) = State_Id then
28765 Append_New_Elmt (State_Id, Refined_States_Seen);
28766 Remove_Elmt (Available_States, State_Elmt);
28770 Next_Elmt (State_Elmt);
28773 -- If we get here, we are refining a state that is not defined in
28774 -- the package declaration.
28776 Error_Msg_Name_1 := Chars (Spec_Id);
28778 ("cannot refine state, & is not defined in package %",
28782 --------------------------------
28783 -- Report_Unused_Constituents --
28784 --------------------------------
28786 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28787 Constit_Elmt : Elmt_Id;
28788 Constit_Id : Entity_Id;
28789 Posted : Boolean := False;
28792 if Present (Constits) then
28793 Constit_Elmt := First_Elmt (Constits);
28794 while Present (Constit_Elmt) loop
28795 Constit_Id := Node (Constit_Elmt);
28797 -- Generate an error message of the form:
28799 -- state ... has unused Part_Of constituents
28800 -- abstract state ... defined at ...
28801 -- constant ... defined at ...
28802 -- variable ... defined at ...
28807 ("state & has unused Part_Of constituents",
28811 Error_Msg_Sloc := Sloc (Constit_Id);
28813 if Ekind (Constit_Id) = E_Abstract_State then
28815 ("\abstract state & defined #", State, Constit_Id);
28817 elsif Ekind (Constit_Id) = E_Constant then
28819 ("\constant & defined #", State, Constit_Id);
28822 pragma Assert (Ekind (Constit_Id) = E_Variable);
28823 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28826 Next_Elmt (Constit_Elmt);
28829 end Report_Unused_Constituents;
28831 -- Local declarations
28833 Body_Ref : Node_Id;
28834 Body_Ref_Elmt : Elmt_Id;
28836 Extra_State : Node_Id;
28838 -- Start of processing for Analyze_Refinement_Clause
28841 -- A refinement clause appears as a component association where the
28842 -- sole choice is the state and the expressions are the constituents.
28843 -- This is a syntax error, always report.
28845 if Nkind (Clause) /= N_Component_Association then
28846 Error_Msg_N ("malformed state refinement clause", Clause);
28850 -- Analyze the state name of a refinement clause
28852 State := First (Choices (Clause));
28855 Resolve_State (State);
28857 -- Ensure that the state name denotes a valid abstract state that is
28858 -- defined in the spec of the related package.
28860 if Is_Entity_Name (State) then
28861 State_Id := Entity_Of (State);
28863 -- When the abstract state is undefined, it appears as Any_Id. Do
28864 -- not continue with the analysis of the clause.
28866 if State_Id = Any_Id then
28869 -- Catch any attempts to re-refine a state or refine a state that
28870 -- is not defined in the package declaration.
28872 elsif Ekind (State_Id) = E_Abstract_State then
28876 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28880 -- References to a state with visible refinement are illegal.
28881 -- When nested packages are involved, detecting such references is
28882 -- tricky because pragma Refined_State is analyzed later than the
28883 -- offending pragma Depends or Global. References that occur in
28884 -- such nested context are stored in a list. Emit errors for all
28885 -- references found in Body_References (SPARK RM 6.1.4(8)).
28887 if Present (Body_References (State_Id)) then
28888 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28889 while Present (Body_Ref_Elmt) loop
28890 Body_Ref := Node (Body_Ref_Elmt);
28892 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28893 Error_Msg_Sloc := Sloc (State);
28894 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28896 Next_Elmt (Body_Ref_Elmt);
28900 -- The state name is illegal. This is a syntax error, always report.
28903 Error_Msg_N ("malformed state name in refinement clause", State);
28907 -- A refinement clause may only refine one state at a time
28909 Extra_State := Next (State);
28911 if Present (Extra_State) then
28913 ("refinement clause cannot cover multiple states", Extra_State);
28916 -- Replicate the Part_Of constituents of the refined state because
28917 -- the algorithm will consume items.
28919 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28921 -- Analyze all constituents of the refinement. Multiple constituents
28922 -- appear as an aggregate.
28924 Constit := Expression (Clause);
28926 if Nkind (Constit) = N_Aggregate then
28927 if Present (Component_Associations (Constit)) then
28929 ("constituents of refinement clause must appear in "
28930 & "positional form", Constit);
28932 else pragma Assert (Present (Expressions (Constit)));
28933 Constit := First (Expressions (Constit));
28934 while Present (Constit) loop
28935 Analyze_Constituent (Constit);
28940 -- Various forms of a single constituent. Note that these may include
28941 -- malformed constituents.
28944 Analyze_Constituent (Constit);
28947 -- Verify that external constituents do not introduce new external
28948 -- property in the state refinement (SPARK RM 7.2.8(2)).
28950 if Is_External_State (State_Id) then
28951 Check_External_Property
28952 (Prop_Nam => Name_Async_Readers,
28953 Enabled => Async_Readers_Enabled (State_Id),
28954 Constit => AR_Constit);
28956 Check_External_Property
28957 (Prop_Nam => Name_Async_Writers,
28958 Enabled => Async_Writers_Enabled (State_Id),
28959 Constit => AW_Constit);
28961 Check_External_Property
28962 (Prop_Nam => Name_Effective_Reads,
28963 Enabled => Effective_Reads_Enabled (State_Id),
28964 Constit => ER_Constit);
28966 Check_External_Property
28967 (Prop_Nam => Name_Effective_Writes,
28968 Enabled => Effective_Writes_Enabled (State_Id),
28969 Constit => EW_Constit);
28971 -- When a refined state is not external, it should not have external
28972 -- constituents (SPARK RM 7.2.8(1)).
28974 elsif External_Constit_Seen then
28976 ("non-external state & cannot contain external constituents in "
28977 & "refinement", State, State_Id);
28980 -- Ensure that all Part_Of candidate constituents have been mentioned
28981 -- in the refinement clause.
28983 Report_Unused_Constituents (Part_Of_Constits);
28984 end Analyze_Refinement_Clause;
28986 -----------------------------
28987 -- Report_Unrefined_States --
28988 -----------------------------
28990 procedure Report_Unrefined_States (States : Elist_Id) is
28991 State_Elmt : Elmt_Id;
28994 if Present (States) then
28995 State_Elmt := First_Elmt (States);
28996 while Present (State_Elmt) loop
28998 ("abstract state & must be refined", Node (State_Elmt));
29000 Next_Elmt (State_Elmt);
29003 end Report_Unrefined_States;
29005 -- Local declarations
29007 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29010 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29013 -- Do not analyze the pragma multiple times
29015 if Is_Analyzed_Pragma (N) then
29019 -- Save the scenario for examination by the ABE Processing phase
29021 Record_Elaboration_Scenario (N);
29023 -- Replicate the abstract states declared by the package because the
29024 -- matching algorithm will consume states.
29026 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29028 -- Gather all abstract states and objects declared in the visible
29029 -- state space of the package body. These items must be utilized as
29030 -- constituents in a state refinement.
29032 Body_States := Collect_Body_States (Body_Id);
29034 -- Multiple non-null state refinements appear as an aggregate
29036 if Nkind (Clauses) = N_Aggregate then
29037 if Present (Expressions (Clauses)) then
29039 ("state refinements must appear as component associations",
29042 else pragma Assert (Present (Component_Associations (Clauses)));
29043 Clause := First (Component_Associations (Clauses));
29044 while Present (Clause) loop
29045 Analyze_Refinement_Clause (Clause);
29050 -- Various forms of a single state refinement. Note that these may
29051 -- include malformed refinements.
29054 Analyze_Refinement_Clause (Clauses);
29057 -- List all abstract states that were left unrefined
29059 Report_Unrefined_States (Available_States);
29061 Set_Is_Analyzed_Pragma (N);
29062 end Analyze_Refined_State_In_Decl_Part;
29064 ------------------------------------
29065 -- Analyze_Test_Case_In_Decl_Part --
29066 ------------------------------------
29068 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29069 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29070 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29072 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29073 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29074 -- denoted by Arg_Nam.
29076 ------------------------------
29077 -- Preanalyze_Test_Case_Arg --
29078 ------------------------------
29080 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29084 -- Preanalyze the original aspect argument for ASIS or for a generic
29085 -- subprogram to properly capture global references.
29087 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
29091 Arg_Nam => Arg_Nam,
29092 From_Aspect => True);
29094 if Present (Arg) then
29095 Preanalyze_Assert_Expression
29096 (Expression (Arg), Standard_Boolean);
29100 Arg := Test_Case_Arg (N, Arg_Nam);
29102 if Present (Arg) then
29103 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29105 end Preanalyze_Test_Case_Arg;
29109 Restore_Scope : Boolean := False;
29111 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29114 -- Do not analyze the pragma multiple times
29116 if Is_Analyzed_Pragma (N) then
29120 -- Ensure that the formal parameters are visible when analyzing all
29121 -- clauses. This falls out of the general rule of aspects pertaining
29122 -- to subprogram declarations.
29124 if not In_Open_Scopes (Spec_Id) then
29125 Restore_Scope := True;
29126 Push_Scope (Spec_Id);
29128 if Is_Generic_Subprogram (Spec_Id) then
29129 Install_Generic_Formals (Spec_Id);
29131 Install_Formals (Spec_Id);
29135 Preanalyze_Test_Case_Arg (Name_Requires);
29136 Preanalyze_Test_Case_Arg (Name_Ensures);
29138 if Restore_Scope then
29142 -- Currently it is not possible to inline pre/postconditions on a
29143 -- subprogram subject to pragma Inline_Always.
29145 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29147 Set_Is_Analyzed_Pragma (N);
29148 end Analyze_Test_Case_In_Decl_Part;
29154 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29159 if Present (List) then
29160 Elmt := First_Elmt (List);
29161 while Present (Elmt) loop
29162 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29165 Id := Entity_Of (Node (Elmt));
29168 if Id = Item_Id then
29179 -----------------------------------
29180 -- Build_Pragma_Check_Equivalent --
29181 -----------------------------------
29183 function Build_Pragma_Check_Equivalent
29185 Subp_Id : Entity_Id := Empty;
29186 Inher_Id : Entity_Id := Empty;
29187 Keep_Pragma_Id : Boolean := False) return Node_Id
29189 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29190 -- Detect whether node N references a formal parameter subject to
29191 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29192 -- to False to suppress the generation of a reference when analyzing
29195 ------------------------
29196 -- Suppress_Reference --
29197 ------------------------
29199 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29200 Formal : Entity_Id;
29203 if Is_Entity_Name (N) and then Present (Entity (N)) then
29204 Formal := Entity (N);
29206 -- The formal parameter is subject to pragma Unreferenced. Prevent
29207 -- the generation of references by resetting the Comes_From_Source
29210 if Is_Formal (Formal)
29211 and then Has_Pragma_Unreferenced (Formal)
29213 Set_Comes_From_Source (N, False);
29218 end Suppress_Reference;
29220 procedure Suppress_References is
29221 new Traverse_Proc (Suppress_Reference);
29225 Loc : constant Source_Ptr := Sloc (Prag);
29226 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29227 Check_Prag : Node_Id;
29231 Needs_Wrapper : Boolean;
29232 pragma Unreferenced (Needs_Wrapper);
29234 -- Start of processing for Build_Pragma_Check_Equivalent
29237 -- When the pre- or postcondition is inherited, map the formals of the
29238 -- inherited subprogram to those of the current subprogram. In addition,
29239 -- map primitive operations of the parent type into the corresponding
29240 -- primitive operations of the descendant.
29242 if Present (Inher_Id) then
29243 pragma Assert (Present (Subp_Id));
29245 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29247 -- Use generic machinery to copy inherited pragma, as if it were an
29248 -- instantiation, resetting source locations appropriately, so that
29249 -- expressions inside the inherited pragma use chained locations.
29250 -- This is used in particular in GNATprove to locate precisely
29251 -- messages on a given inherited pragma.
29253 Set_Copied_Sloc_For_Inherited_Pragma
29254 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29255 Check_Prag := New_Copy_Tree (Source => Prag);
29257 -- Build the inherited class-wide condition
29259 Build_Class_Wide_Expression
29260 (Prag => Check_Prag,
29262 Par_Subp => Inher_Id,
29263 Adjust_Sloc => True,
29264 Needs_Wrapper => Needs_Wrapper);
29266 -- If not an inherited condition simply copy the original pragma
29269 Check_Prag := New_Copy_Tree (Source => Prag);
29272 -- Mark the pragma as being internally generated and reset the Analyzed
29275 Set_Analyzed (Check_Prag, False);
29276 Set_Comes_From_Source (Check_Prag, False);
29278 -- The tree of the original pragma may contain references to the
29279 -- formal parameters of the related subprogram. At the same time
29280 -- the corresponding body may mark the formals as unreferenced:
29282 -- procedure Proc (Formal : ...)
29283 -- with Pre => Formal ...;
29285 -- procedure Proc (Formal : ...) is
29286 -- pragma Unreferenced (Formal);
29289 -- This creates problems because all pragma Check equivalents are
29290 -- analyzed at the end of the body declarations. Since all source
29291 -- references have already been accounted for, reset any references
29292 -- to such formals in the generated pragma Check equivalent.
29294 Suppress_References (Check_Prag);
29296 if Present (Corresponding_Aspect (Prag)) then
29297 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29302 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29303 -- the copied pragma in the newly created pragma, convert the copy into
29304 -- pragma Check by correcting the name and adding a check_kind argument.
29306 if not Keep_Pragma_Id then
29307 Set_Class_Present (Check_Prag, False);
29309 Set_Pragma_Identifier
29310 (Check_Prag, Make_Identifier (Loc, Name_Check));
29312 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29313 Make_Pragma_Argument_Association (Loc,
29314 Expression => Make_Identifier (Loc, Nam)));
29317 -- Update the error message when the pragma is inherited
29319 if Present (Inher_Id) then
29320 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29322 if Chars (Msg_Arg) = Name_Message then
29323 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29325 -- Insert "inherited" to improve the error message
29327 if Name_Buffer (1 .. 8) = "failed p" then
29328 Insert_Str_In_Name_Buffer ("inherited ", 8);
29329 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29335 end Build_Pragma_Check_Equivalent;
29337 -----------------------------
29338 -- Check_Applicable_Policy --
29339 -----------------------------
29341 procedure Check_Applicable_Policy (N : Node_Id) is
29345 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29348 -- No effect if not valid assertion kind name
29350 if not Is_Valid_Assertion_Kind (Ename) then
29354 -- Loop through entries in check policy list
29356 PP := Opt.Check_Policy_List;
29357 while Present (PP) loop
29359 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29360 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29364 or else Pnm = Name_Assertion
29365 or else (Pnm = Name_Statement_Assertions
29366 and then Nam_In (Ename, Name_Assert,
29367 Name_Assert_And_Cut,
29369 Name_Loop_Invariant,
29370 Name_Loop_Variant))
29372 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29378 -- In CodePeer mode and GNATprove mode, we need to
29379 -- consider all assertions, unless they are disabled.
29380 -- Force Is_Checked on ignored assertions, in particular
29381 -- because transformations of the AST may depend on
29382 -- assertions being checked (e.g. the translation of
29383 -- attribute 'Loop_Entry).
29385 if CodePeer_Mode or GNATprove_Mode then
29386 Set_Is_Checked (N, True);
29387 Set_Is_Ignored (N, False);
29389 Set_Is_Checked (N, False);
29390 Set_Is_Ignored (N, True);
29396 Set_Is_Checked (N, True);
29397 Set_Is_Ignored (N, False);
29399 when Name_Disable =>
29400 Set_Is_Ignored (N, True);
29401 Set_Is_Checked (N, False);
29402 Set_Is_Disabled (N, True);
29404 -- That should be exhaustive, the null here is a defence
29405 -- against a malformed tree from previous errors.
29414 PP := Next_Pragma (PP);
29418 -- If there are no specific entries that matched, then we let the
29419 -- setting of assertions govern. Note that this provides the needed
29420 -- compatibility with the RM for the cases of assertion, invariant,
29421 -- precondition, predicate, and postcondition. Note also that
29422 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29424 if Assertions_Enabled then
29425 Set_Is_Checked (N, True);
29426 Set_Is_Ignored (N, False);
29428 Set_Is_Checked (N, False);
29429 Set_Is_Ignored (N, True);
29431 end Check_Applicable_Policy;
29433 -------------------------------
29434 -- Check_External_Properties --
29435 -------------------------------
29437 procedure Check_External_Properties
29445 -- All properties enabled
29447 if AR and AW and ER and EW then
29450 -- Async_Readers + Effective_Writes
29451 -- Async_Readers + Async_Writers + Effective_Writes
29453 elsif AR and EW and not ER then
29456 -- Async_Writers + Effective_Reads
29457 -- Async_Readers + Async_Writers + Effective_Reads
29459 elsif AW and ER and not EW then
29462 -- Async_Readers + Async_Writers
29464 elsif AR and AW and not ER and not EW then
29469 elsif AR and not AW and not ER and not EW then
29474 elsif AW and not AR and not ER and not EW then
29479 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29482 end Check_External_Properties;
29488 function Check_Kind (Nam : Name_Id) return Name_Id is
29492 -- Loop through entries in check policy list
29494 PP := Opt.Check_Policy_List;
29495 while Present (PP) loop
29497 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29498 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29502 or else (Pnm = Name_Assertion
29503 and then Is_Valid_Assertion_Kind (Nam))
29504 or else (Pnm = Name_Statement_Assertions
29505 and then Nam_In (Nam, Name_Assert,
29506 Name_Assert_And_Cut,
29508 Name_Loop_Invariant,
29509 Name_Loop_Variant))
29511 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29520 return Name_Ignore;
29522 when Name_Disable =>
29523 return Name_Disable;
29526 raise Program_Error;
29530 PP := Next_Pragma (PP);
29535 -- If there are no specific entries that matched, then we let the
29536 -- setting of assertions govern. Note that this provides the needed
29537 -- compatibility with the RM for the cases of assertion, invariant,
29538 -- precondition, predicate, and postcondition.
29540 if Assertions_Enabled then
29543 return Name_Ignore;
29547 ---------------------------
29548 -- Check_Missing_Part_Of --
29549 ---------------------------
29551 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29552 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29553 -- Determine whether a package denoted by Pack_Id declares at least one
29556 -----------------------
29557 -- Has_Visible_State --
29558 -----------------------
29560 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29561 Item_Id : Entity_Id;
29564 -- Traverse the entity chain of the package trying to find at least
29565 -- one visible abstract state, variable or a package [instantiation]
29566 -- that declares a visible state.
29568 Item_Id := First_Entity (Pack_Id);
29569 while Present (Item_Id)
29570 and then not In_Private_Part (Item_Id)
29572 -- Do not consider internally generated items
29574 if not Comes_From_Source (Item_Id) then
29577 -- Do not consider generic formals or their corresponding actuals
29578 -- because they are not part of a visible state. Note that both
29579 -- entities are marked as hidden.
29581 elsif Is_Hidden (Item_Id) then
29584 -- A visible state has been found. Note that constants are not
29585 -- considered here because it is not possible to determine whether
29586 -- they depend on variable input. This check is left to the SPARK
29589 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
29592 -- Recursively peek into nested packages and instantiations
29594 elsif Ekind (Item_Id) = E_Package
29595 and then Has_Visible_State (Item_Id)
29600 Next_Entity (Item_Id);
29604 end Has_Visible_State;
29608 Pack_Id : Entity_Id;
29609 Placement : State_Space_Kind;
29611 -- Start of processing for Check_Missing_Part_Of
29614 -- Do not consider abstract states, variables or package instantiations
29615 -- coming from an instance as those always inherit the Part_Of indicator
29616 -- of the instance itself.
29618 if In_Instance then
29621 -- Do not consider internally generated entities as these can never
29622 -- have a Part_Of indicator.
29624 elsif not Comes_From_Source (Item_Id) then
29627 -- Perform these checks only when SPARK_Mode is enabled as they will
29628 -- interfere with standard Ada rules and produce false positives.
29630 elsif SPARK_Mode /= On then
29633 -- Do not consider constants, because the compiler cannot accurately
29634 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29635 -- act as a hidden state of a package.
29637 elsif Ekind (Item_Id) = E_Constant then
29641 -- Find where the abstract state, variable or package instantiation
29642 -- lives with respect to the state space.
29644 Find_Placement_In_State_Space
29645 (Item_Id => Item_Id,
29646 Placement => Placement,
29647 Pack_Id => Pack_Id);
29649 -- Items that appear in a non-package construct (subprogram, block, etc)
29650 -- do not require a Part_Of indicator because they can never act as a
29653 if Placement = Not_In_Package then
29656 -- An item declared in the body state space of a package always act as a
29657 -- constituent and does not need explicit Part_Of indicator.
29659 elsif Placement = Body_State_Space then
29662 -- In general an item declared in the visible state space of a package
29663 -- does not require a Part_Of indicator. The only exception is when the
29664 -- related package is a nongeneric private child unit, in which case
29665 -- Part_Of must denote a state in the parent unit or in one of its
29668 elsif Placement = Visible_State_Space then
29669 if Is_Child_Unit (Pack_Id)
29670 and then not Is_Generic_Unit (Pack_Id)
29671 and then Is_Private_Descendant (Pack_Id)
29673 -- A package instantiation does not need a Part_Of indicator when
29674 -- the related generic template has no visible state.
29676 if Ekind (Item_Id) = E_Package
29677 and then Is_Generic_Instance (Item_Id)
29678 and then not Has_Visible_State (Item_Id)
29682 -- All other cases require Part_Of
29686 ("indicator Part_Of is required in this context "
29687 & "(SPARK RM 7.2.6(3))", Item_Id);
29688 Error_Msg_Name_1 := Chars (Pack_Id);
29690 ("\& is declared in the visible part of private child "
29691 & "unit %", Item_Id);
29695 -- When the item appears in the private state space of a package, it
29696 -- must be a part of some state declared by the said package.
29698 else pragma Assert (Placement = Private_State_Space);
29700 -- The related package does not declare a state, the item cannot act
29701 -- as a Part_Of constituent.
29703 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29706 -- A package instantiation does not need a Part_Of indicator when the
29707 -- related generic template has no visible state.
29709 elsif Ekind (Item_Id) = E_Package
29710 and then Is_Generic_Instance (Item_Id)
29711 and then not Has_Visible_State (Item_Id)
29715 -- All other cases require Part_Of
29719 ("indicator Part_Of is required in this context "
29720 & "(SPARK RM 7.2.6(2))", Item_Id);
29721 Error_Msg_Name_1 := Chars (Pack_Id);
29723 ("\& is declared in the private part of package %", Item_Id);
29726 end Check_Missing_Part_Of;
29728 ---------------------------------------------------
29729 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29730 ---------------------------------------------------
29732 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29734 Spec_Id : Entity_Id)
29737 if Warn_On_Redundant_Constructs
29738 and then Has_Pragma_Inline_Always (Spec_Id)
29739 and then Assertions_Enabled
29741 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29743 if From_Aspect_Specification (Prag) then
29745 ("aspect % not enforced on inlined subprogram &?r?",
29746 Corresponding_Aspect (Prag), Spec_Id);
29749 ("pragma % not enforced on inlined subprogram &?r?",
29753 end Check_Postcondition_Use_In_Inlined_Subprogram;
29755 -------------------------------------
29756 -- Check_State_And_Constituent_Use --
29757 -------------------------------------
29759 procedure Check_State_And_Constituent_Use
29760 (States : Elist_Id;
29761 Constits : Elist_Id;
29764 Constit_Elmt : Elmt_Id;
29765 Constit_Id : Entity_Id;
29766 State_Id : Entity_Id;
29769 -- Nothing to do if there are no states or constituents
29771 if No (States) or else No (Constits) then
29775 -- Inspect the list of constituents and try to determine whether its
29776 -- encapsulating state is in list States.
29778 Constit_Elmt := First_Elmt (Constits);
29779 while Present (Constit_Elmt) loop
29780 Constit_Id := Node (Constit_Elmt);
29782 -- Determine whether the constituent is part of an encapsulating
29783 -- state that appears in the same context and if this is the case,
29784 -- emit an error (SPARK RM 7.2.6(7)).
29786 State_Id := Find_Encapsulating_State (States, Constit_Id);
29788 if Present (State_Id) then
29789 Error_Msg_Name_1 := Chars (Constit_Id);
29791 ("cannot mention state & and its constituent % in the same "
29792 & "context", Context, State_Id);
29796 Next_Elmt (Constit_Elmt);
29798 end Check_State_And_Constituent_Use;
29800 ---------------------------------------------
29801 -- Collect_Inherited_Class_Wide_Conditions --
29802 ---------------------------------------------
29804 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29805 Parent_Subp : constant Entity_Id :=
29806 Ultimate_Alias (Overridden_Operation (Subp));
29807 -- The Overridden_Operation may itself be inherited and as such have no
29808 -- explicit contract.
29810 Prags : constant Node_Id := Contract (Parent_Subp);
29811 In_Spec_Expr : Boolean;
29812 Installed : Boolean;
29814 New_Prag : Node_Id;
29817 Installed := False;
29819 -- Iterate over the contract of the overridden subprogram to find all
29820 -- inherited class-wide pre- and postconditions.
29822 if Present (Prags) then
29823 Prag := Pre_Post_Conditions (Prags);
29825 while Present (Prag) loop
29826 if Nam_In (Pragma_Name_Unmapped (Prag),
29827 Name_Precondition, Name_Postcondition)
29828 and then Class_Present (Prag)
29830 -- The generated pragma must be analyzed in the context of
29831 -- the subprogram, to make its formals visible. In addition,
29832 -- we must inhibit freezing and full analysis because the
29833 -- controlling type of the subprogram is not frozen yet, and
29834 -- may have further primitives.
29836 if not Installed then
29839 Install_Formals (Subp);
29840 In_Spec_Expr := In_Spec_Expression;
29841 In_Spec_Expression := True;
29845 Build_Pragma_Check_Equivalent
29846 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29848 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29849 Preanalyze (New_Prag);
29851 -- Prevent further analysis in subsequent processing of the
29852 -- current list of declarations
29854 Set_Analyzed (New_Prag);
29857 Prag := Next_Pragma (Prag);
29861 In_Spec_Expression := In_Spec_Expr;
29865 end Collect_Inherited_Class_Wide_Conditions;
29867 ---------------------------------------
29868 -- Collect_Subprogram_Inputs_Outputs --
29869 ---------------------------------------
29871 procedure Collect_Subprogram_Inputs_Outputs
29872 (Subp_Id : Entity_Id;
29873 Synthesize : Boolean := False;
29874 Subp_Inputs : in out Elist_Id;
29875 Subp_Outputs : in out Elist_Id;
29876 Global_Seen : out Boolean)
29878 procedure Collect_Dependency_Clause (Clause : Node_Id);
29879 -- Collect all relevant items from a dependency clause
29881 procedure Collect_Global_List
29883 Mode : Name_Id := Name_Input);
29884 -- Collect all relevant items from a global list
29886 -------------------------------
29887 -- Collect_Dependency_Clause --
29888 -------------------------------
29890 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29891 procedure Collect_Dependency_Item
29893 Is_Input : Boolean);
29894 -- Add an item to the proper subprogram input or output collection
29896 -----------------------------
29897 -- Collect_Dependency_Item --
29898 -----------------------------
29900 procedure Collect_Dependency_Item
29902 Is_Input : Boolean)
29907 -- Nothing to collect when the item is null
29909 if Nkind (Item) = N_Null then
29912 -- Ditto for attribute 'Result
29914 elsif Is_Attribute_Result (Item) then
29917 -- Multiple items appear as an aggregate
29919 elsif Nkind (Item) = N_Aggregate then
29920 Extra := First (Expressions (Item));
29921 while Present (Extra) loop
29922 Collect_Dependency_Item (Extra, Is_Input);
29926 -- Otherwise this is a solitary item
29930 Append_New_Elmt (Item, Subp_Inputs);
29932 Append_New_Elmt (Item, Subp_Outputs);
29935 end Collect_Dependency_Item;
29937 -- Start of processing for Collect_Dependency_Clause
29940 if Nkind (Clause) = N_Null then
29943 -- A dependency clause appears as component association
29945 elsif Nkind (Clause) = N_Component_Association then
29946 Collect_Dependency_Item
29947 (Item => Expression (Clause),
29950 Collect_Dependency_Item
29951 (Item => First (Choices (Clause)),
29952 Is_Input => False);
29954 -- To accommodate partial decoration of disabled SPARK features, this
29955 -- routine may be called with illegal input. If this is the case, do
29956 -- not raise Program_Error.
29961 end Collect_Dependency_Clause;
29963 -------------------------
29964 -- Collect_Global_List --
29965 -------------------------
29967 procedure Collect_Global_List
29969 Mode : Name_Id := Name_Input)
29971 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
29972 -- Add an item to the proper subprogram input or output collection
29974 -------------------------
29975 -- Collect_Global_Item --
29976 -------------------------
29978 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
29980 if Nam_In (Mode, Name_In_Out, Name_Input) then
29981 Append_New_Elmt (Item, Subp_Inputs);
29984 if Nam_In (Mode, Name_In_Out, Name_Output) then
29985 Append_New_Elmt (Item, Subp_Outputs);
29987 end Collect_Global_Item;
29994 -- Start of processing for Collect_Global_List
29997 if Nkind (List) = N_Null then
30000 -- Single global item declaration
30002 elsif Nkind_In (List, N_Expanded_Name,
30004 N_Selected_Component)
30006 Collect_Global_Item (List, Mode);
30008 -- Simple global list or moded global list declaration
30010 elsif Nkind (List) = N_Aggregate then
30011 if Present (Expressions (List)) then
30012 Item := First (Expressions (List));
30013 while Present (Item) loop
30014 Collect_Global_Item (Item, Mode);
30019 Assoc := First (Component_Associations (List));
30020 while Present (Assoc) loop
30021 Collect_Global_List
30022 (List => Expression (Assoc),
30023 Mode => Chars (First (Choices (Assoc))));
30028 -- To accommodate partial decoration of disabled SPARK features, this
30029 -- routine may be called with illegal input. If this is the case, do
30030 -- not raise Program_Error.
30035 end Collect_Global_List;
30042 Formal : Entity_Id;
30044 Spec_Id : Entity_Id := Empty;
30045 Subp_Decl : Node_Id;
30048 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30051 Global_Seen := False;
30053 -- Process all formal parameters of entries, [generic] subprograms, and
30056 if Ekind_In (Subp_Id, E_Entry,
30059 E_Generic_Function,
30060 E_Generic_Procedure,
30064 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30065 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30067 -- Process all formal parameters
30069 Formal := First_Entity (Spec_Id);
30070 while Present (Formal) loop
30071 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
30072 Append_New_Elmt (Formal, Subp_Inputs);
30075 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
30076 Append_New_Elmt (Formal, Subp_Outputs);
30078 -- Out parameters can act as inputs when the related type is
30079 -- tagged, unconstrained array, unconstrained record, or record
30080 -- with unconstrained components.
30082 if Ekind (Formal) = E_Out_Parameter
30083 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30085 Append_New_Elmt (Formal, Subp_Inputs);
30089 Next_Entity (Formal);
30092 -- Otherwise the input denotes a task type, a task body, or the
30093 -- anonymous object created for a single task type.
30095 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
30096 or else Is_Single_Task_Object (Subp_Id)
30098 Subp_Decl := Declaration_Node (Subp_Id);
30099 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30102 -- When processing an entry, subprogram or task body, look for pragmas
30103 -- Refined_Depends and Refined_Global as they specify the inputs and
30106 if Is_Entry_Body (Subp_Id)
30107 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
30109 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30110 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30112 -- Subprogram declaration or stand-alone body case, look for pragmas
30113 -- Depends and Global
30116 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30117 Global := Get_Pragma (Spec_Id, Pragma_Global);
30120 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30121 -- because it provides finer granularity of inputs and outputs.
30123 if Present (Global) then
30124 Global_Seen := True;
30125 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30127 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30128 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30129 -- the inputs and outputs from [Refined_]Depends.
30131 elsif Synthesize and then Present (Depends) then
30132 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30134 -- Multiple dependency clauses appear as an aggregate
30136 if Nkind (Clauses) = N_Aggregate then
30137 Clause := First (Component_Associations (Clauses));
30138 while Present (Clause) loop
30139 Collect_Dependency_Clause (Clause);
30143 -- Otherwise this is a single dependency clause
30146 Collect_Dependency_Clause (Clauses);
30150 -- The current instance of a protected type acts as a formal parameter
30151 -- of mode IN for functions and IN OUT for entries and procedures
30152 -- (SPARK RM 6.1.4).
30154 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30155 Typ := Scope (Spec_Id);
30157 -- Use the anonymous object when the type is single protected
30159 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30160 Typ := Anonymous_Object (Typ);
30163 Append_New_Elmt (Typ, Subp_Inputs);
30165 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
30166 Append_New_Elmt (Typ, Subp_Outputs);
30169 -- The current instance of a task type acts as a formal parameter of
30170 -- mode IN OUT (SPARK RM 6.1.4).
30172 elsif Ekind (Spec_Id) = E_Task_Type then
30175 -- Use the anonymous object when the type is single task
30177 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30178 Typ := Anonymous_Object (Typ);
30181 Append_New_Elmt (Typ, Subp_Inputs);
30182 Append_New_Elmt (Typ, Subp_Outputs);
30184 elsif Is_Single_Task_Object (Spec_Id) then
30185 Append_New_Elmt (Spec_Id, Subp_Inputs);
30186 Append_New_Elmt (Spec_Id, Subp_Outputs);
30188 end Collect_Subprogram_Inputs_Outputs;
30190 ---------------------------
30191 -- Contract_Freeze_Error --
30192 ---------------------------
30194 procedure Contract_Freeze_Error
30195 (Contract_Id : Entity_Id;
30196 Freeze_Id : Entity_Id)
30199 Error_Msg_Name_1 := Chars (Contract_Id);
30200 Error_Msg_Sloc := Sloc (Freeze_Id);
30203 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30205 ("\all contractual items must be declared before body #", Contract_Id);
30206 end Contract_Freeze_Error;
30208 ---------------------------------
30209 -- Delay_Config_Pragma_Analyze --
30210 ---------------------------------
30212 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30214 return Nam_In (Pragma_Name_Unmapped (N),
30215 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
30216 end Delay_Config_Pragma_Analyze;
30218 -----------------------
30219 -- Duplication_Error --
30220 -----------------------
30222 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30223 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30224 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30227 Error_Msg_Sloc := Sloc (Prev);
30228 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30230 -- Emit a precise message to distinguish between source pragmas and
30231 -- pragmas generated from aspects. The ordering of the two pragmas is
30235 -- Prag -- duplicate
30237 -- No error is emitted when both pragmas come from aspects because this
30238 -- is already detected by the general aspect analysis mechanism.
30240 if Prag_From_Asp and Prev_From_Asp then
30242 elsif Prag_From_Asp then
30243 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30244 elsif Prev_From_Asp then
30245 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30247 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30249 end Duplication_Error;
30251 ------------------------------
30252 -- Find_Encapsulating_State --
30253 ------------------------------
30255 function Find_Encapsulating_State
30256 (States : Elist_Id;
30257 Constit_Id : Entity_Id) return Entity_Id
30259 State_Id : Entity_Id;
30262 -- Since a constituent may be part of a larger constituent set, climb
30263 -- the encapsulating state chain looking for a state that appears in
30266 State_Id := Encapsulating_State (Constit_Id);
30267 while Present (State_Id) loop
30268 if Contains (States, State_Id) then
30272 State_Id := Encapsulating_State (State_Id);
30276 end Find_Encapsulating_State;
30278 --------------------------
30279 -- Find_Related_Context --
30280 --------------------------
30282 function Find_Related_Context
30284 Do_Checks : Boolean := False) return Node_Id
30289 Stmt := Prev (Prag);
30290 while Present (Stmt) loop
30292 -- Skip prior pragmas, but check for duplicates
30294 if Nkind (Stmt) = N_Pragma then
30296 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30303 -- Skip internally generated code
30305 elsif not Comes_From_Source (Stmt) then
30307 -- The anonymous object created for a single concurrent type is a
30308 -- suitable context.
30310 if Nkind (Stmt) = N_Object_Declaration
30311 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30316 -- Return the current source construct
30326 end Find_Related_Context;
30328 --------------------------------------
30329 -- Find_Related_Declaration_Or_Body --
30330 --------------------------------------
30332 function Find_Related_Declaration_Or_Body
30334 Do_Checks : Boolean := False) return Node_Id
30336 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30338 procedure Expression_Function_Error;
30339 -- Emit an error concerning pragma Prag that illegaly applies to an
30340 -- expression function.
30342 -------------------------------
30343 -- Expression_Function_Error --
30344 -------------------------------
30346 procedure Expression_Function_Error is
30348 Error_Msg_Name_1 := Prag_Nam;
30350 -- Emit a precise message to distinguish between source pragmas and
30351 -- pragmas generated from aspects.
30353 if From_Aspect_Specification (Prag) then
30355 ("aspect % cannot apply to a stand alone expression function",
30359 ("pragma % cannot apply to a stand alone expression function",
30362 end Expression_Function_Error;
30366 Context : constant Node_Id := Parent (Prag);
30369 Look_For_Body : constant Boolean :=
30370 Nam_In (Prag_Nam, Name_Refined_Depends,
30371 Name_Refined_Global,
30373 Name_Refined_State);
30374 -- Refinement pragmas must be associated with a subprogram body [stub]
30376 -- Start of processing for Find_Related_Declaration_Or_Body
30379 Stmt := Prev (Prag);
30380 while Present (Stmt) loop
30382 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30383 -- by splitting a complex pre/postcondition are not considered to
30386 if Nkind (Stmt) = N_Pragma then
30388 and then not Split_PPC (Stmt)
30389 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30396 -- Emit an error when a refinement pragma appears on an expression
30397 -- function without a completion.
30400 and then Look_For_Body
30401 and then Nkind (Stmt) = N_Subprogram_Declaration
30402 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30403 and then not Has_Completion (Defining_Entity (Stmt))
30405 Expression_Function_Error;
30408 -- The refinement pragma applies to a subprogram body stub
30410 elsif Look_For_Body
30411 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30415 -- Skip internally generated code
30417 elsif not Comes_From_Source (Stmt) then
30419 -- The anonymous object created for a single concurrent type is a
30420 -- suitable context.
30422 if Nkind (Stmt) = N_Object_Declaration
30423 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30427 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30429 -- The subprogram declaration is an internally generated spec
30430 -- for an expression function.
30432 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30435 -- The subprogram declaration is an internally generated spec
30436 -- for a stand-alone subrogram body declared inside a protected
30439 elsif Present (Corresponding_Body (Stmt))
30440 and then Comes_From_Source (Corresponding_Body (Stmt))
30441 and then Is_Protected_Type (Current_Scope)
30445 -- The subprogram is actually an instance housed within an
30446 -- anonymous wrapper package.
30448 elsif Present (Generic_Parent (Specification (Stmt))) then
30453 -- Return the current construct which is either a subprogram body,
30454 -- a subprogram declaration or is illegal.
30463 -- If we fall through, then the pragma was either the first declaration
30464 -- or it was preceded by other pragmas and no source constructs.
30466 -- The pragma is associated with a library-level subprogram
30468 if Nkind (Context) = N_Compilation_Unit_Aux then
30469 return Unit (Parent (Context));
30471 -- The pragma appears inside the declarations of an entry body
30473 elsif Nkind (Context) = N_Entry_Body then
30476 -- The pragma appears inside the statements of a subprogram body. This
30477 -- placement is the result of subprogram contract expansion.
30479 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30480 return Parent (Context);
30482 -- The pragma appears inside the declarative part of a package body
30484 elsif Nkind (Context) = N_Package_Body then
30487 -- The pragma appears inside the declarative part of a subprogram body
30489 elsif Nkind (Context) = N_Subprogram_Body then
30492 -- The pragma appears inside the declarative part of a task body
30494 elsif Nkind (Context) = N_Task_Body then
30497 -- The pragma appears inside the visible part of a package specification
30499 elsif Nkind (Context) = N_Package_Specification then
30500 return Parent (Context);
30502 -- The pragma is a byproduct of aspect expansion, return the related
30503 -- context of the original aspect. This case has a lower priority as
30504 -- the above circuitry pinpoints precisely the related context.
30506 elsif Present (Corresponding_Aspect (Prag)) then
30507 return Parent (Corresponding_Aspect (Prag));
30509 -- No candidate subprogram [body] found
30514 end Find_Related_Declaration_Or_Body;
30516 ----------------------------------
30517 -- Find_Related_Package_Or_Body --
30518 ----------------------------------
30520 function Find_Related_Package_Or_Body
30522 Do_Checks : Boolean := False) return Node_Id
30524 Context : constant Node_Id := Parent (Prag);
30525 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30529 Stmt := Prev (Prag);
30530 while Present (Stmt) loop
30532 -- Skip prior pragmas, but check for duplicates
30534 if Nkind (Stmt) = N_Pragma then
30535 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30541 -- Skip internally generated code
30543 elsif not Comes_From_Source (Stmt) then
30544 if Nkind (Stmt) = N_Subprogram_Declaration then
30546 -- The subprogram declaration is an internally generated spec
30547 -- for an expression function.
30549 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30552 -- The subprogram is actually an instance housed within an
30553 -- anonymous wrapper package.
30555 elsif Present (Generic_Parent (Specification (Stmt))) then
30560 -- Return the current source construct which is illegal
30569 -- If we fall through, then the pragma was either the first declaration
30570 -- or it was preceded by other pragmas and no source constructs.
30572 -- The pragma is associated with a package. The immediate context in
30573 -- this case is the specification of the package.
30575 if Nkind (Context) = N_Package_Specification then
30576 return Parent (Context);
30578 -- The pragma appears in the declarations of a package body
30580 elsif Nkind (Context) = N_Package_Body then
30583 -- The pragma appears in the statements of a package body
30585 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30586 and then Nkind (Parent (Context)) = N_Package_Body
30588 return Parent (Context);
30590 -- The pragma is a byproduct of aspect expansion, return the related
30591 -- context of the original aspect. This case has a lower priority as
30592 -- the above circuitry pinpoints precisely the related context.
30594 elsif Present (Corresponding_Aspect (Prag)) then
30595 return Parent (Corresponding_Aspect (Prag));
30597 -- No candidate package [body] found
30602 end Find_Related_Package_Or_Body;
30608 function Get_Argument
30610 Context_Id : Entity_Id := Empty) return Node_Id
30612 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30615 -- Use the expression of the original aspect when compiling for ASIS or
30616 -- when analyzing the template of a generic unit. In both cases the
30617 -- aspect's tree must be decorated to allow for ASIS queries or to save
30618 -- the global references in the generic context.
30620 if From_Aspect_Specification (Prag)
30621 and then (ASIS_Mode or else (Present (Context_Id)
30622 and then Is_Generic_Unit (Context_Id)))
30624 return Corresponding_Aspect (Prag);
30626 -- Otherwise use the expression of the pragma
30628 elsif Present (Args) then
30629 return First (Args);
30636 -------------------------
30637 -- Get_Base_Subprogram --
30638 -------------------------
30640 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30642 -- Follow subprogram renaming chain
30644 if Is_Subprogram (Def_Id)
30645 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30646 N_Subprogram_Renaming_Declaration
30647 and then Present (Alias (Def_Id))
30649 return Alias (Def_Id);
30653 end Get_Base_Subprogram;
30655 -----------------------
30656 -- Get_SPARK_Mode_Type --
30657 -----------------------
30659 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30661 if N = Name_On then
30663 elsif N = Name_Off then
30666 -- Any other argument is illegal. Assume that no SPARK mode applies to
30667 -- avoid potential cascaded errors.
30672 end Get_SPARK_Mode_Type;
30674 ------------------------------------
30675 -- Get_SPARK_Mode_From_Annotation --
30676 ------------------------------------
30678 function Get_SPARK_Mode_From_Annotation
30679 (N : Node_Id) return SPARK_Mode_Type
30684 if Nkind (N) = N_Aspect_Specification then
30685 Mode := Expression (N);
30687 else pragma Assert (Nkind (N) = N_Pragma);
30688 Mode := First (Pragma_Argument_Associations (N));
30690 if Present (Mode) then
30691 Mode := Get_Pragma_Arg (Mode);
30695 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30697 if Present (Mode) then
30698 if Nkind (Mode) = N_Identifier then
30699 return Get_SPARK_Mode_Type (Chars (Mode));
30701 -- In case of a malformed aspect or pragma, return the default None
30707 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30712 end Get_SPARK_Mode_From_Annotation;
30714 ---------------------------
30715 -- Has_Extra_Parentheses --
30716 ---------------------------
30718 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30722 -- The aggregate should not have an expression list because a clause
30723 -- is always interpreted as a component association. The only way an
30724 -- expression list can sneak in is by adding extra parentheses around
30725 -- the individual clauses:
30727 -- Depends (Output => Input) -- proper form
30728 -- Depends ((Output => Input)) -- extra parentheses
30730 -- Since the extra parentheses are not allowed by the syntax of the
30731 -- pragma, flag them now to avoid emitting misleading errors down the
30734 if Nkind (Clause) = N_Aggregate
30735 and then Present (Expressions (Clause))
30737 Expr := First (Expressions (Clause));
30738 while Present (Expr) loop
30740 -- A dependency clause surrounded by extra parentheses appears
30741 -- as an aggregate of component associations with an optional
30742 -- Paren_Count set.
30744 if Nkind (Expr) = N_Aggregate
30745 and then Present (Component_Associations (Expr))
30748 ("dependency clause contains extra parentheses", Expr);
30750 -- Otherwise the expression is a malformed construct
30753 SPARK_Msg_N ("malformed dependency clause", Expr);
30763 end Has_Extra_Parentheses;
30769 procedure Initialize is
30772 Compile_Time_Warnings_Errors.Init;
30781 Dummy := Dummy + 1;
30784 -----------------------------
30785 -- Is_Config_Static_String --
30786 -----------------------------
30788 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30790 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30791 -- This is an internal recursive function that is just like the outer
30792 -- function except that it adds the string to the name buffer rather
30793 -- than placing the string in the name buffer.
30795 ------------------------------
30796 -- Add_Config_Static_String --
30797 ------------------------------
30799 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30806 if Nkind (N) = N_Op_Concat then
30807 if Add_Config_Static_String (Left_Opnd (N)) then
30808 N := Right_Opnd (N);
30814 if Nkind (N) /= N_String_Literal then
30815 Error_Msg_N ("string literal expected for pragma argument", N);
30819 for J in 1 .. String_Length (Strval (N)) loop
30820 C := Get_String_Char (Strval (N), J);
30822 if not In_Character_Range (C) then
30824 ("string literal contains invalid wide character",
30825 Sloc (N) + 1 + Source_Ptr (J));
30829 Add_Char_To_Name_Buffer (Get_Character (C));
30834 end Add_Config_Static_String;
30836 -- Start of processing for Is_Config_Static_String
30841 return Add_Config_Static_String (Arg);
30842 end Is_Config_Static_String;
30844 -------------------------------
30845 -- Is_Elaboration_SPARK_Mode --
30846 -------------------------------
30848 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30851 (Nkind (N) = N_Pragma
30852 and then Pragma_Name (N) = Name_SPARK_Mode
30853 and then Is_List_Member (N));
30855 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30856 -- appears in the statement part of the body.
30859 Present (Parent (N))
30860 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30861 and then List_Containing (N) = Statements (Parent (N))
30862 and then Present (Parent (Parent (N)))
30863 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30864 end Is_Elaboration_SPARK_Mode;
30866 -----------------------
30867 -- Is_Enabled_Pragma --
30868 -----------------------
30870 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30874 if Present (Prag) then
30875 Arg := First (Pragma_Argument_Associations (Prag));
30877 if Present (Arg) then
30878 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30880 -- The lack of a Boolean argument automatically enables the pragma
30886 -- The pragma is missing, therefore it is not enabled
30891 end Is_Enabled_Pragma;
30893 -----------------------------------------
30894 -- Is_Non_Significant_Pragma_Reference --
30895 -----------------------------------------
30897 -- This function makes use of the following static table which indicates
30898 -- whether appearance of some name in a given pragma is to be considered
30899 -- as a reference for the purposes of warnings about unreferenced objects.
30901 -- -1 indicates that appearence in any argument is significant
30902 -- 0 indicates that appearance in any argument is not significant
30903 -- +n indicates that appearance as argument n is significant, but all
30904 -- other arguments are not significant
30905 -- 9n arguments from n on are significant, before n insignificant
30907 Sig_Flags : constant array (Pragma_Id) of Int :=
30908 (Pragma_Abort_Defer => -1,
30909 Pragma_Abstract_State => -1,
30910 Pragma_Acc_Data => 0,
30911 Pragma_Acc_Kernels => 0,
30912 Pragma_Acc_Loop => 0,
30913 Pragma_Acc_Parallel => 0,
30914 Pragma_Ada_83 => -1,
30915 Pragma_Ada_95 => -1,
30916 Pragma_Ada_05 => -1,
30917 Pragma_Ada_2005 => -1,
30918 Pragma_Ada_12 => -1,
30919 Pragma_Ada_2012 => -1,
30920 Pragma_Ada_2020 => -1,
30921 Pragma_All_Calls_Remote => -1,
30922 Pragma_Allow_Integer_Address => -1,
30923 Pragma_Annotate => 93,
30924 Pragma_Assert => -1,
30925 Pragma_Assert_And_Cut => -1,
30926 Pragma_Assertion_Policy => 0,
30927 Pragma_Assume => -1,
30928 Pragma_Assume_No_Invalid_Values => 0,
30929 Pragma_Async_Readers => 0,
30930 Pragma_Async_Writers => 0,
30931 Pragma_Asynchronous => 0,
30932 Pragma_Atomic => 0,
30933 Pragma_Atomic_Components => 0,
30934 Pragma_Attach_Handler => -1,
30935 Pragma_Attribute_Definition => 92,
30936 Pragma_Check => -1,
30937 Pragma_Check_Float_Overflow => 0,
30938 Pragma_Check_Name => 0,
30939 Pragma_Check_Policy => 0,
30940 Pragma_CPP_Class => 0,
30941 Pragma_CPP_Constructor => 0,
30942 Pragma_CPP_Virtual => 0,
30943 Pragma_CPP_Vtable => 0,
30945 Pragma_C_Pass_By_Copy => 0,
30946 Pragma_Comment => -1,
30947 Pragma_Common_Object => 0,
30948 Pragma_Compile_Time_Error => -1,
30949 Pragma_Compile_Time_Warning => -1,
30950 Pragma_Compiler_Unit => -1,
30951 Pragma_Compiler_Unit_Warning => -1,
30952 Pragma_Complete_Representation => 0,
30953 Pragma_Complex_Representation => 0,
30954 Pragma_Component_Alignment => 0,
30955 Pragma_Constant_After_Elaboration => 0,
30956 Pragma_Contract_Cases => -1,
30957 Pragma_Controlled => 0,
30958 Pragma_Convention => 0,
30959 Pragma_Convention_Identifier => 0,
30960 Pragma_Deadline_Floor => -1,
30961 Pragma_Debug => -1,
30962 Pragma_Debug_Policy => 0,
30963 Pragma_Detect_Blocking => 0,
30964 Pragma_Default_Initial_Condition => -1,
30965 Pragma_Default_Scalar_Storage_Order => 0,
30966 Pragma_Default_Storage_Pool => 0,
30967 Pragma_Depends => -1,
30968 Pragma_Disable_Atomic_Synchronization => 0,
30969 Pragma_Discard_Names => 0,
30970 Pragma_Dispatching_Domain => -1,
30971 Pragma_Effective_Reads => 0,
30972 Pragma_Effective_Writes => 0,
30973 Pragma_Elaborate => 0,
30974 Pragma_Elaborate_All => 0,
30975 Pragma_Elaborate_Body => 0,
30976 Pragma_Elaboration_Checks => 0,
30977 Pragma_Eliminate => 0,
30978 Pragma_Enable_Atomic_Synchronization => 0,
30979 Pragma_Export => -1,
30980 Pragma_Export_Function => -1,
30981 Pragma_Export_Object => -1,
30982 Pragma_Export_Procedure => -1,
30983 Pragma_Export_Value => -1,
30984 Pragma_Export_Valued_Procedure => -1,
30985 Pragma_Extend_System => -1,
30986 Pragma_Extensions_Allowed => 0,
30987 Pragma_Extensions_Visible => 0,
30988 Pragma_External => -1,
30989 Pragma_Favor_Top_Level => 0,
30990 Pragma_External_Name_Casing => 0,
30991 Pragma_Fast_Math => 0,
30992 Pragma_Finalize_Storage_Only => 0,
30994 Pragma_Global => -1,
30995 Pragma_Ident => -1,
30996 Pragma_Ignore_Pragma => 0,
30997 Pragma_Implementation_Defined => -1,
30998 Pragma_Implemented => -1,
30999 Pragma_Implicit_Packing => 0,
31000 Pragma_Import => 93,
31001 Pragma_Import_Function => 0,
31002 Pragma_Import_Object => 0,
31003 Pragma_Import_Procedure => 0,
31004 Pragma_Import_Valued_Procedure => 0,
31005 Pragma_Independent => 0,
31006 Pragma_Independent_Components => 0,
31007 Pragma_Initial_Condition => -1,
31008 Pragma_Initialize_Scalars => 0,
31009 Pragma_Initializes => -1,
31010 Pragma_Inline => 0,
31011 Pragma_Inline_Always => 0,
31012 Pragma_Inline_Generic => 0,
31013 Pragma_Inspection_Point => -1,
31014 Pragma_Interface => 92,
31015 Pragma_Interface_Name => 0,
31016 Pragma_Interrupt_Handler => -1,
31017 Pragma_Interrupt_Priority => -1,
31018 Pragma_Interrupt_State => -1,
31019 Pragma_Invariant => -1,
31020 Pragma_Keep_Names => 0,
31021 Pragma_License => 0,
31022 Pragma_Link_With => -1,
31023 Pragma_Linker_Alias => -1,
31024 Pragma_Linker_Constructor => -1,
31025 Pragma_Linker_Destructor => -1,
31026 Pragma_Linker_Options => -1,
31027 Pragma_Linker_Section => -1,
31029 Pragma_Lock_Free => 0,
31030 Pragma_Locking_Policy => 0,
31031 Pragma_Loop_Invariant => -1,
31032 Pragma_Loop_Optimize => 0,
31033 Pragma_Loop_Variant => -1,
31034 Pragma_Machine_Attribute => -1,
31036 Pragma_Main_Storage => -1,
31037 Pragma_Max_Entry_Queue_Depth => 0,
31038 Pragma_Max_Entry_Queue_Length => 0,
31039 Pragma_Max_Queue_Length => 0,
31040 Pragma_Memory_Size => 0,
31041 Pragma_No_Body => 0,
31042 Pragma_No_Caching => 0,
31043 Pragma_No_Component_Reordering => -1,
31044 Pragma_No_Elaboration_Code_All => 0,
31045 Pragma_No_Heap_Finalization => 0,
31046 Pragma_No_Inline => 0,
31047 Pragma_No_Return => 0,
31048 Pragma_No_Run_Time => -1,
31049 Pragma_No_Strict_Aliasing => -1,
31050 Pragma_No_Tagged_Streams => 0,
31051 Pragma_Normalize_Scalars => 0,
31052 Pragma_Obsolescent => 0,
31053 Pragma_Optimize => 0,
31054 Pragma_Optimize_Alignment => 0,
31055 Pragma_Overflow_Mode => 0,
31056 Pragma_Overriding_Renamings => 0,
31057 Pragma_Ordered => 0,
31060 Pragma_Part_Of => 0,
31061 Pragma_Partition_Elaboration_Policy => 0,
31062 Pragma_Passive => 0,
31063 Pragma_Persistent_BSS => 0,
31064 Pragma_Polling => 0,
31065 Pragma_Prefix_Exception_Messages => 0,
31067 Pragma_Postcondition => -1,
31068 Pragma_Post_Class => -1,
31070 Pragma_Precondition => -1,
31071 Pragma_Predicate => -1,
31072 Pragma_Predicate_Failure => -1,
31073 Pragma_Preelaborable_Initialization => -1,
31074 Pragma_Preelaborate => 0,
31075 Pragma_Pre_Class => -1,
31076 Pragma_Priority => -1,
31077 Pragma_Priority_Specific_Dispatching => 0,
31078 Pragma_Profile => 0,
31079 Pragma_Profile_Warnings => 0,
31080 Pragma_Propagate_Exceptions => 0,
31081 Pragma_Provide_Shift_Operators => 0,
31082 Pragma_Psect_Object => 0,
31084 Pragma_Pure_Function => 0,
31085 Pragma_Queuing_Policy => 0,
31086 Pragma_Rational => 0,
31087 Pragma_Ravenscar => 0,
31088 Pragma_Refined_Depends => -1,
31089 Pragma_Refined_Global => -1,
31090 Pragma_Refined_Post => -1,
31091 Pragma_Refined_State => -1,
31092 Pragma_Relative_Deadline => 0,
31093 Pragma_Rename_Pragma => 0,
31094 Pragma_Remote_Access_Type => -1,
31095 Pragma_Remote_Call_Interface => -1,
31096 Pragma_Remote_Types => -1,
31097 Pragma_Restricted_Run_Time => 0,
31098 Pragma_Restriction_Warnings => 0,
31099 Pragma_Restrictions => 0,
31100 Pragma_Reviewable => -1,
31101 Pragma_Secondary_Stack_Size => -1,
31102 Pragma_Short_Circuit_And_Or => 0,
31103 Pragma_Share_Generic => 0,
31104 Pragma_Shared => 0,
31105 Pragma_Shared_Passive => 0,
31106 Pragma_Short_Descriptors => 0,
31107 Pragma_Simple_Storage_Pool_Type => 0,
31108 Pragma_Source_File_Name => 0,
31109 Pragma_Source_File_Name_Project => 0,
31110 Pragma_Source_Reference => 0,
31111 Pragma_SPARK_Mode => 0,
31112 Pragma_Storage_Size => -1,
31113 Pragma_Storage_Unit => 0,
31114 Pragma_Static_Elaboration_Desired => 0,
31115 Pragma_Stream_Convert => 0,
31116 Pragma_Style_Checks => 0,
31117 Pragma_Subtitle => 0,
31118 Pragma_Suppress => 0,
31119 Pragma_Suppress_Exception_Locations => 0,
31120 Pragma_Suppress_All => 0,
31121 Pragma_Suppress_Debug_Info => 0,
31122 Pragma_Suppress_Initialization => 0,
31123 Pragma_System_Name => 0,
31124 Pragma_Task_Dispatching_Policy => 0,
31125 Pragma_Task_Info => -1,
31126 Pragma_Task_Name => -1,
31127 Pragma_Task_Storage => -1,
31128 Pragma_Test_Case => -1,
31129 Pragma_Thread_Local_Storage => -1,
31130 Pragma_Time_Slice => -1,
31132 Pragma_Type_Invariant => -1,
31133 Pragma_Type_Invariant_Class => -1,
31134 Pragma_Unchecked_Union => 0,
31135 Pragma_Unevaluated_Use_Of_Old => 0,
31136 Pragma_Unimplemented_Unit => 0,
31137 Pragma_Universal_Aliasing => 0,
31138 Pragma_Universal_Data => 0,
31139 Pragma_Unmodified => 0,
31140 Pragma_Unreferenced => 0,
31141 Pragma_Unreferenced_Objects => 0,
31142 Pragma_Unreserve_All_Interrupts => 0,
31143 Pragma_Unsuppress => 0,
31144 Pragma_Unused => 0,
31145 Pragma_Use_VADS_Size => 0,
31146 Pragma_Validity_Checks => 0,
31147 Pragma_Volatile => 0,
31148 Pragma_Volatile_Components => 0,
31149 Pragma_Volatile_Full_Access => 0,
31150 Pragma_Volatile_Function => 0,
31151 Pragma_Warning_As_Error => 0,
31152 Pragma_Warnings => 0,
31153 Pragma_Weak_External => 0,
31154 Pragma_Wide_Character_Encoding => 0,
31155 Unknown_Pragma => 0);
31157 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31163 function Arg_No return Nat;
31164 -- Returns an integer showing what argument we are in. A value of
31165 -- zero means we are not in any of the arguments.
31171 function Arg_No return Nat is
31176 A := First (Pragma_Argument_Associations (Parent (P)));
31190 -- Start of processing for Non_Significant_Pragma_Reference
31195 if Nkind (P) /= N_Pragma_Argument_Association then
31199 Id := Get_Pragma_Id (Parent (P));
31200 C := Sig_Flags (Id);
31215 return AN < (C - 90);
31221 end Is_Non_Significant_Pragma_Reference;
31223 ------------------------------
31224 -- Is_Pragma_String_Literal --
31225 ------------------------------
31227 -- This function returns true if the corresponding pragma argument is a
31228 -- static string expression. These are the only cases in which string
31229 -- literals can appear as pragma arguments. We also allow a string literal
31230 -- as the first argument to pragma Assert (although it will of course
31231 -- always generate a type error).
31233 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31234 Pragn : constant Node_Id := Parent (Par);
31235 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31236 Pname : constant Name_Id := Pragma_Name (Pragn);
31242 N := First (Assoc);
31249 if Pname = Name_Assert then
31252 elsif Pname = Name_Export then
31255 elsif Pname = Name_Ident then
31258 elsif Pname = Name_Import then
31261 elsif Pname = Name_Interface_Name then
31264 elsif Pname = Name_Linker_Alias then
31267 elsif Pname = Name_Linker_Section then
31270 elsif Pname = Name_Machine_Attribute then
31273 elsif Pname = Name_Source_File_Name then
31276 elsif Pname = Name_Source_Reference then
31279 elsif Pname = Name_Title then
31282 elsif Pname = Name_Subtitle then
31288 end Is_Pragma_String_Literal;
31290 ---------------------------
31291 -- Is_Private_SPARK_Mode --
31292 ---------------------------
31294 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31297 (Nkind (N) = N_Pragma
31298 and then Pragma_Name (N) = Name_SPARK_Mode
31299 and then Is_List_Member (N));
31301 -- For pragma SPARK_Mode to be private, it has to appear in the private
31302 -- declarations of a package.
31305 Present (Parent (N))
31306 and then Nkind (Parent (N)) = N_Package_Specification
31307 and then List_Containing (N) = Private_Declarations (Parent (N));
31308 end Is_Private_SPARK_Mode;
31310 -------------------------------------
31311 -- Is_Unconstrained_Or_Tagged_Item --
31312 -------------------------------------
31314 function Is_Unconstrained_Or_Tagged_Item
31315 (Item : Entity_Id) return Boolean
31317 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31318 -- Determine whether record type Typ has at least one unconstrained
31321 ---------------------------------
31322 -- Has_Unconstrained_Component --
31323 ---------------------------------
31325 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31329 Comp := First_Component (Typ);
31330 while Present (Comp) loop
31331 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31335 Next_Component (Comp);
31339 end Has_Unconstrained_Component;
31343 Typ : constant Entity_Id := Etype (Item);
31345 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31348 if Is_Tagged_Type (Typ) then
31351 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31354 elsif Is_Record_Type (Typ) then
31355 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31358 return Has_Unconstrained_Component (Typ);
31361 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31367 end Is_Unconstrained_Or_Tagged_Item;
31369 -----------------------------
31370 -- Is_Valid_Assertion_Kind --
31371 -----------------------------
31373 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31380 | Name_Assertion_Policy
31381 | Name_Static_Predicate
31382 | Name_Dynamic_Predicate
31387 | Name_Type_Invariant
31388 | Name_uType_Invariant
31392 | Name_Assert_And_Cut
31394 | Name_Contract_Cases
31396 | Name_Default_Initial_Condition
31398 | Name_Initial_Condition
31401 | Name_Loop_Invariant
31402 | Name_Loop_Variant
31403 | Name_Postcondition
31404 | Name_Precondition
31406 | Name_Refined_Post
31407 | Name_Statement_Assertions
31414 end Is_Valid_Assertion_Kind;
31416 --------------------------------------
31417 -- Process_Compilation_Unit_Pragmas --
31418 --------------------------------------
31420 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31422 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31423 -- strange because it comes at the end of the unit. Rational has the
31424 -- same name for a pragma, but treats it as a program unit pragma, In
31425 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31426 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31427 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31428 -- the context clause to ensure the correct processing.
31430 if Has_Pragma_Suppress_All (N) then
31431 Prepend_To (Context_Items (N),
31432 Make_Pragma (Sloc (N),
31433 Chars => Name_Suppress,
31434 Pragma_Argument_Associations => New_List (
31435 Make_Pragma_Argument_Association (Sloc (N),
31436 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31439 -- Nothing else to do at the current time
31441 end Process_Compilation_Unit_Pragmas;
31443 --------------------------------------------
31444 -- Validate_Compile_Time_Warning_Or_Error --
31445 --------------------------------------------
31447 procedure Validate_Compile_Time_Warning_Or_Error
31451 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31452 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31453 Arg2 : constant Node_Id := Next (Arg1);
31456 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31458 if Compile_Time_Known_Value (Arg1x) then
31459 if Is_True (Expr_Value (Arg1x)) then
31461 -- We have already verified that the second argument is a static
31462 -- string expression. Its string value must be retrieved
31463 -- explicitly if it is a declared constant, otherwise it has
31464 -- been constant-folded previously.
31467 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31468 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31469 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31470 Str : constant String_Id :=
31471 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31472 Str_Len : constant Nat := String_Length (Str);
31474 Force : constant Boolean :=
31475 Prag_Id = Pragma_Compile_Time_Warning
31476 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31477 and then (Ekind (Cent) /= E_Package
31478 or else not In_Private_Part (Cent));
31479 -- Set True if this is the warning case, and we are in the
31480 -- visible part of a package spec, or in a subprogram spec,
31481 -- in which case we want to force the client to see the
31482 -- warning, even though it is not in the main unit.
31490 -- Loop through segments of message separated by line feeds.
31491 -- We output these segments as separate messages with
31492 -- continuation marks for all but the first.
31497 Error_Msg_Strlen := 0;
31499 -- Loop to copy characters from argument to error message
31503 exit when Ptr > Str_Len;
31504 CC := Get_String_Char (Str, Ptr);
31507 -- Ignore wide chars ??? else store character
31509 if In_Character_Range (CC) then
31510 C := Get_Character (CC);
31511 exit when C = ASCII.LF;
31512 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31513 Error_Msg_String (Error_Msg_Strlen) := C;
31517 -- Here with one line ready to go
31519 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31521 -- If this is a warning in a spec, then we want clients
31522 -- to see the warning, so mark the message with the
31523 -- special sequence !! to force the warning. In the case
31524 -- of a package spec, we do not force this if we are in
31525 -- the private part of the spec.
31528 if Cont = False then
31529 Error_Msg ("<<~!!", Eloc);
31532 Error_Msg ("\<<~!!", Eloc);
31535 -- Error, rather than warning, or in a body, so we do not
31536 -- need to force visibility for client (error will be
31537 -- output in any case, and this is the situation in which
31538 -- we do not want a client to get a warning, since the
31539 -- warning is in the body or the spec private part).
31542 if Cont = False then
31543 Error_Msg ("<<~", Eloc);
31546 Error_Msg ("\<<~", Eloc);
31550 exit when Ptr > Str_Len;
31555 -- Arg1x is not known at compile time, so issue a warning. This can
31556 -- happen only if the pragma's processing was deferred until after the
31557 -- back end is run (see Process_Compile_Time_Warning_Or_Error).
31558 -- Note that the warning control switch applies to both pragmas.
31560 elsif Warn_On_Unknown_Compile_Time_Warning then
31561 Error_Msg_N ("?condition is not known at compile time", Arg1x);
31563 end Validate_Compile_Time_Warning_Or_Error;
31565 ------------------------------------
31566 -- Record_Possible_Body_Reference --
31567 ------------------------------------
31569 procedure Record_Possible_Body_Reference
31570 (State_Id : Entity_Id;
31574 Spec_Id : Entity_Id;
31577 -- Ensure that we are dealing with a reference to a state
31579 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31581 -- Climb the tree starting from the reference looking for a package body
31582 -- whose spec declares the referenced state. This criteria automatically
31583 -- excludes references in package specs which are legal. Note that it is
31584 -- not wise to emit an error now as the package body may lack pragma
31585 -- Refined_State or the referenced state may not be mentioned in the
31586 -- refinement. This approach avoids the generation of misleading errors.
31589 while Present (Context) loop
31590 if Nkind (Context) = N_Package_Body then
31591 Spec_Id := Corresponding_Spec (Context);
31593 if Present (Abstract_States (Spec_Id))
31594 and then Contains (Abstract_States (Spec_Id), State_Id)
31596 if No (Body_References (State_Id)) then
31597 Set_Body_References (State_Id, New_Elmt_List);
31600 Append_Elmt (Ref, To => Body_References (State_Id));
31605 Context := Parent (Context);
31607 end Record_Possible_Body_Reference;
31609 ------------------------------------------
31610 -- Relocate_Pragmas_To_Anonymous_Object --
31611 ------------------------------------------
31613 procedure Relocate_Pragmas_To_Anonymous_Object
31614 (Typ_Decl : Node_Id;
31615 Obj_Decl : Node_Id)
31619 Next_Decl : Node_Id;
31622 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31623 Def := Protected_Definition (Typ_Decl);
31625 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31626 Def := Task_Definition (Typ_Decl);
31629 -- The concurrent definition has a visible declaration list. Inspect it
31630 -- and relocate all canidate pragmas.
31632 if Present (Def) and then Present (Visible_Declarations (Def)) then
31633 Decl := First (Visible_Declarations (Def));
31634 while Present (Decl) loop
31636 -- Preserve the following declaration for iteration purposes due
31637 -- to possible relocation of a pragma.
31639 Next_Decl := Next (Decl);
31641 if Nkind (Decl) = N_Pragma
31642 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31645 Insert_After (Obj_Decl, Decl);
31647 -- Skip internally generated code
31649 elsif not Comes_From_Source (Decl) then
31652 -- No candidate pragmas are available for relocation
31661 end Relocate_Pragmas_To_Anonymous_Object;
31663 ------------------------------
31664 -- Relocate_Pragmas_To_Body --
31665 ------------------------------
31667 procedure Relocate_Pragmas_To_Body
31668 (Subp_Body : Node_Id;
31669 Target_Body : Node_Id := Empty)
31671 procedure Relocate_Pragma (Prag : Node_Id);
31672 -- Remove a single pragma from its current list and add it to the
31673 -- declarations of the proper body (either Subp_Body or Target_Body).
31675 ---------------------
31676 -- Relocate_Pragma --
31677 ---------------------
31679 procedure Relocate_Pragma (Prag : Node_Id) is
31684 -- When subprogram stubs or expression functions are involves, the
31685 -- destination declaration list belongs to the proper body.
31687 if Present (Target_Body) then
31688 Target := Target_Body;
31690 Target := Subp_Body;
31693 Decls := Declarations (Target);
31697 Set_Declarations (Target, Decls);
31700 -- Unhook the pragma from its current list
31703 Prepend (Prag, Decls);
31704 end Relocate_Pragma;
31708 Body_Id : constant Entity_Id :=
31709 Defining_Unit_Name (Specification (Subp_Body));
31710 Next_Stmt : Node_Id;
31713 -- Start of processing for Relocate_Pragmas_To_Body
31716 -- Do not process a body that comes from a separate unit as no construct
31717 -- can possibly follow it.
31719 if not Is_List_Member (Subp_Body) then
31722 -- Do not relocate pragmas that follow a stub if the stub does not have
31725 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31726 and then No (Target_Body)
31730 -- Do not process internally generated routine _Postconditions
31732 elsif Ekind (Body_Id) = E_Procedure
31733 and then Chars (Body_Id) = Name_uPostconditions
31738 -- Look at what is following the body. We are interested in certain kind
31739 -- of pragmas (either from source or byproducts of expansion) that can
31740 -- apply to a body [stub].
31742 Stmt := Next (Subp_Body);
31743 while Present (Stmt) loop
31745 -- Preserve the following statement for iteration purposes due to a
31746 -- possible relocation of a pragma.
31748 Next_Stmt := Next (Stmt);
31750 -- Move a candidate pragma following the body to the declarations of
31753 if Nkind (Stmt) = N_Pragma
31754 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31757 -- If a source pragma Warnings follows the body, it applies to
31758 -- following statements and does not belong in the body.
31760 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31761 and then Comes_From_Source (Stmt)
31765 Relocate_Pragma (Stmt);
31768 -- Skip internally generated code
31770 elsif not Comes_From_Source (Stmt) then
31773 -- No candidate pragmas are available for relocation
31781 end Relocate_Pragmas_To_Body;
31783 -------------------
31784 -- Resolve_State --
31785 -------------------
31787 procedure Resolve_State (N : Node_Id) is
31792 if Is_Entity_Name (N) and then Present (Entity (N)) then
31793 Func := Entity (N);
31795 -- Handle overloading of state names by functions. Traverse the
31796 -- homonym chain looking for an abstract state.
31798 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31799 pragma Assert (Is_Overloaded (N));
31801 State := Homonym (Func);
31802 while Present (State) loop
31803 if Ekind (State) = E_Abstract_State then
31805 -- Resolve the overloading by setting the proper entity of
31806 -- the reference to that of the state.
31808 Set_Etype (N, Standard_Void_Type);
31809 Set_Entity (N, State);
31810 Set_Is_Overloaded (N, False);
31812 Generate_Reference (State, N);
31816 State := Homonym (State);
31819 -- A function can never act as a state. If the homonym chain does
31820 -- not contain a corresponding state, then something went wrong in
31821 -- the overloading mechanism.
31823 raise Program_Error;
31828 ----------------------------
31829 -- Rewrite_Assertion_Kind --
31830 ----------------------------
31832 procedure Rewrite_Assertion_Kind
31834 From_Policy : Boolean := False)
31840 if Nkind (N) = N_Attribute_Reference
31841 and then Attribute_Name (N) = Name_Class
31842 and then Nkind (Prefix (N)) = N_Identifier
31844 case Chars (Prefix (N)) is
31851 when Name_Type_Invariant =>
31852 Nam := Name_uType_Invariant;
31854 when Name_Invariant =>
31855 Nam := Name_uInvariant;
31861 -- Recommend standard use of aspect names Pre/Post
31863 elsif Nkind (N) = N_Identifier
31864 and then From_Policy
31865 and then Serious_Errors_Detected = 0
31866 and then not ASIS_Mode
31868 if Chars (N) = Name_Precondition
31869 or else Chars (N) = Name_Postcondition
31871 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31873 ("\use Assertion_Policy and aspect names Pre/Post for "
31874 & "Ada2012 conformance?", N);
31880 if Nam /= No_Name then
31881 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31883 end Rewrite_Assertion_Kind;
31891 Dummy := Dummy + 1;
31894 --------------------------------
31895 -- Set_Encoded_Interface_Name --
31896 --------------------------------
31898 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31899 Str : constant String_Id := Strval (S);
31900 Len : constant Nat := String_Length (Str);
31905 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31908 -- Stores encoded value of character code CC. The encoding we use an
31909 -- underscore followed by four lower case hex digits.
31915 procedure Encode is
31917 Store_String_Char (Get_Char_Code ('_'));
31919 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31921 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31923 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31925 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31928 -- Start of processing for Set_Encoded_Interface_Name
31931 -- If first character is asterisk, this is a link name, and we leave it
31932 -- completely unmodified. We also ignore null strings (the latter case
31933 -- happens only in error cases).
31936 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31938 Set_Interface_Name (E, S);
31943 CC := Get_String_Char (Str, J);
31945 exit when not In_Character_Range (CC);
31947 C := Get_Character (CC);
31949 exit when C /= '_' and then C /= '$'
31950 and then C not in '0' .. '9'
31951 and then C not in 'a' .. 'z'
31952 and then C not in 'A' .. 'Z';
31955 Set_Interface_Name (E, S);
31963 -- Here we need to encode. The encoding we use as follows:
31964 -- three underscores + four hex digits (lower case)
31968 for J in 1 .. String_Length (Str) loop
31969 CC := Get_String_Char (Str, J);
31971 if not In_Character_Range (CC) then
31974 C := Get_Character (CC);
31976 if C = '_' or else C = '$'
31977 or else C in '0' .. '9'
31978 or else C in 'a' .. 'z'
31979 or else C in 'A' .. 'Z'
31981 Store_String_Char (CC);
31988 Set_Interface_Name (E,
31989 Make_String_Literal (Sloc (S),
31990 Strval => End_String));
31992 end Set_Encoded_Interface_Name;
31994 ------------------------
31995 -- Set_Elab_Unit_Name --
31996 ------------------------
31998 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32003 if Nkind (N) = N_Identifier
32004 and then Nkind (With_Item) = N_Identifier
32006 Set_Entity (N, Entity (With_Item));
32008 elsif Nkind (N) = N_Selected_Component then
32009 Change_Selected_Component_To_Expanded_Name (N);
32010 Set_Entity (N, Entity (With_Item));
32011 Set_Entity (Selector_Name (N), Entity (N));
32013 Pref := Prefix (N);
32014 Scop := Scope (Entity (N));
32015 while Nkind (Pref) = N_Selected_Component loop
32016 Change_Selected_Component_To_Expanded_Name (Pref);
32017 Set_Entity (Selector_Name (Pref), Scop);
32018 Set_Entity (Pref, Scop);
32019 Pref := Prefix (Pref);
32020 Scop := Scope (Scop);
32023 Set_Entity (Pref, Scop);
32026 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32027 end Set_Elab_Unit_Name;
32029 -------------------
32030 -- Test_Case_Arg --
32031 -------------------
32033 function Test_Case_Arg
32036 From_Aspect : Boolean := False) return Node_Id
32038 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32043 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
32048 -- The caller requests the aspect argument
32050 if From_Aspect then
32051 if Present (Aspect)
32052 and then Nkind (Expression (Aspect)) = N_Aggregate
32054 Args := Expression (Aspect);
32056 -- "Name" and "Mode" may appear without an identifier as a
32057 -- positional association.
32059 if Present (Expressions (Args)) then
32060 Arg := First (Expressions (Args));
32062 if Present (Arg) and then Arg_Nam = Name_Name then
32070 if Present (Arg) and then Arg_Nam = Name_Mode then
32075 -- Some or all arguments may appear as component associatons
32077 if Present (Component_Associations (Args)) then
32078 Arg := First (Component_Associations (Args));
32079 while Present (Arg) loop
32080 if Chars (First (Choices (Arg))) = Arg_Nam then
32089 -- Otherwise retrieve the argument directly from the pragma
32092 Arg := First (Pragma_Argument_Associations (Prag));
32094 if Present (Arg) and then Arg_Nam = Name_Name then
32098 -- Skip argument "Name"
32102 if Present (Arg) and then Arg_Nam = Name_Mode then
32106 -- Skip argument "Mode"
32110 -- Arguments "Requires" and "Ensures" are optional and may not be
32113 while Present (Arg) loop
32114 if Chars (Arg) = Arg_Nam then
32125 -----------------------------------------
32126 -- Defer_Compile_Time_Warning_Error_To_BE --
32127 -----------------------------------------
32129 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32130 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32132 Compile_Time_Warnings_Errors.Append
32133 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32134 Scope => Current_Scope,
32136 end Defer_Compile_Time_Warning_Error_To_BE;
32138 ------------------------------------------
32139 -- Validate_Compile_Time_Warning_Errors --
32140 ------------------------------------------
32142 procedure Validate_Compile_Time_Warning_Errors is
32143 procedure Set_Scope (S : Entity_Id);
32144 -- Install all enclosing scopes of S along with S itself
32146 procedure Unset_Scope (S : Entity_Id);
32147 -- Uninstall all enclosing scopes of S along with S itself
32153 procedure Set_Scope (S : Entity_Id) is
32155 if S /= Standard_Standard then
32156 Set_Scope (Scope (S));
32166 procedure Unset_Scope (S : Entity_Id) is
32168 if S /= Standard_Standard then
32169 Unset_Scope (Scope (S));
32175 -- Start of processing for Validate_Compile_Time_Warning_Errors
32178 Expander_Mode_Save_And_Set (False);
32179 In_Compile_Time_Warning_Or_Error := True;
32181 for N in Compile_Time_Warnings_Errors.First ..
32182 Compile_Time_Warnings_Errors.Last
32185 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32188 Set_Scope (T.Scope);
32189 Reset_Analyzed_Flags (T.Prag);
32190 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32191 Unset_Scope (T.Scope);
32195 In_Compile_Time_Warning_Or_Error := False;
32196 Expander_Mode_Restore;
32197 end Validate_Compile_Time_Warning_Errors;