1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with GNAT_CUDA; use GNAT_CUDA;
48 with Gnatvsn; use Gnatvsn;
50 with Lib.Writ; use Lib.Writ;
51 with Lib.Xref; use Lib.Xref;
52 with Namet.Sp; use Namet.Sp;
53 with Nlists; use Nlists;
54 with Nmake; use Nmake;
55 with Output; use Output;
56 with Par_SCO; use Par_SCO;
57 with Restrict; use Restrict;
58 with Rident; use Rident;
59 with Rtsfind; use Rtsfind;
61 with Sem_Aux; use Sem_Aux;
62 with Sem_Ch3; use Sem_Ch3;
63 with Sem_Ch6; use Sem_Ch6;
64 with Sem_Ch8; use Sem_Ch8;
65 with Sem_Ch12; use Sem_Ch12;
66 with Sem_Ch13; use Sem_Ch13;
67 with Sem_Disp; use Sem_Disp;
68 with Sem_Dist; use Sem_Dist;
69 with Sem_Elab; use Sem_Elab;
70 with Sem_Elim; use Sem_Elim;
71 with Sem_Eval; use Sem_Eval;
72 with Sem_Intr; use Sem_Intr;
73 with Sem_Mech; use Sem_Mech;
74 with Sem_Res; use Sem_Res;
75 with Sem_Type; use Sem_Type;
76 with Sem_Util; use Sem_Util;
77 with Sem_Warn; use Sem_Warn;
78 with Stand; use Stand;
79 with Sinfo; use Sinfo;
80 with Sinfo.CN; use Sinfo.CN;
81 with Sinput; use Sinput;
82 with Stringt; use Stringt;
83 with Stylesw; use Stylesw;
85 with Targparm; use Targparm;
86 with Tbuild; use Tbuild;
88 with Uintp; use Uintp;
89 with Uname; use Uname;
90 with Urealp; use Urealp;
91 with Validsw; use Validsw;
92 with Warnsw; use Warnsw;
94 with System.Case_Util;
96 package body Sem_Prag is
98 ----------------------------------------------
99 -- Common Handling of Import-Export Pragmas --
100 ----------------------------------------------
102 -- In the following section, a number of Import_xxx and Export_xxx pragmas
103 -- are defined by GNAT. These are compatible with the DEC pragmas of the
104 -- same name, and all have the following common form and processing:
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
112 -- [Internal =>] LOCAL_NAME
113 -- [, [External =>] EXTERNAL_SYMBOL]
114 -- [, other optional parameters ]);
116 -- EXTERNAL_SYMBOL ::=
118 -- | static_string_EXPRESSION
120 -- The internal LOCAL_NAME designates the entity that is imported or
121 -- exported, and must refer to an entity in the current declarative
122 -- part (as required by the rules for LOCAL_NAME).
124 -- The external linker name is designated by the External parameter if
125 -- given, or the Internal parameter if not (if there is no External
126 -- parameter, the External parameter is a copy of the Internal name).
128 -- If the External parameter is given as a string, then this string is
129 -- treated as an external name (exactly as though it had been given as an
130 -- External_Name parameter for a normal Import pragma).
132 -- If the External parameter is given as an identifier (or there is no
133 -- External parameter, so that the Internal identifier is used), then
134 -- the external name is the characters of the identifier, translated
135 -- to all lower case letters.
137 -- Note: the external name specified or implied by any of these special
138 -- Import_xxx or Export_xxx pragmas override an external or link name
139 -- specified in a previous Import or Export pragma.
141 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
142 -- named notation, following the standard rules for subprogram calls, i.e.
143 -- parameters can be given in any order if named notation is used, and
144 -- positional and named notation can be mixed, subject to the rule that all
145 -- positional parameters must appear first.
147 -- Note: All these pragmas are implemented exactly following the DEC design
148 -- and implementation and are intended to be fully compatible with the use
149 -- of these pragmas in the DEC Ada compiler.
151 --------------------------------------------
152 -- Checking for Duplicated External Names --
153 --------------------------------------------
155 -- It is suspicious if two separate Export pragmas use the same external
156 -- name. The following table is used to diagnose this situation so that
157 -- an appropriate warning can be issued.
159 -- The Node_Id stored is for the N_String_Literal node created to hold
160 -- the value of the external name. The Sloc of this node is used to
161 -- cross-reference the location of the duplication.
163 package Externals is new Table.Table (
164 Table_Component_Type => Node_Id,
165 Table_Index_Type => Int,
166 Table_Low_Bound => 0,
167 Table_Initial => 100,
168 Table_Increment => 100,
169 Table_Name => "Name_Externals");
171 -------------------------------------
172 -- Local Subprograms and Variables --
173 -------------------------------------
175 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
176 -- This routine is used for possible casing adjustment of an explicit
177 -- external name supplied as a string literal (the node N), according to
178 -- the casing requirement of Opt.External_Name_Casing. If this is set to
179 -- As_Is, then the string literal is returned unchanged, but if it is set
180 -- to Uppercase or Lowercase, then a new string literal with appropriate
181 -- casing is constructed.
183 procedure Analyze_Part_Of
187 Encap_Id : out Entity_Id;
188 Legal : out Boolean);
189 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
190 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
191 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
192 -- package instantiation. Encap denotes the encapsulating state or single
193 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
194 -- the indicator is legal.
196 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
197 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
198 -- Query whether a particular item appears in a mixed list of nodes and
199 -- entities. It is assumed that all nodes in the list have entities.
201 procedure Check_Postcondition_Use_In_Inlined_Subprogram
203 Spec_Id : Entity_Id);
204 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
205 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
206 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
207 -- and assertions are enabled.
209 procedure Check_State_And_Constituent_Use
213 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
214 -- Global and Initializes. Determine whether a state from list States and a
215 -- corresponding constituent from list Constits (if any) appear in the same
216 -- context denoted by Context. If this is the case, emit an error.
218 procedure Contract_Freeze_Error
219 (Contract_Id : Entity_Id;
220 Freeze_Id : Entity_Id);
221 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
222 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
223 -- of a body which caused contract freezing and Contract_Id denotes the
224 -- entity of the affected contstruct.
226 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
227 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
228 -- Prag that duplicates previous pragma Prev.
230 function Find_Encapsulating_State
232 Constit_Id : Entity_Id) return Entity_Id;
233 -- Given the entity of a constituent Constit_Id, find the corresponding
234 -- encapsulating state which appears in States. The routine returns Empty
235 -- if no such state is found.
237 function Find_Related_Context
239 Do_Checks : Boolean := False) return Node_Id;
240 -- Subsidiary to the analysis of pragmas
243 -- Constant_After_Elaboration
247 -- Find the first source declaration or statement found while traversing
248 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
249 -- set, the routine reports duplicate pragmas. The routine returns Empty
250 -- when reaching the start of the node chain.
252 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
253 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
254 -- original one, following the renaming chain) is returned. Otherwise the
255 -- entity is returned unchanged. Should be in Einfo???
257 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
258 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
259 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
260 -- value of type SPARK_Mode_Type.
262 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
263 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
264 -- Determine whether dependency clause Clause is surrounded by extra
265 -- parentheses. If this is the case, issue an error message.
267 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
268 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
269 -- pragma Depends. Determine whether the type of dependency item Item is
270 -- tagged, unconstrained array, unconstrained record or a record with at
271 -- least one unconstrained component.
273 procedure Record_Possible_Body_Reference
274 (State_Id : Entity_Id;
276 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
277 -- Global. Given an abstract state denoted by State_Id and a reference Ref
278 -- to it, determine whether the reference appears in a package body that
279 -- will eventually refine the state. If this is the case, record the
280 -- reference for future checks (see Analyze_Refined_State_In_Decls).
282 procedure Resolve_State (N : Node_Id);
283 -- Handle the overloading of state names by functions. When N denotes a
284 -- function, this routine finds the corresponding state and sets the entity
285 -- of N to that of the state.
287 procedure Rewrite_Assertion_Kind
289 From_Policy : Boolean := False);
290 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
291 -- then it is rewritten as an identifier with the corresponding special
292 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
293 -- and Check_Policy. If the names are Precondition or Postcondition, this
294 -- combination is deprecated in favor of Assertion_Policy and Ada2012
295 -- Aspect names. The parameter From_Policy indicates that the pragma
296 -- is the old non-standard Check_Policy and not a rewritten pragma.
298 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
299 -- Place semantic information on the argument of an Elaborate/Elaborate_All
300 -- pragma. Entity name for unit and its parents is taken from item in
301 -- previous with_clause that mentions the unit.
303 procedure Validate_Compile_Time_Warning_Or_Error
306 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
307 -- pragma N. Called when the pragma is processed as part of its regular
308 -- analysis but also called after calling the back end to validate these
309 -- pragmas for size and alignment appropriateness.
311 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
312 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
313 -- expression is not known at compile time during the front end. This
314 -- procedure makes an entry in a table. The actual checking is performed by
315 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
318 Dummy : Integer := 0;
319 pragma Volatile (Dummy);
320 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
323 pragma No_Inline (ip);
324 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
325 -- is just to help debugging the front end. If a pragma Inspection_Point
326 -- is added to a source program, then breaking on ip will get you to that
327 -- point in the program.
330 pragma No_Inline (rv);
331 -- This is a dummy function called by the processing for pragma Reviewable.
332 -- It is there for assisting front end debugging. By placing a Reviewable
333 -- pragma in the source program, a breakpoint on rv catches this place in
334 -- the source, allowing convenient stepping to the point of interest.
336 ------------------------------------------------------
337 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
338 ------------------------------------------------------
340 -- The following table collects pragmas Compile_Time_Error and Compile_
341 -- Time_Warning for validation. Entries are made by calls to subprogram
342 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
343 -- Validate_Compile_Time_Warning_Errors does the actual error checking
344 -- and posting of warning and error messages. The reason for this delayed
345 -- processing is to take advantage of back-annotations of attributes size
346 -- and alignment values performed by the back end.
348 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
349 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
350 -- will already have modified all Sloc values if the -gnatD option is set.
352 type CTWE_Entry is record
354 -- Source location used in warnings and error messages
357 -- Pragma Compile_Time_Error or Compile_Time_Warning
360 -- The scope which encloses the pragma
363 package Compile_Time_Warnings_Errors is new Table.Table (
364 Table_Component_Type => CTWE_Entry,
365 Table_Index_Type => Int,
366 Table_Low_Bound => 1,
368 Table_Increment => 200,
369 Table_Name => "Compile_Time_Warnings_Errors");
371 -------------------------------
372 -- Adjust_External_Name_Case --
373 -------------------------------
375 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
379 -- Adjust case of literal if required
381 if Opt.External_Name_Exp_Casing = As_Is then
385 -- Copy existing string
391 for J in 1 .. String_Length (Strval (N)) loop
392 CC := Get_String_Char (Strval (N), J);
394 if Opt.External_Name_Exp_Casing = Uppercase
395 and then CC >= Get_Char_Code ('a')
396 and then CC <= Get_Char_Code ('z')
398 Store_String_Char (CC - 32);
400 elsif Opt.External_Name_Exp_Casing = Lowercase
401 and then CC >= Get_Char_Code ('A')
402 and then CC <= Get_Char_Code ('Z')
404 Store_String_Char (CC + 32);
407 Store_String_Char (CC);
412 Make_String_Literal (Sloc (N),
413 Strval => End_String);
415 end Adjust_External_Name_Case;
417 -----------------------------------------
418 -- Analyze_Contract_Cases_In_Decl_Part --
419 -----------------------------------------
421 -- WARNING: This routine manages Ghost regions. Return statements must be
422 -- replaced by gotos which jump to the end of the routine and restore the
425 procedure Analyze_Contract_Cases_In_Decl_Part
427 Freeze_Id : Entity_Id := Empty)
429 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
430 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
432 Others_Seen : Boolean := False;
433 -- This flag is set when an "others" choice is encountered. It is used
434 -- to detect multiple illegal occurrences of "others".
436 procedure Analyze_Contract_Case (CCase : Node_Id);
437 -- Verify the legality of a single contract case
439 ---------------------------
440 -- Analyze_Contract_Case --
441 ---------------------------
443 procedure Analyze_Contract_Case (CCase : Node_Id) is
444 Case_Guard : Node_Id;
447 Extra_Guard : Node_Id;
450 if Nkind (CCase) = N_Component_Association then
451 Case_Guard := First (Choices (CCase));
452 Conseq := Expression (CCase);
454 -- Each contract case must have exactly one case guard
456 Extra_Guard := Next (Case_Guard);
458 if Present (Extra_Guard) then
460 ("contract case must have exactly one case guard",
464 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
466 if Nkind (Case_Guard) = N_Others_Choice then
469 ("only one others choice allowed in contract cases",
475 elsif Others_Seen then
477 ("others must be the last choice in contract cases", N);
480 -- Preanalyze the case guard and consequence
482 if Nkind (Case_Guard) /= N_Others_Choice then
483 Errors := Serious_Errors_Detected;
484 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
486 -- Emit a clarification message when the case guard contains
487 -- at least one undefined reference, possibly due to contract
490 if Errors /= Serious_Errors_Detected
491 and then Present (Freeze_Id)
492 and then Has_Undefined_Reference (Case_Guard)
494 Contract_Freeze_Error (Spec_Id, Freeze_Id);
498 Errors := Serious_Errors_Detected;
499 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
501 -- Emit a clarification message when the consequence contains
502 -- at least one undefined reference, possibly due to contract
505 if Errors /= Serious_Errors_Detected
506 and then Present (Freeze_Id)
507 and then Has_Undefined_Reference (Conseq)
509 Contract_Freeze_Error (Spec_Id, Freeze_Id);
512 -- The contract case is malformed
515 Error_Msg_N ("wrong syntax in contract case", CCase);
517 end Analyze_Contract_Case;
521 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
523 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
524 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
525 -- Save the Ghost-related attributes to restore on exit
528 Restore_Scope : Boolean := False;
530 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
533 -- Do not analyze the pragma multiple times
535 if Is_Analyzed_Pragma (N) then
539 -- Set the Ghost mode in effect from the pragma. Due to the delayed
540 -- analysis of the pragma, the Ghost mode at point of declaration and
541 -- point of analysis may not necessarily be the same. Use the mode in
542 -- effect at the point of declaration.
546 -- Single and multiple contract cases must appear in aggregate form. If
547 -- this is not the case, then either the parser or the analysis of the
548 -- pragma failed to produce an aggregate, e.g. when the contract is
549 -- "null" or a "(null record)".
552 (if Nkind (CCases) = N_Aggregate
553 then Null_Record_Present (CCases)
554 xor (Present (Component_Associations (CCases))
556 Present (Expressions (CCases)))
557 else Nkind (CCases) = N_Null);
559 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
561 if Nkind (CCases) = N_Aggregate
562 and then Present (Component_Associations (CCases))
563 and then No (Expressions (CCases))
566 -- Check that the expression is a proper aggregate (no parentheses)
568 if Paren_Count (CCases) /= 0 then
570 ("redundant parentheses", First_Sloc (CCases));
573 -- Ensure that the formal parameters are visible when analyzing all
574 -- clauses. This falls out of the general rule of aspects pertaining
575 -- to subprogram declarations.
577 if not In_Open_Scopes (Spec_Id) then
578 Restore_Scope := True;
579 Push_Scope (Spec_Id);
581 if Is_Generic_Subprogram (Spec_Id) then
582 Install_Generic_Formals (Spec_Id);
584 Install_Formals (Spec_Id);
588 CCase := First (Component_Associations (CCases));
589 while Present (CCase) loop
590 Analyze_Contract_Case (CCase);
594 if Restore_Scope then
598 -- Currently it is not possible to inline pre/postconditions on a
599 -- subprogram subject to pragma Inline_Always.
601 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
603 -- Otherwise the pragma is illegal
606 Error_Msg_N ("wrong syntax for contract cases", N);
609 Set_Is_Analyzed_Pragma (N);
611 Restore_Ghost_Region (Saved_GM, Saved_IGR);
612 end Analyze_Contract_Cases_In_Decl_Part;
614 ----------------------------------
615 -- Analyze_Depends_In_Decl_Part --
616 ----------------------------------
618 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
619 Loc : constant Source_Ptr := Sloc (N);
620 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
621 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
623 All_Inputs_Seen : Elist_Id := No_Elist;
624 -- A list containing the entities of all the inputs processed so far.
625 -- The list is populated with unique entities because the same input
626 -- may appear in multiple input lists.
628 All_Outputs_Seen : Elist_Id := No_Elist;
629 -- A list containing the entities of all the outputs processed so far.
630 -- The list is populated with unique entities because output items are
631 -- unique in a dependence relation.
633 Constits_Seen : Elist_Id := No_Elist;
634 -- A list containing the entities of all constituents processed so far.
635 -- It aids in detecting illegal usage of a state and a corresponding
636 -- constituent in pragma [Refinde_]Depends.
638 Global_Seen : Boolean := False;
639 -- A flag set when pragma Global has been processed
641 Null_Output_Seen : Boolean := False;
642 -- A flag used to track the legality of a null output
644 Result_Seen : Boolean := False;
645 -- A flag set when Spec_Id'Result is processed
647 States_Seen : Elist_Id := No_Elist;
648 -- A list containing the entities of all states processed so far. It
649 -- helps in detecting illegal usage of a state and a corresponding
650 -- constituent in pragma [Refined_]Depends.
652 Subp_Inputs : Elist_Id := No_Elist;
653 Subp_Outputs : Elist_Id := No_Elist;
654 -- Two lists containing the full set of inputs and output of the related
655 -- subprograms. Note that these lists contain both nodes and entities.
657 Task_Input_Seen : Boolean := False;
658 Task_Output_Seen : Boolean := False;
659 -- Flags used to track the implicit dependence of a task unit on itself
661 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
662 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
663 -- to the name buffer. The individual kinds are as follows:
664 -- E_Abstract_State - "state"
665 -- E_Constant - "constant"
666 -- E_Generic_In_Out_Parameter - "generic parameter"
667 -- E_Generic_In_Parameter - "generic parameter"
668 -- E_In_Parameter - "parameter"
669 -- E_In_Out_Parameter - "parameter"
670 -- E_Loop_Parameter - "loop parameter"
671 -- E_Out_Parameter - "parameter"
672 -- E_Protected_Type - "current instance of protected type"
673 -- E_Task_Type - "current instance of task type"
674 -- E_Variable - "global"
676 procedure Analyze_Dependency_Clause
679 -- Verify the legality of a single dependency clause. Flag Is_Last
680 -- denotes whether Clause is the last clause in the relation.
682 procedure Check_Function_Return;
683 -- Verify that Funtion'Result appears as one of the outputs
684 -- (SPARK RM 6.1.5(10)).
691 -- Ensure that an item fulfills its designated input and/or output role
692 -- as specified by pragma Global (if any) or the enclosing context. If
693 -- this is not the case, emit an error. Item and Item_Id denote the
694 -- attributes of an item. Flag Is_Input should be set when item comes
695 -- from an input list. Flag Self_Ref should be set when the item is an
696 -- output and the dependency clause has operator "+".
698 procedure Check_Usage
699 (Subp_Items : Elist_Id;
700 Used_Items : Elist_Id;
702 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
703 -- error if this is not the case.
705 procedure Normalize_Clause (Clause : Node_Id);
706 -- Remove a self-dependency "+" from the input list of a clause
708 -----------------------------
709 -- Add_Item_To_Name_Buffer --
710 -----------------------------
712 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
714 if Ekind (Item_Id) = E_Abstract_State then
715 Add_Str_To_Name_Buffer ("state");
717 elsif Ekind (Item_Id) = E_Constant then
718 Add_Str_To_Name_Buffer ("constant");
720 elsif Ekind (Item_Id) in
721 E_Generic_In_Out_Parameter | E_Generic_In_Parameter
723 Add_Str_To_Name_Buffer ("generic parameter");
725 elsif Is_Formal (Item_Id) then
726 Add_Str_To_Name_Buffer ("parameter");
728 elsif Ekind (Item_Id) = E_Loop_Parameter then
729 Add_Str_To_Name_Buffer ("loop parameter");
731 elsif Ekind (Item_Id) = E_Protected_Type
732 or else Is_Single_Protected_Object (Item_Id)
734 Add_Str_To_Name_Buffer ("current instance of protected type");
736 elsif Ekind (Item_Id) = E_Task_Type
737 or else Is_Single_Task_Object (Item_Id)
739 Add_Str_To_Name_Buffer ("current instance of task type");
741 elsif Ekind (Item_Id) = E_Variable then
742 Add_Str_To_Name_Buffer ("global");
744 -- The routine should not be called with non-SPARK items
749 end Add_Item_To_Name_Buffer;
751 -------------------------------
752 -- Analyze_Dependency_Clause --
753 -------------------------------
755 procedure Analyze_Dependency_Clause
759 procedure Analyze_Input_List (Inputs : Node_Id);
760 -- Verify the legality of a single input list
762 procedure Analyze_Input_Output
767 Seen : in out Elist_Id;
768 Null_Seen : in out Boolean;
769 Non_Null_Seen : in out Boolean);
770 -- Verify the legality of a single input or output item. Flag
771 -- Is_Input should be set whenever Item is an input, False when it
772 -- denotes an output. Flag Self_Ref should be set when the item is an
773 -- output and the dependency clause has a "+". Flag Top_Level should
774 -- be set whenever Item appears immediately within an input or output
775 -- list. Seen is a collection of all abstract states, objects and
776 -- formals processed so far. Flag Null_Seen denotes whether a null
777 -- input or output has been encountered. Flag Non_Null_Seen denotes
778 -- whether a non-null input or output has been encountered.
780 ------------------------
781 -- Analyze_Input_List --
782 ------------------------
784 procedure Analyze_Input_List (Inputs : Node_Id) is
785 Inputs_Seen : Elist_Id := No_Elist;
786 -- A list containing the entities of all inputs that appear in the
787 -- current input list.
789 Non_Null_Input_Seen : Boolean := False;
790 Null_Input_Seen : Boolean := False;
791 -- Flags used to check the legality of an input list
796 -- Multiple inputs appear as an aggregate
798 if Nkind (Inputs) = N_Aggregate then
799 if Present (Component_Associations (Inputs)) then
801 ("nested dependency relations not allowed", Inputs);
803 elsif Present (Expressions (Inputs)) then
804 Input := First (Expressions (Inputs));
805 while Present (Input) loop
812 Null_Seen => Null_Input_Seen,
813 Non_Null_Seen => Non_Null_Input_Seen);
818 -- Syntax error, always report
821 Error_Msg_N ("malformed input dependency list", Inputs);
824 -- Process a solitary input
833 Null_Seen => Null_Input_Seen,
834 Non_Null_Seen => Non_Null_Input_Seen);
837 -- Detect an illegal dependency clause of the form
841 if Null_Output_Seen and then Null_Input_Seen then
843 ("null dependency clause cannot have a null input list",
846 end Analyze_Input_List;
848 --------------------------
849 -- Analyze_Input_Output --
850 --------------------------
852 procedure Analyze_Input_Output
857 Seen : in out Elist_Id;
858 Null_Seen : in out Boolean;
859 Non_Null_Seen : in out Boolean)
861 procedure Current_Task_Instance_Seen;
862 -- Set the appropriate global flag when the current instance of a
863 -- task unit is encountered.
865 --------------------------------
866 -- Current_Task_Instance_Seen --
867 --------------------------------
869 procedure Current_Task_Instance_Seen is
872 Task_Input_Seen := True;
874 Task_Output_Seen := True;
876 end Current_Task_Instance_Seen;
880 Is_Output : constant Boolean := not Is_Input;
884 -- Start of processing for Analyze_Input_Output
887 -- Multiple input or output items appear as an aggregate
889 if Nkind (Item) = N_Aggregate then
890 if not Top_Level then
891 SPARK_Msg_N ("nested grouping of items not allowed", Item);
893 elsif Present (Component_Associations (Item)) then
895 ("nested dependency relations not allowed", Item);
897 -- Recursively analyze the grouped items
899 elsif Present (Expressions (Item)) then
900 Grouped := First (Expressions (Item));
901 while Present (Grouped) loop
904 Is_Input => Is_Input,
905 Self_Ref => Self_Ref,
908 Null_Seen => Null_Seen,
909 Non_Null_Seen => Non_Null_Seen);
914 -- Syntax error, always report
917 Error_Msg_N ("malformed dependency list", Item);
920 -- Process attribute 'Result in the context of a dependency clause
922 elsif Is_Attribute_Result (Item) then
923 Non_Null_Seen := True;
927 -- Attribute 'Result is allowed to appear on the output side of
928 -- a dependency clause (SPARK RM 6.1.5(6)).
931 SPARK_Msg_N ("function result cannot act as input", Item);
935 ("cannot mix null and non-null dependency items", Item);
941 -- Detect multiple uses of null in a single dependency list or
942 -- throughout the whole relation. Verify the placement of a null
943 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
945 elsif Nkind (Item) = N_Null then
948 ("multiple null dependency relations not allowed", Item);
950 elsif Non_Null_Seen then
952 ("cannot mix null and non-null dependency items", Item);
960 ("null output list must be the last clause in a "
961 & "dependency relation", Item);
963 -- Catch a useless dependence of the form:
968 ("useless dependence, null depends on itself", Item);
976 Non_Null_Seen := True;
979 SPARK_Msg_N ("cannot mix null and non-null items", Item);
983 Resolve_State (Item);
985 -- Find the entity of the item. If this is a renaming, climb
986 -- the renaming chain to reach the root object. Renamings of
987 -- non-entire objects do not yield an entity (Empty).
989 Item_Id := Entity_Of (Item);
991 if Present (Item_Id) then
995 if Ekind (Item_Id) in E_Constant | E_Loop_Parameter
998 -- Current instances of concurrent types
1000 Ekind (Item_Id) in E_Protected_Type | E_Task_Type
1003 -- Formal parameters
1005 Ekind (Item_Id) in E_Generic_In_Out_Parameter
1006 | E_Generic_In_Parameter
1008 | E_In_Out_Parameter
1012 -- States, variables
1014 Ekind (Item_Id) in E_Abstract_State | E_Variable
1016 -- A [generic] function is not allowed to have Output
1017 -- items in its dependency relations. Note that "null"
1018 -- and attribute 'Result are still valid items.
1020 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1021 and then not Is_Input
1024 ("output item is not applicable to function", Item);
1027 -- The item denotes a concurrent type. Note that single
1028 -- protected/task types are not considered here because
1029 -- they behave as objects in the context of pragma
1030 -- [Refined_]Depends.
1032 if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
1034 -- This use is legal as long as the concurrent type is
1035 -- the current instance of an enclosing type.
1037 if Is_CCT_Instance (Item_Id, Spec_Id) then
1039 -- The dependence of a task unit on itself is
1040 -- implicit and may or may not be explicitly
1041 -- specified (SPARK RM 6.1.4).
1043 if Ekind (Item_Id) = E_Task_Type then
1044 Current_Task_Instance_Seen;
1047 -- Otherwise this is not the current instance
1051 ("invalid use of subtype mark in dependency "
1052 & "relation", Item);
1055 -- The dependency of a task unit on itself is implicit
1056 -- and may or may not be explicitly specified
1057 -- (SPARK RM 6.1.4).
1059 elsif Is_Single_Task_Object (Item_Id)
1060 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1062 Current_Task_Instance_Seen;
1065 -- Ensure that the item fulfills its role as input and/or
1066 -- output as specified by pragma Global or the enclosing
1069 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1071 -- Detect multiple uses of the same state, variable or
1072 -- formal parameter. If this is not the case, add the
1073 -- item to the list of processed relations.
1075 if Contains (Seen, Item_Id) then
1077 ("duplicate use of item &", Item, Item_Id);
1079 Append_New_Elmt (Item_Id, Seen);
1082 -- Detect illegal use of an input related to a null
1083 -- output. Such input items cannot appear in other
1084 -- input lists (SPARK RM 6.1.5(13)).
1087 and then Null_Output_Seen
1088 and then Contains (All_Inputs_Seen, Item_Id)
1091 ("input of a null output list cannot appear in "
1092 & "multiple input lists", Item);
1095 -- Add an input or a self-referential output to the list
1096 -- of all processed inputs.
1098 if Is_Input or else Self_Ref then
1099 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1102 -- State related checks (SPARK RM 6.1.5(3))
1104 if Ekind (Item_Id) = E_Abstract_State then
1106 -- Package and subprogram bodies are instantiated
1107 -- individually in a separate compiler pass. Due to
1108 -- this mode of instantiation, the refinement of a
1109 -- state may no longer be visible when a subprogram
1110 -- body contract is instantiated. Since the generic
1111 -- template is legal, do not perform this check in
1112 -- the instance to circumvent this oddity.
1117 -- An abstract state with visible refinement cannot
1118 -- appear in pragma [Refined_]Depends as its place
1119 -- must be taken by some of its constituents
1120 -- (SPARK RM 6.1.4(7)).
1122 elsif Has_Visible_Refinement (Item_Id) then
1124 ("cannot mention state & in dependence relation",
1126 SPARK_Msg_N ("\use its constituents instead", Item);
1129 -- If the reference to the abstract state appears in
1130 -- an enclosing package body that will eventually
1131 -- refine the state, record the reference for future
1135 Record_Possible_Body_Reference
1136 (State_Id => Item_Id,
1141 -- When the item renames an entire object, replace the
1142 -- item with a reference to the object.
1144 if Entity (Item) /= Item_Id then
1146 New_Occurrence_Of (Item_Id, Sloc (Item)));
1150 -- Add the entity of the current item to the list of
1153 if Ekind (Item_Id) = E_Abstract_State then
1154 Append_New_Elmt (Item_Id, States_Seen);
1156 -- The variable may eventually become a constituent of a
1157 -- single protected/task type. Record the reference now
1158 -- and verify its legality when analyzing the contract of
1159 -- the variable (SPARK RM 9.3).
1161 elsif Ekind (Item_Id) = E_Variable then
1162 Record_Possible_Part_Of_Reference
1167 if Ekind (Item_Id) in E_Abstract_State
1170 and then Present (Encapsulating_State (Item_Id))
1172 Append_New_Elmt (Item_Id, Constits_Seen);
1175 -- All other input/output items are illegal
1176 -- (SPARK RM 6.1.5(1)).
1180 ("item must denote parameter, variable, state or "
1181 & "current instance of concurrent type", Item);
1184 -- All other input/output items are illegal
1185 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1189 ("item must denote parameter, variable, state or current "
1190 & "instance of concurrent type", Item);
1193 end Analyze_Input_Output;
1201 Non_Null_Output_Seen : Boolean := False;
1202 -- Flag used to check the legality of an output list
1204 -- Start of processing for Analyze_Dependency_Clause
1207 Inputs := Expression (Clause);
1210 -- An input list with a self-dependency appears as operator "+" where
1211 -- the actuals inputs are the right operand.
1213 if Nkind (Inputs) = N_Op_Plus then
1214 Inputs := Right_Opnd (Inputs);
1218 -- Process the output_list of a dependency_clause
1220 Output := First (Choices (Clause));
1221 while Present (Output) loop
1222 Analyze_Input_Output
1225 Self_Ref => Self_Ref,
1227 Seen => All_Outputs_Seen,
1228 Null_Seen => Null_Output_Seen,
1229 Non_Null_Seen => Non_Null_Output_Seen);
1234 -- Process the input_list of a dependency_clause
1236 Analyze_Input_List (Inputs);
1237 end Analyze_Dependency_Clause;
1239 ---------------------------
1240 -- Check_Function_Return --
1241 ---------------------------
1243 procedure Check_Function_Return is
1245 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1246 and then not Result_Seen
1249 ("result of & must appear in exactly one output list",
1252 end Check_Function_Return;
1258 procedure Check_Role
1260 Item_Id : Entity_Id;
1265 (Item_Is_Input : out Boolean;
1266 Item_Is_Output : out Boolean);
1267 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1268 -- Item_Is_Output are set depending on the role.
1270 procedure Role_Error
1271 (Item_Is_Input : Boolean;
1272 Item_Is_Output : Boolean);
1273 -- Emit an error message concerning the incorrect use of Item in
1274 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1275 -- denote whether the item is an input and/or an output.
1282 (Item_Is_Input : out Boolean;
1283 Item_Is_Output : out Boolean)
1285 -- A constant or IN parameter of access-to-variable type should be
1286 -- handled like a variable, as the underlying memory pointed-to
1287 -- can be modified. Use Adjusted_Kind to do this adjustment.
1289 Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
1292 if Ekind (Item_Id) in E_Constant
1293 | E_Generic_In_Parameter
1295 and then Is_Access_Variable (Etype (Item_Id))
1297 Adjusted_Kind := E_Variable;
1300 case Adjusted_Kind is
1304 when E_Abstract_State =>
1306 -- When pragma Global is present it determines the mode of
1307 -- the abstract state.
1310 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1311 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1313 -- Otherwise the state has a default IN OUT mode, because it
1314 -- behaves as a variable.
1317 Item_Is_Input := True;
1318 Item_Is_Output := True;
1321 -- Constants and IN parameters
1324 | E_Generic_In_Parameter
1328 -- When pragma Global is present it determines the mode
1329 -- of constant objects as inputs (and such objects cannot
1330 -- appear as outputs in the Global contract).
1333 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1335 Item_Is_Input := True;
1338 Item_Is_Output := False;
1340 -- Variables and IN OUT parameters, as well as constants and
1341 -- IN parameters of access type which are handled like
1344 when E_Generic_In_Out_Parameter
1345 | E_In_Out_Parameter
1348 -- When pragma Global is present it determines the mode of
1353 -- A variable has mode IN when its type is unconstrained
1354 -- or tagged because array bounds, discriminants or tags
1358 Appears_In (Subp_Inputs, Item_Id)
1359 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1361 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1363 -- Otherwise the variable has a default IN OUT mode
1366 Item_Is_Input := True;
1367 Item_Is_Output := True;
1370 when E_Out_Parameter =>
1372 -- An OUT parameter of the related subprogram; it cannot
1373 -- appear in Global.
1375 if Scope (Item_Id) = Spec_Id then
1377 -- The parameter has mode IN if its type is unconstrained
1378 -- or tagged because array bounds, discriminants or tags
1382 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1384 Item_Is_Output := True;
1386 -- An OUT parameter of an enclosing subprogram; it can
1387 -- appear in Global and behaves as a read-write variable.
1390 -- When pragma Global is present it determines the mode
1395 -- A variable has mode IN when its type is
1396 -- unconstrained or tagged because array
1397 -- bounds, discriminants or tags can be read.
1400 Appears_In (Subp_Inputs, Item_Id)
1401 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1403 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1405 -- Otherwise the variable has a default IN OUT mode
1408 Item_Is_Input := True;
1409 Item_Is_Output := True;
1415 when E_Protected_Type =>
1418 -- A variable has mode IN when its type is unconstrained
1419 -- or tagged because array bounds, discriminants or tags
1423 Appears_In (Subp_Inputs, Item_Id)
1424 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1426 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1429 -- A protected type acts as a formal parameter of mode IN
1430 -- when it applies to a protected function.
1432 if Ekind (Spec_Id) = E_Function then
1433 Item_Is_Input := True;
1434 Item_Is_Output := False;
1436 -- Otherwise the protected type acts as a formal of mode
1440 Item_Is_Input := True;
1441 Item_Is_Output := True;
1449 -- When pragma Global is present it determines the mode of
1454 Appears_In (Subp_Inputs, Item_Id)
1455 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1457 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1459 -- Otherwise task types act as IN OUT parameters
1462 Item_Is_Input := True;
1463 Item_Is_Output := True;
1467 raise Program_Error;
1475 procedure Role_Error
1476 (Item_Is_Input : Boolean;
1477 Item_Is_Output : Boolean)
1479 Error_Msg : Name_Id;
1484 -- When the item is not part of the input and the output set of
1485 -- the related subprogram, then it appears as extra in pragma
1486 -- [Refined_]Depends.
1488 if not Item_Is_Input and then not Item_Is_Output then
1489 Add_Item_To_Name_Buffer (Item_Id);
1490 Add_Str_To_Name_Buffer
1491 (" & cannot appear in dependence relation");
1493 Error_Msg := Name_Find;
1494 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1496 Error_Msg_Name_1 := Chars (Spec_Id);
1498 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1499 & "set of subprogram %"), Item, Item_Id);
1501 -- The mode of the item and its role in pragma [Refined_]Depends
1502 -- are in conflict. Construct a detailed message explaining the
1503 -- illegality (SPARK RM 6.1.5(5-6)).
1506 if Item_Is_Input then
1507 Add_Str_To_Name_Buffer ("read-only");
1509 Add_Str_To_Name_Buffer ("write-only");
1512 Add_Char_To_Name_Buffer (' ');
1513 Add_Item_To_Name_Buffer (Item_Id);
1514 Add_Str_To_Name_Buffer (" & cannot appear as ");
1516 if Item_Is_Input then
1517 Add_Str_To_Name_Buffer ("output");
1519 Add_Str_To_Name_Buffer ("input");
1522 Add_Str_To_Name_Buffer (" in dependence relation");
1523 Error_Msg := Name_Find;
1524 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1530 Item_Is_Input : Boolean;
1531 Item_Is_Output : Boolean;
1533 -- Start of processing for Check_Role
1536 Find_Role (Item_Is_Input, Item_Is_Output);
1541 if not Item_Is_Input then
1542 Role_Error (Item_Is_Input, Item_Is_Output);
1545 -- Self-referential item
1548 if not Item_Is_Input or else not Item_Is_Output then
1549 Role_Error (Item_Is_Input, Item_Is_Output);
1554 elsif not Item_Is_Output then
1555 Role_Error (Item_Is_Input, Item_Is_Output);
1563 procedure Check_Usage
1564 (Subp_Items : Elist_Id;
1565 Used_Items : Elist_Id;
1568 procedure Usage_Error (Item_Id : Entity_Id);
1569 -- Emit an error concerning the illegal usage of an item
1575 procedure Usage_Error (Item_Id : Entity_Id) is
1576 Error_Msg : Name_Id;
1583 -- Unconstrained and tagged items are not part of the explicit
1584 -- input set of the related subprogram, they do not have to be
1585 -- present in a dependence relation and should not be flagged
1586 -- (SPARK RM 6.1.5(5)).
1588 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1591 Add_Item_To_Name_Buffer (Item_Id);
1592 Add_Str_To_Name_Buffer
1593 (" & is missing from input dependence list");
1595 Error_Msg := Name_Find;
1596 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1598 ("\add `null ='> &` dependency to ignore this input",
1602 -- Output case (SPARK RM 6.1.5(10))
1607 Add_Item_To_Name_Buffer (Item_Id);
1608 Add_Str_To_Name_Buffer
1609 (" & is missing from output dependence list");
1611 Error_Msg := Name_Find;
1612 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1620 Item_Id : Entity_Id;
1622 -- Start of processing for Check_Usage
1625 if No (Subp_Items) then
1629 -- Each input or output of the subprogram must appear in a dependency
1632 Elmt := First_Elmt (Subp_Items);
1633 while Present (Elmt) loop
1634 Item := Node (Elmt);
1636 if Nkind (Item) = N_Defining_Identifier then
1639 Item_Id := Entity_Of (Item);
1642 -- The item does not appear in a dependency
1644 if Present (Item_Id)
1645 and then not Contains (Used_Items, Item_Id)
1647 if Is_Formal (Item_Id) then
1648 Usage_Error (Item_Id);
1650 -- The current instance of a protected type behaves as a formal
1651 -- parameter (SPARK RM 6.1.4).
1653 elsif Ekind (Item_Id) = E_Protected_Type
1654 or else Is_Single_Protected_Object (Item_Id)
1656 Usage_Error (Item_Id);
1658 -- The current instance of a task type behaves as a formal
1659 -- parameter (SPARK RM 6.1.4).
1661 elsif Ekind (Item_Id) = E_Task_Type
1662 or else Is_Single_Task_Object (Item_Id)
1664 -- The dependence of a task unit on itself is implicit and
1665 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1666 -- Emit an error if only one input/output is present.
1668 if Task_Input_Seen /= Task_Output_Seen then
1669 Usage_Error (Item_Id);
1672 -- States and global objects are not used properly only when
1673 -- the subprogram is subject to pragma Global.
1675 elsif Global_Seen then
1676 Usage_Error (Item_Id);
1684 ----------------------
1685 -- Normalize_Clause --
1686 ----------------------
1688 procedure Normalize_Clause (Clause : Node_Id) is
1689 procedure Create_Or_Modify_Clause
1695 Multiple : Boolean);
1696 -- Create a brand new clause to represent the self-reference or
1697 -- modify the input and/or output lists of an existing clause. Output
1698 -- denotes a self-referencial output. Outputs is the output list of a
1699 -- clause. Inputs is the input list of a clause. After denotes the
1700 -- clause after which the new clause is to be inserted. Flag In_Place
1701 -- should be set when normalizing the last output of an output list.
1702 -- Flag Multiple should be set when Output comes from a list with
1705 -----------------------------
1706 -- Create_Or_Modify_Clause --
1707 -----------------------------
1709 procedure Create_Or_Modify_Clause
1717 procedure Propagate_Output
1720 -- Handle the various cases of output propagation to the input
1721 -- list. Output denotes a self-referencial output item. Inputs
1722 -- is the input list of a clause.
1724 ----------------------
1725 -- Propagate_Output --
1726 ----------------------
1728 procedure Propagate_Output
1732 function In_Input_List
1734 Inputs : List_Id) return Boolean;
1735 -- Determine whether a particulat item appears in the input
1736 -- list of a clause.
1742 function In_Input_List
1744 Inputs : List_Id) return Boolean
1749 Elmt := First (Inputs);
1750 while Present (Elmt) loop
1751 if Entity_Of (Elmt) = Item then
1763 Output_Id : constant Entity_Id := Entity_Of (Output);
1766 -- Start of processing for Propagate_Output
1769 -- The clause is of the form:
1771 -- (Output =>+ null)
1773 -- Remove null input and replace it with a copy of the output:
1775 -- (Output => Output)
1777 if Nkind (Inputs) = N_Null then
1778 Rewrite (Inputs, New_Copy_Tree (Output));
1780 -- The clause is of the form:
1782 -- (Output =>+ (Input1, ..., InputN))
1784 -- Determine whether the output is not already mentioned in the
1785 -- input list and if not, add it to the list of inputs:
1787 -- (Output => (Output, Input1, ..., InputN))
1789 elsif Nkind (Inputs) = N_Aggregate then
1790 Grouped := Expressions (Inputs);
1792 if not In_Input_List
1796 Prepend_To (Grouped, New_Copy_Tree (Output));
1799 -- The clause is of the form:
1801 -- (Output =>+ Input)
1803 -- If the input does not mention the output, group the two
1806 -- (Output => (Output, Input))
1808 elsif Entity_Of (Inputs) /= Output_Id then
1810 Make_Aggregate (Loc,
1811 Expressions => New_List (
1812 New_Copy_Tree (Output),
1813 New_Copy_Tree (Inputs))));
1815 end Propagate_Output;
1819 Loc : constant Source_Ptr := Sloc (Clause);
1820 New_Clause : Node_Id;
1822 -- Start of processing for Create_Or_Modify_Clause
1825 -- A null output depending on itself does not require any
1828 if Nkind (Output) = N_Null then
1831 -- A function result cannot depend on itself because it cannot
1832 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1834 elsif Is_Attribute_Result (Output) then
1835 SPARK_Msg_N ("function result cannot depend on itself", Output);
1839 -- When performing the transformation in place, simply add the
1840 -- output to the list of inputs (if not already there). This
1841 -- case arises when dealing with the last output of an output
1842 -- list. Perform the normalization in place to avoid generating
1843 -- a malformed tree.
1846 Propagate_Output (Output, Inputs);
1848 -- A list with multiple outputs is slowly trimmed until only
1849 -- one element remains. When this happens, replace aggregate
1850 -- with the element itself.
1854 Rewrite (Outputs, Output);
1860 -- Unchain the output from its output list as it will appear in
1861 -- a new clause. Note that we cannot simply rewrite the output
1862 -- as null because this will violate the semantics of pragma
1867 -- Generate a new clause of the form:
1868 -- (Output => Inputs)
1871 Make_Component_Association (Loc,
1872 Choices => New_List (Output),
1873 Expression => New_Copy_Tree (Inputs));
1875 -- The new clause contains replicated content that has already
1876 -- been analyzed. There is not need to reanalyze or renormalize
1879 Set_Analyzed (New_Clause);
1882 (Output => First (Choices (New_Clause)),
1883 Inputs => Expression (New_Clause));
1885 Insert_After (After, New_Clause);
1887 end Create_Or_Modify_Clause;
1891 Outputs : constant Node_Id := First (Choices (Clause));
1893 Last_Output : Node_Id;
1894 Next_Output : Node_Id;
1897 -- Start of processing for Normalize_Clause
1900 -- A self-dependency appears as operator "+". Remove the "+" from the
1901 -- tree by moving the real inputs to their proper place.
1903 if Nkind (Expression (Clause)) = N_Op_Plus then
1904 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1905 Inputs := Expression (Clause);
1907 -- Multiple outputs appear as an aggregate
1909 if Nkind (Outputs) = N_Aggregate then
1910 Last_Output := Last (Expressions (Outputs));
1912 Output := First (Expressions (Outputs));
1913 while Present (Output) loop
1915 -- Normalization may remove an output from its list,
1916 -- preserve the subsequent output now.
1918 Next_Output := Next (Output);
1920 Create_Or_Modify_Clause
1925 In_Place => Output = Last_Output,
1928 Output := Next_Output;
1934 Create_Or_Modify_Clause
1943 end Normalize_Clause;
1947 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1948 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1952 Last_Clause : Node_Id;
1953 Restore_Scope : Boolean := False;
1955 -- Start of processing for Analyze_Depends_In_Decl_Part
1958 -- Do not analyze the pragma multiple times
1960 if Is_Analyzed_Pragma (N) then
1964 -- Empty dependency list
1966 if Nkind (Deps) = N_Null then
1968 -- Gather all states, objects and formal parameters that the
1969 -- subprogram may depend on. These items are obtained from the
1970 -- parameter profile or pragma [Refined_]Global (if available).
1972 Collect_Subprogram_Inputs_Outputs
1973 (Subp_Id => Subp_Id,
1974 Subp_Inputs => Subp_Inputs,
1975 Subp_Outputs => Subp_Outputs,
1976 Global_Seen => Global_Seen);
1978 -- Verify that every input or output of the subprogram appear in a
1981 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1982 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1983 Check_Function_Return;
1985 -- Dependency clauses appear as component associations of an aggregate
1987 elsif Nkind (Deps) = N_Aggregate then
1989 -- Do not attempt to perform analysis of a syntactically illegal
1990 -- clause as this will lead to misleading errors.
1992 if Has_Extra_Parentheses (Deps) then
1996 if Present (Component_Associations (Deps)) then
1997 Last_Clause := Last (Component_Associations (Deps));
1999 -- Gather all states, objects and formal parameters that the
2000 -- subprogram may depend on. These items are obtained from the
2001 -- parameter profile or pragma [Refined_]Global (if available).
2003 Collect_Subprogram_Inputs_Outputs
2004 (Subp_Id => Subp_Id,
2005 Subp_Inputs => Subp_Inputs,
2006 Subp_Outputs => Subp_Outputs,
2007 Global_Seen => Global_Seen);
2009 -- When pragma [Refined_]Depends appears on a single concurrent
2010 -- type, it is relocated to the anonymous object.
2012 if Is_Single_Concurrent_Object (Spec_Id) then
2015 -- Ensure that the formal parameters are visible when analyzing
2016 -- all clauses. This falls out of the general rule of aspects
2017 -- pertaining to subprogram declarations.
2019 elsif not In_Open_Scopes (Spec_Id) then
2020 Restore_Scope := True;
2021 Push_Scope (Spec_Id);
2023 if Ekind (Spec_Id) = E_Task_Type then
2025 -- Task discriminants cannot appear in the [Refined_]Depends
2026 -- contract, but must be present for the analysis so that we
2027 -- can reject them with an informative error message.
2029 if Has_Discriminants (Spec_Id) then
2030 Install_Discriminants (Spec_Id);
2033 elsif Is_Generic_Subprogram (Spec_Id) then
2034 Install_Generic_Formals (Spec_Id);
2037 Install_Formals (Spec_Id);
2041 Clause := First (Component_Associations (Deps));
2042 while Present (Clause) loop
2043 Errors := Serious_Errors_Detected;
2045 -- The normalization mechanism may create extra clauses that
2046 -- contain replicated input and output names. There is no need
2047 -- to reanalyze them.
2049 if not Analyzed (Clause) then
2050 Set_Analyzed (Clause);
2052 Analyze_Dependency_Clause
2054 Is_Last => Clause = Last_Clause);
2057 -- Do not normalize a clause if errors were detected (count
2058 -- of Serious_Errors has increased) because the inputs and/or
2059 -- outputs may denote illegal items.
2061 if Serious_Errors_Detected = Errors then
2062 Normalize_Clause (Clause);
2068 if Restore_Scope then
2072 -- Verify that every input or output of the subprogram appear in a
2075 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2076 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2077 Check_Function_Return;
2079 -- The dependency list is malformed. This is a syntax error, always
2083 Error_Msg_N ("malformed dependency relation", Deps);
2087 -- The top level dependency relation is malformed. This is a syntax
2088 -- error, always report.
2091 Error_Msg_N ("malformed dependency relation", Deps);
2095 -- Ensure that a state and a corresponding constituent do not appear
2096 -- together in pragma [Refined_]Depends.
2098 Check_State_And_Constituent_Use
2099 (States => States_Seen,
2100 Constits => Constits_Seen,
2104 Set_Is_Analyzed_Pragma (N);
2105 end Analyze_Depends_In_Decl_Part;
2107 --------------------------------------------
2108 -- Analyze_External_Property_In_Decl_Part --
2109 --------------------------------------------
2111 procedure Analyze_External_Property_In_Decl_Part
2113 Expr_Val : out Boolean)
2115 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2116 Arg1 : constant Node_Id :=
2117 First (Pragma_Argument_Associations (N));
2118 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2119 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2123 -- Do not analyze the pragma multiple times, but set the output
2124 -- parameter to the argument specified by the pragma.
2126 if Is_Analyzed_Pragma (N) then
2130 Error_Msg_Name_1 := Pragma_Name (N);
2132 -- An external property pragma must apply to an effectively volatile
2133 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2134 -- The check is performed at the end of the declarative region due to a
2135 -- possible out-of-order arrangement of pragmas:
2138 -- pragma Async_Readers (Obj);
2139 -- pragma Volatile (Obj);
2141 if Prag_Id /= Pragma_No_Caching
2142 and then not Is_Effectively_Volatile (Obj_Id)
2144 if Ekind (Obj_Id) = E_Variable
2145 and then No_Caching_Enabled (Obj_Id)
2148 ("illegal combination of external property % and property "
2149 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2152 ("external property % must apply to a volatile type or object",
2156 -- Pragma No_Caching should only apply to volatile variables of
2157 -- a non-effectively volatile type (SPARK RM 7.1.2).
2159 elsif Prag_Id = Pragma_No_Caching then
2160 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2161 SPARK_Msg_N ("property % must not apply to an object of "
2162 & "an effectively volatile type", N);
2163 elsif not Is_Volatile (Obj_Id) then
2164 SPARK_Msg_N ("property % must apply to a volatile object", N);
2168 Set_Is_Analyzed_Pragma (N);
2172 -- Ensure that the Boolean expression (if present) is static. A missing
2173 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2177 if Present (Arg1) then
2178 Expr := Get_Pragma_Arg (Arg1);
2180 if Is_OK_Static_Expression (Expr) then
2181 Expr_Val := Is_True (Expr_Value (Expr));
2185 end Analyze_External_Property_In_Decl_Part;
2187 ---------------------------------
2188 -- Analyze_Global_In_Decl_Part --
2189 ---------------------------------
2191 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2192 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2193 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2194 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2196 Constits_Seen : Elist_Id := No_Elist;
2197 -- A list containing the entities of all constituents processed so far.
2198 -- It aids in detecting illegal usage of a state and a corresponding
2199 -- constituent in pragma [Refinde_]Global.
2201 Seen : Elist_Id := No_Elist;
2202 -- A list containing the entities of all the items processed so far. It
2203 -- plays a role in detecting distinct entities.
2205 States_Seen : Elist_Id := No_Elist;
2206 -- A list containing the entities of all states processed so far. It
2207 -- helps in detecting illegal usage of a state and a corresponding
2208 -- constituent in pragma [Refined_]Global.
2210 In_Out_Seen : Boolean := False;
2211 Input_Seen : Boolean := False;
2212 Output_Seen : Boolean := False;
2213 Proof_Seen : Boolean := False;
2214 -- Flags used to verify the consistency of modes
2216 procedure Analyze_Global_List
2218 Global_Mode : Name_Id := Name_Input);
2219 -- Verify the legality of a single global list declaration. Global_Mode
2220 -- denotes the current mode in effect.
2222 -------------------------
2223 -- Analyze_Global_List --
2224 -------------------------
2226 procedure Analyze_Global_List
2228 Global_Mode : Name_Id := Name_Input)
2230 procedure Analyze_Global_Item
2232 Global_Mode : Name_Id);
2233 -- Verify the legality of a single global item declaration denoted by
2234 -- Item. Global_Mode denotes the current mode in effect.
2236 procedure Check_Duplicate_Mode
2238 Status : in out Boolean);
2239 -- Flag Status denotes whether a particular mode has been seen while
2240 -- processing a global list. This routine verifies that Mode is not a
2241 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2243 procedure Check_Mode_Restriction_In_Enclosing_Context
2245 Item_Id : Entity_Id);
2246 -- Verify that an item of mode In_Out or Output does not appear as
2247 -- an input in the Global aspect of an enclosing subprogram or task
2248 -- unit. If this is the case, emit an error. Item and Item_Id are
2249 -- respectively the item and its entity.
2251 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2252 -- Mode denotes either In_Out or Output. Depending on the kind of the
2253 -- related subprogram, emit an error if those two modes apply to a
2254 -- function (SPARK RM 6.1.4(10)).
2256 -------------------------
2257 -- Analyze_Global_Item --
2258 -------------------------
2260 procedure Analyze_Global_Item
2262 Global_Mode : Name_Id)
2264 Item_Id : Entity_Id;
2267 -- Detect one of the following cases
2269 -- with Global => (null, Name)
2270 -- with Global => (Name_1, null, Name_2)
2271 -- with Global => (Name, null)
2273 if Nkind (Item) = N_Null then
2274 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2279 Resolve_State (Item);
2281 -- Find the entity of the item. If this is a renaming, climb the
2282 -- renaming chain to reach the root object. Renamings of non-
2283 -- entire objects do not yield an entity (Empty).
2285 Item_Id := Entity_Of (Item);
2287 if Present (Item_Id) then
2289 -- A global item may denote a formal parameter of an enclosing
2290 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2291 -- provide a better error diagnostic.
2293 if Is_Formal (Item_Id) then
2294 if Scope (Item_Id) = Spec_Id then
2296 (Fix_Msg (Spec_Id, "global item cannot reference "
2297 & "parameter of subprogram &"), Item, Spec_Id);
2301 -- A global item may denote a concurrent type as long as it is
2302 -- the current instance of an enclosing protected or task type
2303 -- (SPARK RM 6.1.4).
2305 elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
2306 if Is_CCT_Instance (Item_Id, Spec_Id) then
2308 -- Pragma [Refined_]Global associated with a protected
2309 -- subprogram cannot mention the current instance of a
2310 -- protected type because the instance behaves as a
2311 -- formal parameter.
2313 if Ekind (Item_Id) = E_Protected_Type then
2314 if Scope (Spec_Id) = Item_Id then
2315 Error_Msg_Name_1 := Chars (Item_Id);
2317 (Fix_Msg (Spec_Id, "global item of subprogram & "
2318 & "cannot reference current instance of "
2319 & "protected type %"), Item, Spec_Id);
2323 -- Pragma [Refined_]Global associated with a task type
2324 -- cannot mention the current instance of a task type
2325 -- because the instance behaves as a formal parameter.
2327 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2328 if Spec_Id = Item_Id then
2329 Error_Msg_Name_1 := Chars (Item_Id);
2331 (Fix_Msg (Spec_Id, "global item of subprogram & "
2332 & "cannot reference current instance of task "
2333 & "type %"), Item, Spec_Id);
2338 -- Otherwise the global item denotes a subtype mark that is
2339 -- not a current instance.
2343 ("invalid use of subtype mark in global list", Item);
2347 -- A global item may denote the anonymous object created for a
2348 -- single protected/task type as long as the current instance
2349 -- is the same single type (SPARK RM 6.1.4).
2351 elsif Is_Single_Concurrent_Object (Item_Id)
2352 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2354 -- Pragma [Refined_]Global associated with a protected
2355 -- subprogram cannot mention the current instance of a
2356 -- protected type because the instance behaves as a formal
2359 if Is_Single_Protected_Object (Item_Id) then
2360 if Scope (Spec_Id) = Etype (Item_Id) then
2361 Error_Msg_Name_1 := Chars (Item_Id);
2363 (Fix_Msg (Spec_Id, "global item of subprogram & "
2364 & "cannot reference current instance of protected "
2365 & "type %"), Item, Spec_Id);
2369 -- Pragma [Refined_]Global associated with a task type
2370 -- cannot mention the current instance of a task type
2371 -- because the instance behaves as a formal parameter.
2373 else pragma Assert (Is_Single_Task_Object (Item_Id));
2374 if Spec_Id = Item_Id then
2375 Error_Msg_Name_1 := Chars (Item_Id);
2377 (Fix_Msg (Spec_Id, "global item of subprogram & "
2378 & "cannot reference current instance of task "
2379 & "type %"), Item, Spec_Id);
2384 -- A formal object may act as a global item inside a generic
2386 elsif Is_Formal_Object (Item_Id) then
2389 -- The only legal references are those to abstract states,
2390 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2392 elsif Ekind (Item_Id) not in E_Abstract_State
2398 ("global item must denote object, state or current "
2399 & "instance of concurrent type", Item);
2401 if Is_Named_Number (Item_Id) then
2403 ("\named number & is not an object", Item, Item_Id);
2409 -- State related checks
2411 if Ekind (Item_Id) = E_Abstract_State then
2413 -- Package and subprogram bodies are instantiated
2414 -- individually in a separate compiler pass. Due to this
2415 -- mode of instantiation, the refinement of a state may
2416 -- no longer be visible when a subprogram body contract
2417 -- is instantiated. Since the generic template is legal,
2418 -- do not perform this check in the instance to circumvent
2424 -- An abstract state with visible refinement cannot appear
2425 -- in pragma [Refined_]Global as its place must be taken by
2426 -- some of its constituents (SPARK RM 6.1.4(7)).
2428 elsif Has_Visible_Refinement (Item_Id) then
2430 ("cannot mention state & in global refinement",
2432 SPARK_Msg_N ("\use its constituents instead", Item);
2435 -- An external state cannot appear as a global item of a
2436 -- nonvolatile function (SPARK RM 7.1.3(8)).
2438 elsif Is_External_State (Item_Id)
2439 and then Ekind (Spec_Id) in E_Function | E_Generic_Function
2440 and then not Is_Volatile_Function (Spec_Id)
2443 ("external state & cannot act as global item of "
2444 & "nonvolatile function", Item, Item_Id);
2447 -- If the reference to the abstract state appears in an
2448 -- enclosing package body that will eventually refine the
2449 -- state, record the reference for future checks.
2452 Record_Possible_Body_Reference
2453 (State_Id => Item_Id,
2457 -- Constant related checks
2459 elsif Ekind (Item_Id) = E_Constant
2460 and then not Is_Access_Type (Etype (Item_Id))
2463 -- Unless it is of an access type, a constant is a read-only
2464 -- item, therefore it cannot act as an output.
2466 if Global_Mode in Name_In_Out | Name_Output then
2468 ("constant & cannot act as output", Item, Item_Id);
2472 -- Loop parameter related checks
2474 elsif Ekind (Item_Id) = E_Loop_Parameter then
2476 -- A loop parameter is a read-only item, therefore it cannot
2477 -- act as an output.
2479 if Global_Mode in Name_In_Out | Name_Output then
2481 ("loop parameter & cannot act as output",
2486 -- Variable related checks. These are only relevant when
2487 -- SPARK_Mode is on as they are not standard Ada legality
2490 elsif SPARK_Mode = On
2491 and then Ekind (Item_Id) = E_Variable
2492 and then Is_Effectively_Volatile_For_Reading (Item_Id)
2494 -- The current instance of a protected unit is not an
2495 -- effectively volatile object, unless the protected unit
2496 -- is already volatile for another reason (SPARK RM 7.1.2).
2498 if Is_Single_Protected_Object (Item_Id)
2499 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2500 and then not Is_Effectively_Volatile_For_Reading
2501 (Item_Id, Ignore_Protected => True)
2505 -- An effectively volatile object for reading cannot appear
2506 -- as a global item of a nonvolatile function (SPARK RM
2509 elsif Ekind (Spec_Id) in E_Function | E_Generic_Function
2510 and then not Is_Volatile_Function (Spec_Id)
2513 ("volatile object & cannot act as global item of a "
2514 & "function", Item, Item_Id);
2517 -- An effectively volatile object with external property
2518 -- Effective_Reads set to True must have mode Output or
2519 -- In_Out (SPARK RM 7.1.3(10)).
2521 elsif Effective_Reads_Enabled (Item_Id)
2522 and then Global_Mode = Name_Input
2525 ("volatile object & with property Effective_Reads must "
2526 & "have mode In_Out or Output", Item, Item_Id);
2531 -- When the item renames an entire object, replace the item
2532 -- with a reference to the object.
2534 if Entity (Item) /= Item_Id then
2535 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2539 -- Some form of illegal construct masquerading as a name
2540 -- (SPARK RM 6.1.4(4)).
2544 ("global item must denote object, state or current instance "
2545 & "of concurrent type", Item);
2549 -- Verify that an output does not appear as an input in an
2550 -- enclosing subprogram.
2552 if Global_Mode in Name_In_Out | Name_Output then
2553 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2556 -- The same entity might be referenced through various way.
2557 -- Check the entity of the item rather than the item itself
2558 -- (SPARK RM 6.1.4(10)).
2560 if Contains (Seen, Item_Id) then
2561 SPARK_Msg_N ("duplicate global item", Item);
2563 -- Add the entity of the current item to the list of processed
2567 Append_New_Elmt (Item_Id, Seen);
2569 if Ekind (Item_Id) = E_Abstract_State then
2570 Append_New_Elmt (Item_Id, States_Seen);
2572 -- The variable may eventually become a constituent of a single
2573 -- protected/task type. Record the reference now and verify its
2574 -- legality when analyzing the contract of the variable
2577 elsif Ekind (Item_Id) = E_Variable then
2578 Record_Possible_Part_Of_Reference
2583 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
2584 and then Present (Encapsulating_State (Item_Id))
2586 Append_New_Elmt (Item_Id, Constits_Seen);
2589 end Analyze_Global_Item;
2591 --------------------------
2592 -- Check_Duplicate_Mode --
2593 --------------------------
2595 procedure Check_Duplicate_Mode
2597 Status : in out Boolean)
2601 SPARK_Msg_N ("duplicate global mode", Mode);
2605 end Check_Duplicate_Mode;
2607 -------------------------------------------------
2608 -- Check_Mode_Restriction_In_Enclosing_Context --
2609 -------------------------------------------------
2611 procedure Check_Mode_Restriction_In_Enclosing_Context
2613 Item_Id : Entity_Id)
2615 Context : Entity_Id;
2617 Inputs : Elist_Id := No_Elist;
2618 Outputs : Elist_Id := No_Elist;
2621 -- Traverse the scope stack looking for enclosing subprograms or
2622 -- tasks subject to pragma [Refined_]Global.
2624 Context := Scope (Subp_Id);
2625 while Present (Context) and then Context /= Standard_Standard loop
2627 -- For a single task type, retrieve the corresponding object to
2628 -- which pragma [Refined_]Global is attached.
2630 if Ekind (Context) = E_Task_Type
2631 and then Is_Single_Concurrent_Type (Context)
2633 Context := Anonymous_Object (Context);
2636 if (Is_Subprogram (Context)
2637 or else Ekind (Context) = E_Task_Type
2638 or else Is_Single_Task_Object (Context))
2640 (Present (Get_Pragma (Context, Pragma_Global))
2642 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2644 Collect_Subprogram_Inputs_Outputs
2645 (Subp_Id => Context,
2646 Subp_Inputs => Inputs,
2647 Subp_Outputs => Outputs,
2648 Global_Seen => Dummy);
2650 -- The item is classified as In_Out or Output but appears as
2651 -- an Input in an enclosing subprogram or task unit (SPARK
2654 if Appears_In (Inputs, Item_Id)
2655 and then not Appears_In (Outputs, Item_Id)
2658 ("global item & cannot have mode In_Out or Output",
2661 if Is_Subprogram (Context) then
2663 (Fix_Msg (Subp_Id, "\item already appears as input "
2664 & "of subprogram &"), Item, Context);
2667 (Fix_Msg (Subp_Id, "\item already appears as input "
2668 & "of task &"), Item, Context);
2671 -- Stop the traversal once an error has been detected
2677 Context := Scope (Context);
2679 end Check_Mode_Restriction_In_Enclosing_Context;
2681 ----------------------------------------
2682 -- Check_Mode_Restriction_In_Function --
2683 ----------------------------------------
2685 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2687 if Ekind (Spec_Id) in E_Function | E_Generic_Function then
2689 ("global mode & is not applicable to functions", Mode);
2691 end Check_Mode_Restriction_In_Function;
2699 -- Start of processing for Analyze_Global_List
2702 if Nkind (List) = N_Null then
2703 Set_Analyzed (List);
2705 -- Single global item declaration
2707 elsif Nkind (List) in N_Expanded_Name
2709 | N_Selected_Component
2711 Analyze_Global_Item (List, Global_Mode);
2713 -- Simple global list or moded global list declaration
2715 elsif Nkind (List) = N_Aggregate then
2716 Set_Analyzed (List);
2718 -- The declaration of a simple global list appear as a collection
2721 if Present (Expressions (List)) then
2722 if Present (Component_Associations (List)) then
2724 ("cannot mix moded and non-moded global lists", List);
2727 Item := First (Expressions (List));
2728 while Present (Item) loop
2729 Analyze_Global_Item (Item, Global_Mode);
2733 -- The declaration of a moded global list appears as a collection
2734 -- of component associations where individual choices denote
2737 elsif Present (Component_Associations (List)) then
2738 if Present (Expressions (List)) then
2740 ("cannot mix moded and non-moded global lists", List);
2743 Assoc := First (Component_Associations (List));
2744 while Present (Assoc) loop
2745 Mode := First (Choices (Assoc));
2747 if Nkind (Mode) = N_Identifier then
2748 if Chars (Mode) = Name_In_Out then
2749 Check_Duplicate_Mode (Mode, In_Out_Seen);
2750 Check_Mode_Restriction_In_Function (Mode);
2752 elsif Chars (Mode) = Name_Input then
2753 Check_Duplicate_Mode (Mode, Input_Seen);
2755 elsif Chars (Mode) = Name_Output then
2756 Check_Duplicate_Mode (Mode, Output_Seen);
2757 Check_Mode_Restriction_In_Function (Mode);
2759 elsif Chars (Mode) = Name_Proof_In then
2760 Check_Duplicate_Mode (Mode, Proof_Seen);
2763 SPARK_Msg_N ("invalid mode selector", Mode);
2767 SPARK_Msg_N ("invalid mode selector", Mode);
2770 -- Items in a moded list appear as a collection of
2771 -- expressions. Reuse the existing machinery to analyze
2775 (List => Expression (Assoc),
2776 Global_Mode => Chars (Mode));
2784 raise Program_Error;
2787 -- Any other attempt to declare a global item is illegal. This is a
2788 -- syntax error, always report.
2791 Error_Msg_N ("malformed global list", List);
2793 end Analyze_Global_List;
2797 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2799 Restore_Scope : Boolean := False;
2801 -- Start of processing for Analyze_Global_In_Decl_Part
2804 -- Do not analyze the pragma multiple times
2806 if Is_Analyzed_Pragma (N) then
2810 -- There is nothing to be done for a null global list
2812 if Nkind (Items) = N_Null then
2813 Set_Analyzed (Items);
2815 -- Analyze the various forms of global lists and items. Note that some
2816 -- of these may be malformed in which case the analysis emits error
2820 -- When pragma [Refined_]Global appears on a single concurrent type,
2821 -- it is relocated to the anonymous object.
2823 if Is_Single_Concurrent_Object (Spec_Id) then
2826 -- Ensure that the formal parameters are visible when processing an
2827 -- item. This falls out of the general rule of aspects pertaining to
2828 -- subprogram declarations.
2830 elsif not In_Open_Scopes (Spec_Id) then
2831 Restore_Scope := True;
2832 Push_Scope (Spec_Id);
2834 if Ekind (Spec_Id) = E_Task_Type then
2836 -- Task discriminants cannot appear in the [Refined_]Global
2837 -- contract, but must be present for the analysis so that we
2838 -- can reject them with an informative error message.
2840 if Has_Discriminants (Spec_Id) then
2841 Install_Discriminants (Spec_Id);
2844 elsif Is_Generic_Subprogram (Spec_Id) then
2845 Install_Generic_Formals (Spec_Id);
2848 Install_Formals (Spec_Id);
2852 Analyze_Global_List (Items);
2854 if Restore_Scope then
2859 -- Ensure that a state and a corresponding constituent do not appear
2860 -- together in pragma [Refined_]Global.
2862 Check_State_And_Constituent_Use
2863 (States => States_Seen,
2864 Constits => Constits_Seen,
2867 Set_Is_Analyzed_Pragma (N);
2868 end Analyze_Global_In_Decl_Part;
2870 --------------------------------------------
2871 -- Analyze_Initial_Condition_In_Decl_Part --
2872 --------------------------------------------
2874 -- WARNING: This routine manages Ghost regions. Return statements must be
2875 -- replaced by gotos which jump to the end of the routine and restore the
2878 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2879 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2880 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2881 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2883 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2884 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2885 -- Save the Ghost-related attributes to restore on exit
2888 -- Do not analyze the pragma multiple times
2890 if Is_Analyzed_Pragma (N) then
2894 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2895 -- analysis of the pragma, the Ghost mode at point of declaration and
2896 -- point of analysis may not necessarily be the same. Use the mode in
2897 -- effect at the point of declaration.
2901 -- The expression is preanalyzed because it has not been moved to its
2902 -- final place yet. A direct analysis may generate side effects and this
2903 -- is not desired at this point.
2905 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2906 Set_Is_Analyzed_Pragma (N);
2908 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2909 end Analyze_Initial_Condition_In_Decl_Part;
2911 --------------------------------------
2912 -- Analyze_Initializes_In_Decl_Part --
2913 --------------------------------------
2915 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2916 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2917 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2919 Constits_Seen : Elist_Id := No_Elist;
2920 -- A list containing the entities of all constituents processed so far.
2921 -- It aids in detecting illegal usage of a state and a corresponding
2922 -- constituent in pragma Initializes.
2924 Items_Seen : Elist_Id := No_Elist;
2925 -- A list of all initialization items processed so far. This list is
2926 -- used to detect duplicate items.
2928 States_And_Objs : Elist_Id := No_Elist;
2929 -- A list of all abstract states and objects declared in the visible
2930 -- declarations of the related package. This list is used to detect the
2931 -- legality of initialization items.
2933 States_Seen : Elist_Id := No_Elist;
2934 -- A list containing the entities of all states processed so far. It
2935 -- helps in detecting illegal usage of a state and a corresponding
2936 -- constituent in pragma Initializes.
2938 procedure Analyze_Initialization_Item (Item : Node_Id);
2939 -- Verify the legality of a single initialization item
2941 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2942 -- Verify the legality of a single initialization item followed by a
2943 -- list of input items.
2945 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
2946 -- Inspect the visible declarations of the related package and gather
2947 -- the entities of all abstract states and objects in States_And_Objs.
2949 ---------------------------------
2950 -- Analyze_Initialization_Item --
2951 ---------------------------------
2953 procedure Analyze_Initialization_Item (Item : Node_Id) is
2954 Item_Id : Entity_Id;
2958 Resolve_State (Item);
2960 if Is_Entity_Name (Item) then
2961 Item_Id := Entity_Of (Item);
2963 if Present (Item_Id)
2964 and then Ekind (Item_Id) in
2965 E_Abstract_State | E_Constant | E_Variable
2967 -- When the initialization item is undefined, it appears as
2968 -- Any_Id. Do not continue with the analysis of the item.
2970 if Item_Id = Any_Id then
2973 -- The state or variable must be declared in the visible
2974 -- declarations of the package (SPARK RM 7.1.5(7)).
2976 elsif not Contains (States_And_Objs, Item_Id) then
2977 Error_Msg_Name_1 := Chars (Pack_Id);
2979 ("initialization item & must appear in the visible "
2980 & "declarations of package %", Item, Item_Id);
2982 -- Detect a duplicate use of the same initialization item
2983 -- (SPARK RM 7.1.5(5)).
2985 elsif Contains (Items_Seen, Item_Id) then
2986 SPARK_Msg_N ("duplicate initialization item", Item);
2988 -- The item is legal, add it to the list of processed states
2992 Append_New_Elmt (Item_Id, Items_Seen);
2994 if Ekind (Item_Id) = E_Abstract_State then
2995 Append_New_Elmt (Item_Id, States_Seen);
2998 if Present (Encapsulating_State (Item_Id)) then
2999 Append_New_Elmt (Item_Id, Constits_Seen);
3003 -- The item references something that is not a state or object
3004 -- (SPARK RM 7.1.5(3)).
3008 ("initialization item must denote object or state", Item);
3011 -- Some form of illegal construct masquerading as a name
3012 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3016 ("initialization item must denote object or state", Item);
3018 end Analyze_Initialization_Item;
3020 ---------------------------------------------
3021 -- Analyze_Initialization_Item_With_Inputs --
3022 ---------------------------------------------
3024 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
3025 Inputs_Seen : Elist_Id := No_Elist;
3026 -- A list of all inputs processed so far. This list is used to detect
3027 -- duplicate uses of an input.
3029 Non_Null_Seen : Boolean := False;
3030 Null_Seen : Boolean := False;
3031 -- Flags used to check the legality of an input list
3033 procedure Analyze_Input_Item (Input : Node_Id);
3034 -- Verify the legality of a single input item
3036 ------------------------
3037 -- Analyze_Input_Item --
3038 ------------------------
3040 procedure Analyze_Input_Item (Input : Node_Id) is
3041 Input_Id : Entity_Id;
3046 if Nkind (Input) = N_Null then
3049 ("multiple null initializations not allowed", Item);
3051 elsif Non_Null_Seen then
3053 ("cannot mix null and non-null initialization item", Item);
3061 Non_Null_Seen := True;
3065 ("cannot mix null and non-null initialization item", Item);
3069 Resolve_State (Input);
3071 if Is_Entity_Name (Input) then
3072 Input_Id := Entity_Of (Input);
3074 if Present (Input_Id)
3075 and then Ekind (Input_Id) in E_Abstract_State
3077 | E_Generic_In_Out_Parameter
3078 | E_Generic_In_Parameter
3080 | E_In_Out_Parameter
3086 -- The input cannot denote states or objects declared
3087 -- within the related package (SPARK RM 7.1.5(4)).
3089 if Within_Scope (Input_Id, Current_Scope) then
3091 -- Do not consider generic formal parameters or their
3092 -- respective mappings to generic formals. Even though
3093 -- the formals appear within the scope of the package,
3094 -- it is allowed for an initialization item to depend
3095 -- on an input item.
3097 if Ekind (Input_Id) in E_Generic_In_Out_Parameter
3098 | E_Generic_In_Parameter
3102 elsif Ekind (Input_Id) in E_Constant | E_Variable
3103 and then Present (Corresponding_Generic_Association
3104 (Declaration_Node (Input_Id)))
3109 Error_Msg_Name_1 := Chars (Pack_Id);
3111 ("input item & cannot denote a visible object or "
3112 & "state of package %", Input, Input_Id);
3117 -- Detect a duplicate use of the same input item
3118 -- (SPARK RM 7.1.5(5)).
3120 if Contains (Inputs_Seen, Input_Id) then
3121 SPARK_Msg_N ("duplicate input item", Input);
3125 -- At this point it is known that the input is legal. Add
3126 -- it to the list of processed inputs.
3128 Append_New_Elmt (Input_Id, Inputs_Seen);
3130 if Ekind (Input_Id) = E_Abstract_State then
3131 Append_New_Elmt (Input_Id, States_Seen);
3134 if Ekind (Input_Id) in E_Abstract_State
3137 and then Present (Encapsulating_State (Input_Id))
3139 Append_New_Elmt (Input_Id, Constits_Seen);
3142 -- The input references something that is not a state or an
3143 -- object (SPARK RM 7.1.5(3)).
3147 ("input item must denote object or state", Input);
3150 -- Some form of illegal construct masquerading as a name
3151 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3155 ("input item must denote object or state", Input);
3158 end Analyze_Input_Item;
3162 Inputs : constant Node_Id := Expression (Item);
3166 Name_Seen : Boolean := False;
3167 -- A flag used to detect multiple item names
3169 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3172 -- Inspect the name of an item with inputs
3174 Elmt := First (Choices (Item));
3175 while Present (Elmt) loop
3177 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3180 Analyze_Initialization_Item (Elmt);
3186 -- Multiple input items appear as an aggregate
3188 if Nkind (Inputs) = N_Aggregate then
3189 if Present (Expressions (Inputs)) then
3190 Input := First (Expressions (Inputs));
3191 while Present (Input) loop
3192 Analyze_Input_Item (Input);
3197 if Present (Component_Associations (Inputs)) then
3199 ("inputs must appear in named association form", Inputs);
3202 -- Single input item
3205 Analyze_Input_Item (Inputs);
3207 end Analyze_Initialization_Item_With_Inputs;
3209 --------------------------------
3210 -- Collect_States_And_Objects --
3211 --------------------------------
3213 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3214 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3215 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3217 State_Elmt : Elmt_Id;
3220 -- Collect the abstract states defined in the package (if any)
3222 if Has_Non_Null_Abstract_State (Pack_Id) then
3223 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3224 while Present (State_Elmt) loop
3225 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3226 Next_Elmt (State_Elmt);
3230 -- Collect all objects that appear in the visible declarations of the
3233 if Present (Visible_Declarations (Pack_Spec)) then
3234 Decl := First (Visible_Declarations (Pack_Spec));
3235 while Present (Decl) loop
3236 if Comes_From_Source (Decl)
3237 and then Nkind (Decl) in N_Object_Declaration
3238 | N_Object_Renaming_Declaration
3240 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3242 elsif Nkind (Decl) = N_Package_Declaration then
3243 Collect_States_And_Objects (Decl);
3245 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3247 (Anonymous_Object (Defining_Entity (Decl)),
3254 end Collect_States_And_Objects;
3258 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3261 -- Start of processing for Analyze_Initializes_In_Decl_Part
3264 -- Do not analyze the pragma multiple times
3266 if Is_Analyzed_Pragma (N) then
3270 -- Nothing to do when the initialization list is empty
3272 if Nkind (Inits) = N_Null then
3276 -- Single and multiple initialization clauses appear as an aggregate. If
3277 -- this is not the case, then either the parser or the analysis of the
3278 -- pragma failed to produce an aggregate.
3280 pragma Assert (Nkind (Inits) = N_Aggregate);
3282 -- Initialize the various lists used during analysis
3284 Collect_States_And_Objects (Pack_Decl);
3286 if Present (Expressions (Inits)) then
3287 Init := First (Expressions (Inits));
3288 while Present (Init) loop
3289 Analyze_Initialization_Item (Init);
3294 if Present (Component_Associations (Inits)) then
3295 Init := First (Component_Associations (Inits));
3296 while Present (Init) loop
3297 Analyze_Initialization_Item_With_Inputs (Init);
3302 -- Ensure that a state and a corresponding constituent do not appear
3303 -- together in pragma Initializes.
3305 Check_State_And_Constituent_Use
3306 (States => States_Seen,
3307 Constits => Constits_Seen,
3310 Set_Is_Analyzed_Pragma (N);
3311 end Analyze_Initializes_In_Decl_Part;
3313 ---------------------
3314 -- Analyze_Part_Of --
3315 ---------------------
3317 procedure Analyze_Part_Of
3319 Item_Id : Entity_Id;
3321 Encap_Id : out Entity_Id;
3322 Legal : out Boolean)
3324 procedure Check_Part_Of_Abstract_State;
3325 pragma Inline (Check_Part_Of_Abstract_State);
3326 -- Verify the legality of indicator Part_Of when the encapsulator is an
3329 procedure Check_Part_Of_Concurrent_Type;
3330 pragma Inline (Check_Part_Of_Concurrent_Type);
3331 -- Verify the legality of indicator Part_Of when the encapsulator is a
3332 -- single concurrent type.
3334 ----------------------------------
3335 -- Check_Part_Of_Abstract_State --
3336 ----------------------------------
3338 procedure Check_Part_Of_Abstract_State is
3339 Pack_Id : Entity_Id;
3340 Placement : State_Space_Kind;
3341 Parent_Unit : Entity_Id;
3344 -- Determine where the object, package instantiation or state lives
3345 -- with respect to the enclosing packages or package bodies.
3347 Find_Placement_In_State_Space
3348 (Item_Id => Item_Id,
3349 Placement => Placement,
3350 Pack_Id => Pack_Id);
3352 -- The item appears in a non-package construct with a declarative
3353 -- part (subprogram, block, etc). As such, the item is not allowed
3354 -- to be a part of an encapsulating state because the item is not
3357 if Placement = Not_In_Package then
3359 ("indicator Part_Of cannot appear in this context "
3360 & "(SPARK RM 7.2.6(5))", Indic);
3362 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3364 ("\& is not part of the hidden state of package %",
3368 -- The item appears in the visible state space of some package. In
3369 -- general this scenario does not warrant Part_Of except when the
3370 -- package is a nongeneric private child unit and the encapsulating
3371 -- state is declared in a parent unit or a public descendant of that
3374 elsif Placement = Visible_State_Space then
3375 if Is_Child_Unit (Pack_Id)
3376 and then not Is_Generic_Unit (Pack_Id)
3377 and then Is_Private_Descendant (Pack_Id)
3379 -- A variable or state abstraction which is part of the visible
3380 -- state of a nongeneric private child unit or its public
3381 -- descendants must have its Part_Of indicator specified. The
3382 -- Part_Of indicator must denote a state declared by either the
3383 -- parent unit of the private unit or by a public descendant of
3384 -- that parent unit.
3386 -- Find the nearest private ancestor (which can be the current
3389 Parent_Unit := Pack_Id;
3390 while Present (Parent_Unit) loop
3393 (Parent (Unit_Declaration_Node (Parent_Unit)));
3394 Parent_Unit := Scope (Parent_Unit);
3397 Parent_Unit := Scope (Parent_Unit);
3399 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3401 ("indicator Part_Of must denote abstract state of & or of "
3402 & "its public descendant (SPARK RM 7.2.6(3))",
3403 Indic, Parent_Unit);
3406 elsif Scope (Encap_Id) = Parent_Unit
3408 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3409 and then not Is_Private_Descendant (Scope (Encap_Id)))
3415 ("indicator Part_Of must denote abstract state of & or of "
3416 & "its public descendant (SPARK RM 7.2.6(3))",
3417 Indic, Parent_Unit);
3421 -- Indicator Part_Of is not needed when the related package is
3422 -- not a nongeneric private child unit or a public descendant
3427 ("indicator Part_Of cannot appear in this context "
3428 & "(SPARK RM 7.2.6(5))", Indic);
3430 Error_Msg_Name_1 := Chars (Pack_Id);
3432 ("\& is declared in the visible part of package %",
3437 -- When the item appears in the private state space of a package, the
3438 -- encapsulating state must be declared in the same package.
3440 elsif Placement = Private_State_Space then
3441 if Scope (Encap_Id) /= Pack_Id then
3443 ("indicator Part_Of must denote an abstract state of "
3444 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3446 Error_Msg_Name_1 := Chars (Pack_Id);
3448 ("\& is declared in the private part of package %",
3453 -- Items declared in the body state space of a package do not need
3454 -- Part_Of indicators as the refinement has already been seen.
3458 ("indicator Part_Of cannot appear in this context "
3459 & "(SPARK RM 7.2.6(5))", Indic);
3461 if Scope (Encap_Id) = Pack_Id then
3462 Error_Msg_Name_1 := Chars (Pack_Id);
3464 ("\& is declared in the body of package %", Indic, Item_Id);
3470 -- At this point it is known that the Part_Of indicator is legal
3473 end Check_Part_Of_Abstract_State;
3475 -----------------------------------
3476 -- Check_Part_Of_Concurrent_Type --
3477 -----------------------------------
3479 procedure Check_Part_Of_Concurrent_Type is
3480 function In_Proper_Order
3482 Second : Node_Id) return Boolean;
3483 pragma Inline (In_Proper_Order);
3484 -- Determine whether node First precedes node Second
3486 procedure Placement_Error;
3487 pragma Inline (Placement_Error);
3488 -- Emit an error concerning the illegal placement of the item with
3489 -- respect to the single concurrent type.
3491 ---------------------
3492 -- In_Proper_Order --
3493 ---------------------
3495 function In_Proper_Order
3497 Second : Node_Id) return Boolean
3502 if List_Containing (First) = List_Containing (Second) then
3504 while Present (N) loop
3514 end In_Proper_Order;
3516 ---------------------
3517 -- Placement_Error --
3518 ---------------------
3520 procedure Placement_Error is
3523 ("indicator Part_Of must denote a previously declared single "
3524 & "protected type or single task type", Encap);
3525 end Placement_Error;
3529 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3530 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3531 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3533 Item_Context : Node_Id;
3534 Item_Decl : Node_Id;
3535 Prv_Decls : List_Id;
3536 Vis_Decls : List_Id;
3538 -- Start of processing for Check_Part_Of_Concurrent_Type
3541 -- Only abstract states and variables can act as constituents of an
3542 -- encapsulating single concurrent type.
3544 if Ekind (Item_Id) in E_Abstract_State | E_Variable then
3547 -- The constituent is a constant
3549 elsif Ekind (Item_Id) = E_Constant then
3550 Error_Msg_Name_1 := Chars (Encap_Id);
3552 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3553 & "single protected type %"), Indic, Item_Id);
3556 -- The constituent is a package instantiation
3559 Error_Msg_Name_1 := Chars (Encap_Id);
3561 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3562 & "constituent of single protected type %"), Indic, Item_Id);
3566 -- When the item denotes an abstract state of a nested package, use
3567 -- the declaration of the package to detect proper placement.
3572 -- with Abstract_State => (State with Part_Of => T)
3574 if Ekind (Item_Id) = E_Abstract_State then
3575 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3577 Item_Decl := Declaration_Node (Item_Id);
3580 Item_Context := Parent (Item_Decl);
3582 -- The item and the single concurrent type must appear in the same
3583 -- declarative region, with the item following the declaration of
3584 -- the single concurrent type (SPARK RM 9(3)).
3586 if Item_Context = Encap_Context then
3587 if Nkind (Item_Context) in N_Package_Specification
3588 | N_Protected_Definition
3591 Prv_Decls := Private_Declarations (Item_Context);
3592 Vis_Decls := Visible_Declarations (Item_Context);
3594 -- The placement is OK when the single concurrent type appears
3595 -- within the visible declarations and the item in the private
3601 -- Constit : ... with Part_Of => PO;
3604 if List_Containing (Encap_Decl) = Vis_Decls
3605 and then List_Containing (Item_Decl) = Prv_Decls
3609 -- The placement is illegal when the item appears within the
3610 -- visible declarations and the single concurrent type is in
3611 -- the private declarations.
3614 -- Constit : ... with Part_Of => PO;
3619 elsif List_Containing (Item_Decl) = Vis_Decls
3620 and then List_Containing (Encap_Decl) = Prv_Decls
3625 -- Otherwise both the item and the single concurrent type are
3626 -- in the same list. Ensure that the declaration of the single
3627 -- concurrent type precedes that of the item.
3629 elsif not In_Proper_Order
3630 (First => Encap_Decl,
3631 Second => Item_Decl)
3637 -- Otherwise both the item and the single concurrent type are
3638 -- in the same list. Ensure that the declaration of the single
3639 -- concurrent type precedes that of the item.
3641 elsif not In_Proper_Order
3642 (First => Encap_Decl,
3643 Second => Item_Decl)
3649 -- Otherwise the item and the single concurrent type reside within
3650 -- unrelated regions.
3653 Error_Msg_Name_1 := Chars (Encap_Id);
3655 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3656 & "immediately within the same region as single protected "
3657 & "type %"), Indic, Item_Id);
3661 -- At this point it is known that the Part_Of indicator is legal
3664 end Check_Part_Of_Concurrent_Type;
3666 -- Start of processing for Analyze_Part_Of
3669 -- Assume that the indicator is illegal
3675 N_Expanded_Name | N_Identifier | N_Selected_Component
3678 Resolve_State (Encap);
3680 Encap_Id := Entity (Encap);
3682 -- The encapsulator is an abstract state
3684 if Ekind (Encap_Id) = E_Abstract_State then
3687 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3689 elsif Is_Single_Concurrent_Object (Encap_Id) then
3692 -- Otherwise the encapsulator is not a legal choice
3696 ("indicator Part_Of must denote abstract state, single "
3697 & "protected type or single task type", Encap);
3701 -- This is a syntax error, always report
3705 ("indicator Part_Of must denote abstract state, single protected "
3706 & "type or single task type", Encap);
3710 -- Catch a case where indicator Part_Of denotes the abstract view of a
3711 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3713 if From_Limited_With (Encap_Id)
3714 and then Present (Non_Limited_View (Encap_Id))
3715 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3717 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3718 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3722 -- The encapsulator is an abstract state
3724 if Ekind (Encap_Id) = E_Abstract_State then
3725 Check_Part_Of_Abstract_State;
3727 -- The encapsulator is a single concurrent type
3730 Check_Part_Of_Concurrent_Type;
3732 end Analyze_Part_Of;
3734 ----------------------------------
3735 -- Analyze_Part_Of_In_Decl_Part --
3736 ----------------------------------
3738 procedure Analyze_Part_Of_In_Decl_Part
3740 Freeze_Id : Entity_Id := Empty)
3742 Encap : constant Node_Id :=
3743 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3744 Errors : constant Nat := Serious_Errors_Detected;
3745 Var_Decl : constant Node_Id := Find_Related_Context (N);
3746 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3747 Constits : Elist_Id;
3748 Encap_Id : Entity_Id;
3752 -- Detect any discrepancies between the placement of the variable with
3753 -- respect to general state space and the encapsulating state or single
3760 Encap_Id => Encap_Id,
3763 -- The Part_Of indicator turns the variable into a constituent of the
3764 -- encapsulating state or single concurrent type.
3767 pragma Assert (Present (Encap_Id));
3768 Constits := Part_Of_Constituents (Encap_Id);
3770 if No (Constits) then
3771 Constits := New_Elmt_List;
3772 Set_Part_Of_Constituents (Encap_Id, Constits);
3775 Append_Elmt (Var_Id, Constits);
3776 Set_Encapsulating_State (Var_Id, Encap_Id);
3778 -- A Part_Of constituent partially refines an abstract state. This
3779 -- property does not apply to protected or task units.
3781 if Ekind (Encap_Id) = E_Abstract_State then
3782 Set_Has_Partial_Visible_Refinement (Encap_Id);
3786 -- Emit a clarification message when the encapsulator is undefined,
3787 -- possibly due to contract freezing.
3789 if Errors /= Serious_Errors_Detected
3790 and then Present (Freeze_Id)
3791 and then Has_Undefined_Reference (Encap)
3793 Contract_Freeze_Error (Var_Id, Freeze_Id);
3795 end Analyze_Part_Of_In_Decl_Part;
3797 --------------------
3798 -- Analyze_Pragma --
3799 --------------------
3801 procedure Analyze_Pragma (N : Node_Id) is
3802 Loc : constant Source_Ptr := Sloc (N);
3804 Pname : Name_Id := Pragma_Name (N);
3805 -- Name of the source pragma, or name of the corresponding aspect for
3806 -- pragmas which originate in a source aspect. In the latter case, the
3807 -- name may be different from the pragma name.
3809 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3811 Pragma_Exit : exception;
3812 -- This exception is used to exit pragma processing completely. It
3813 -- is used when an error is detected, and no further processing is
3814 -- required. It is also used if an earlier error has left the tree in
3815 -- a state where the pragma should not be processed.
3818 -- Number of pragma argument associations
3825 -- First five pragma arguments (pragma argument association nodes, or
3826 -- Empty if the corresponding argument does not exist).
3828 type Name_List is array (Natural range <>) of Name_Id;
3829 type Args_List is array (Natural range <>) of Node_Id;
3830 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3832 -----------------------
3833 -- Local Subprograms --
3834 -----------------------
3836 procedure Ada_2005_Pragma;
3837 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3838 -- Ada 95 mode, these are implementation defined pragmas, so should be
3839 -- caught by the No_Implementation_Pragmas restriction.
3841 procedure Ada_2012_Pragma;
3842 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3843 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3844 -- should be caught by the No_Implementation_Pragmas restriction.
3846 procedure Analyze_Depends_Global
3847 (Spec_Id : out Entity_Id;
3848 Subp_Decl : out Node_Id;
3849 Legal : out Boolean);
3850 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3851 -- legality of the placement and related context of the pragma. Spec_Id
3852 -- is the entity of the related subprogram. Subp_Decl is the declaration
3853 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3855 procedure Analyze_If_Present (Id : Pragma_Id);
3856 -- Inspect the remainder of the list containing pragma N and look for
3857 -- a pragma that matches Id. If found, analyze the pragma.
3859 procedure Analyze_Pre_Post_Condition;
3860 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3862 procedure Analyze_Refined_Depends_Global_Post
3863 (Spec_Id : out Entity_Id;
3864 Body_Id : out Entity_Id;
3865 Legal : out Boolean);
3866 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3867 -- Refined_Global and Refined_Post. Verify the legality of the placement
3868 -- and related context of the pragma. Spec_Id is the entity of the
3869 -- related subprogram. Body_Id is the entity of the subprogram body.
3870 -- Flag Legal is set when the pragma is legal.
3872 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3873 -- Perform full analysis of pragma Unmodified and the write aspect of
3874 -- pragma Unused. Flag Is_Unused should be set when verifying the
3875 -- semantics of pragma Unused.
3877 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3878 -- Perform full analysis of pragma Unreferenced and the read aspect of
3879 -- pragma Unused. Flag Is_Unused should be set when verifying the
3880 -- semantics of pragma Unused.
3882 procedure Check_Ada_83_Warning;
3883 -- Issues a warning message for the current pragma if operating in Ada
3884 -- 83 mode (used for language pragmas that are not a standard part of
3885 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3888 procedure Check_Arg_Count (Required : Nat);
3889 -- Check argument count for pragma is equal to given parameter. If not,
3890 -- then issue an error message and raise Pragma_Exit.
3892 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3893 -- Arg which can either be a pragma argument association, in which case
3894 -- the check is applied to the expression of the association or an
3895 -- expression directly.
3897 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3898 -- Check that an argument has the right form for an EXTERNAL_NAME
3899 -- parameter of an extended import/export pragma. The rule is that the
3900 -- name must be an identifier or string literal (in Ada 83 mode) or a
3901 -- static string expression (in Ada 95 mode).
3903 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3904 -- Check the specified argument Arg to make sure that it is an
3905 -- identifier. If not give error and raise Pragma_Exit.
3907 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3908 -- Check the specified argument Arg to make sure that it is an integer
3909 -- literal. If not give error and raise Pragma_Exit.
3911 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3912 -- Check the specified argument Arg to make sure that it has the proper
3913 -- syntactic form for a local name and meets the semantic requirements
3914 -- for a local name. The local name is analyzed as part of the
3915 -- processing for this call. In addition, the local name is required
3916 -- to represent an entity at the library level.
3918 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3919 -- Check the specified argument Arg to make sure that it has the proper
3920 -- syntactic form for a local name and meets the semantic requirements
3921 -- for a local name. The local name is analyzed as part of the
3922 -- processing for this call.
3924 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3925 -- Check the specified argument Arg to make sure that it is a valid
3926 -- locking policy name. If not give error and raise Pragma_Exit.
3928 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3929 -- Check the specified argument Arg to make sure that it is a valid
3930 -- elaboration policy name. If not give error and raise Pragma_Exit.
3932 procedure Check_Arg_Is_One_Of
3935 procedure Check_Arg_Is_One_Of
3937 N1, N2, N3 : Name_Id);
3938 procedure Check_Arg_Is_One_Of
3940 N1, N2, N3, N4 : Name_Id);
3941 procedure Check_Arg_Is_One_Of
3943 N1, N2, N3, N4, N5 : Name_Id);
3944 -- Check the specified argument Arg to make sure that it is an
3945 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3946 -- present). If not then give error and raise Pragma_Exit.
3948 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3949 -- Check the specified argument Arg to make sure that it is a valid
3950 -- queuing policy name. If not give error and raise Pragma_Exit.
3952 procedure Check_Arg_Is_OK_Static_Expression
3954 Typ : Entity_Id := Empty);
3955 -- Check the specified argument Arg to make sure that it is a static
3956 -- expression of the given type (i.e. it will be analyzed and resolved
3957 -- using this type, which can be any valid argument to Resolve, e.g.
3958 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3959 -- Typ is left Empty, then any static expression is allowed. Includes
3960 -- checking that the argument does not raise Constraint_Error.
3962 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3963 -- Check the specified argument Arg to make sure that it is a valid task
3964 -- dispatching policy name. If not give error and raise Pragma_Exit.
3966 procedure Check_Arg_Order (Names : Name_List);
3967 -- Checks for an instance of two arguments with identifiers for the
3968 -- current pragma which are not in the sequence indicated by Names,
3969 -- and if so, generates a fatal message about bad order of arguments.
3971 procedure Check_At_Least_N_Arguments (N : Nat);
3972 -- Check there are at least N arguments present
3974 procedure Check_At_Most_N_Arguments (N : Nat);
3975 -- Check there are no more than N arguments present
3977 procedure Check_Component
3980 In_Variant_Part : Boolean := False);
3981 -- Examine an Unchecked_Union component for correct use of per-object
3982 -- constrained subtypes, and for restrictions on finalizable components.
3983 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3984 -- should be set when Comp comes from a record variant.
3986 procedure Check_Duplicate_Pragma (E : Entity_Id);
3987 -- Check if a rep item of the same name as the current pragma is already
3988 -- chained as a rep pragma to the given entity. If so give a message
3989 -- about the duplicate, and then raise Pragma_Exit so does not return.
3990 -- Note that if E is a type, then this routine avoids flagging a pragma
3991 -- which applies to a parent type from which E is derived.
3993 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3994 -- Nam is an N_String_Literal node containing the external name set by
3995 -- an Import or Export pragma (or extended Import or Export pragma).
3996 -- This procedure checks for possible duplications if this is the export
3997 -- case, and if found, issues an appropriate error message.
3999 procedure Check_Expr_Is_OK_Static_Expression
4001 Typ : Entity_Id := Empty);
4002 -- Check the specified expression Expr to make sure that it is a static
4003 -- expression of the given type (i.e. it will be analyzed and resolved
4004 -- using this type, which can be any valid argument to Resolve, e.g.
4005 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4006 -- Typ is left Empty, then any static expression is allowed. Includes
4007 -- checking that the expression does not raise Constraint_Error.
4009 procedure Check_First_Subtype (Arg : Node_Id);
4010 -- Checks that Arg, whose expression is an entity name, references a
4013 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
4014 -- Checks that the given argument has an identifier, and if so, requires
4015 -- it to match the given identifier name. If there is no identifier, or
4016 -- a non-matching identifier, then an error message is given and
4017 -- Pragma_Exit is raised.
4019 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
4020 -- Checks that the given argument has an identifier, and if so, requires
4021 -- it to match one of the given identifier names. If there is no
4022 -- identifier, or a non-matching identifier, then an error message is
4023 -- given and Pragma_Exit is raised.
4025 procedure Check_In_Main_Program;
4026 -- Common checks for pragmas that appear within a main program
4027 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4029 procedure Check_Interrupt_Or_Attach_Handler;
4030 -- Common processing for first argument of pragma Interrupt_Handler or
4031 -- pragma Attach_Handler.
4033 procedure Check_Loop_Pragma_Placement;
4034 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4035 -- appear immediately within a construct restricted to loops, and that
4036 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4038 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
4039 -- Check that pragma appears in a declarative part, or in a package
4040 -- specification, i.e. that it does not occur in a statement sequence
4043 procedure Check_No_Identifier (Arg : Node_Id);
4044 -- Checks that the given argument does not have an identifier. If
4045 -- an identifier is present, then an error message is issued, and
4046 -- Pragma_Exit is raised.
4048 procedure Check_No_Identifiers;
4049 -- Checks that none of the arguments to the pragma has an identifier.
4050 -- If any argument has an identifier, then an error message is issued,
4051 -- and Pragma_Exit is raised.
4053 procedure Check_No_Link_Name;
4054 -- Checks that no link name is specified
4056 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4057 -- Checks if the given argument has an identifier, and if so, requires
4058 -- it to match the given identifier name. If there is a non-matching
4059 -- identifier, then an error message is given and Pragma_Exit is raised.
4061 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4062 -- Checks if the given argument has an identifier, and if so, requires
4063 -- it to match the given identifier name. If there is a non-matching
4064 -- identifier, then an error message is given and Pragma_Exit is raised.
4065 -- In this version of the procedure, the identifier name is given as
4066 -- a string with lower case letters.
4068 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4069 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4070 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4071 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4072 -- is an OK static boolean expression. Emit an error if this is not the
4075 procedure Check_Static_Constraint (Constr : Node_Id);
4076 -- Constr is a constraint from an N_Subtype_Indication node from a
4077 -- component constraint in an Unchecked_Union type. This routine checks
4078 -- that the constraint is static as required by the restrictions for
4081 procedure Check_Valid_Configuration_Pragma;
4082 -- Legality checks for placement of a configuration pragma
4084 procedure Check_Valid_Library_Unit_Pragma;
4085 -- Legality checks for library unit pragmas. A special case arises for
4086 -- pragmas in generic instances that come from copies of the original
4087 -- library unit pragmas in the generic templates. In the case of other
4088 -- than library level instantiations these can appear in contexts which
4089 -- would normally be invalid (they only apply to the original template
4090 -- and to library level instantiations), and they are simply ignored,
4091 -- which is implemented by rewriting them as null statements and raising
4092 -- exception to terminate analysis.
4094 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4095 -- Check an Unchecked_Union variant for lack of nested variants and
4096 -- presence of at least one component. UU_Typ is the related Unchecked_
4099 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4100 -- Subsidiary routine to the processing of pragmas Abstract_State,
4101 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4102 -- Refined_Global, Refined_State and Subprogram_Variant. Transform
4103 -- argument Arg into an aggregate if not one already. N_Null is never
4104 -- transformed. Arg may denote an aspect specification or a pragma
4105 -- argument association.
4107 procedure Error_Pragma (Msg : String);
4108 pragma No_Return (Error_Pragma);
4109 -- Outputs error message for current pragma. The message contains a %
4110 -- that will be replaced with the pragma name, and the flag is placed
4111 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4112 -- calls Fix_Error (see spec of that procedure for details).
4114 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4115 pragma No_Return (Error_Pragma_Arg);
4116 -- Outputs error message for current pragma. The message may contain
4117 -- a % that will be replaced with the pragma name. The parameter Arg
4118 -- may either be a pragma argument association, in which case the flag
4119 -- is placed on the expression of this association, or an expression,
4120 -- in which case the flag is placed directly on the expression. The
4121 -- message is placed using Error_Msg_N, so the message may also contain
4122 -- an & insertion character which will reference the given Arg value.
4123 -- After placing the message, Pragma_Exit is raised. Note: this routine
4124 -- calls Fix_Error (see spec of that procedure for details).
4126 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4127 pragma No_Return (Error_Pragma_Arg);
4128 -- Similar to above form of Error_Pragma_Arg except that two messages
4129 -- are provided, the second is a continuation comment starting with \.
4131 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4132 pragma No_Return (Error_Pragma_Arg_Ident);
4133 -- Outputs error message for current pragma. The message may contain a %
4134 -- that will be replaced with the pragma name. The parameter Arg must be
4135 -- a pragma argument association with a non-empty identifier (i.e. its
4136 -- Chars field must be set), and the error message is placed on the
4137 -- identifier. The message is placed using Error_Msg_N so the message
4138 -- may also contain an & insertion character which will reference
4139 -- the identifier. After placing the message, Pragma_Exit is raised.
4140 -- Note: this routine calls Fix_Error (see spec of that procedure for
4143 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4144 pragma No_Return (Error_Pragma_Ref);
4145 -- Outputs error message for current pragma. The message may contain
4146 -- a % that will be replaced with the pragma name. The parameter Ref
4147 -- must be an entity whose name can be referenced by & and sloc by #.
4148 -- After placing the message, Pragma_Exit is raised. Note: this routine
4149 -- calls Fix_Error (see spec of that procedure for details).
4151 function Find_Lib_Unit_Name return Entity_Id;
4152 -- Used for a library unit pragma to find the entity to which the
4153 -- library unit pragma applies, returns the entity found.
4155 procedure Find_Program_Unit_Name (Id : Node_Id);
4156 -- If the pragma is a compilation unit pragma, the id must denote the
4157 -- compilation unit in the same compilation, and the pragma must appear
4158 -- in the list of preceding or trailing pragmas. If it is a program
4159 -- unit pragma that is not a compilation unit pragma, then the
4160 -- identifier must be visible.
4162 function Find_Unique_Parameterless_Procedure
4164 Arg : Node_Id) return Entity_Id;
4165 -- Used for a procedure pragma to find the unique parameterless
4166 -- procedure identified by Name, returns it if it exists, otherwise
4167 -- errors out and uses Arg as the pragma argument for the message.
4169 function Fix_Error (Msg : String) return String;
4170 -- This is called prior to issuing an error message. Msg is the normal
4171 -- error message issued in the pragma case. This routine checks for the
4172 -- case of a pragma coming from an aspect in the source, and returns a
4173 -- message suitable for the aspect case as follows:
4175 -- Each substring "pragma" is replaced by "aspect"
4177 -- If "argument of" is at the start of the error message text, it is
4178 -- replaced by "entity for".
4180 -- If "argument" is at the start of the error message text, it is
4181 -- replaced by "entity".
4183 -- So for example, "argument of pragma X must be discrete type"
4184 -- returns "entity for aspect X must be a discrete type".
4186 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4187 -- be different from the pragma name). If the current pragma results
4188 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4189 -- original pragma name.
4191 procedure Gather_Associations
4193 Args : out Args_List);
4194 -- This procedure is used to gather the arguments for a pragma that
4195 -- permits arbitrary ordering of parameters using the normal rules
4196 -- for named and positional parameters. The Names argument is a list
4197 -- of Name_Id values that corresponds to the allowed pragma argument
4198 -- association identifiers in order. The result returned in Args is
4199 -- a list of corresponding expressions that are the pragma arguments.
4200 -- Note that this is a list of expressions, not of pragma argument
4201 -- associations (Gather_Associations has completely checked all the
4202 -- optional identifiers when it returns). An entry in Args is Empty
4203 -- on return if the corresponding argument is not present.
4205 procedure GNAT_Pragma;
4206 -- Called for all GNAT defined pragmas to check the relevant restriction
4207 -- (No_Implementation_Pragmas).
4209 function Is_Before_First_Decl
4210 (Pragma_Node : Node_Id;
4211 Decls : List_Id) return Boolean;
4212 -- Return True if Pragma_Node is before the first declarative item in
4213 -- Decls where Decls is the list of declarative items.
4215 function Is_Configuration_Pragma return Boolean;
4216 -- Determines if the placement of the current pragma is appropriate
4217 -- for a configuration pragma.
4219 function Is_In_Context_Clause return Boolean;
4220 -- Returns True if pragma appears within the context clause of a unit,
4221 -- and False for any other placement (does not generate any messages).
4223 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4224 -- Analyzes the argument, and determines if it is a static string
4225 -- expression, returns True if so, False if non-static or not String.
4226 -- A special case is that a string literal returns True in Ada 83 mode
4227 -- (which has no such thing as static string expressions). Note that
4228 -- the call analyzes its argument, so this cannot be used for the case
4229 -- where an identifier might not be declared.
4231 procedure Pragma_Misplaced;
4232 pragma No_Return (Pragma_Misplaced);
4233 -- Issue fatal error message for misplaced pragma
4235 procedure Process_Atomic_Independent_Shared_Volatile;
4236 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4237 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4238 -- and treated as being identical in effect to pragma Atomic.
4240 procedure Process_Compile_Time_Warning_Or_Error;
4241 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4243 procedure Process_Convention
4244 (C : out Convention_Id;
4245 Ent : out Entity_Id);
4246 -- Common processing for Convention, Interface, Import and Export.
4247 -- Checks first two arguments of pragma, and sets the appropriate
4248 -- convention value in the specified entity or entities. On return
4249 -- C is the convention, Ent is the referenced entity.
4251 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4252 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4253 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4255 procedure Process_Extended_Import_Export_Object_Pragma
4256 (Arg_Internal : Node_Id;
4257 Arg_External : Node_Id;
4258 Arg_Size : Node_Id);
4259 -- Common processing for the pragmas Import/Export_Object. The three
4260 -- arguments correspond to the three named parameters of the pragmas. An
4261 -- argument is empty if the corresponding parameter is not present in
4264 procedure Process_Extended_Import_Export_Internal_Arg
4265 (Arg_Internal : Node_Id := Empty);
4266 -- Common processing for all extended Import and Export pragmas. The
4267 -- argument is the pragma parameter for the Internal argument. If
4268 -- Arg_Internal is empty or inappropriate, an error message is posted.
4269 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4270 -- set to identify the referenced entity.
4272 procedure Process_Extended_Import_Export_Subprogram_Pragma
4273 (Arg_Internal : Node_Id;
4274 Arg_External : Node_Id;
4275 Arg_Parameter_Types : Node_Id;
4276 Arg_Result_Type : Node_Id := Empty;
4277 Arg_Mechanism : Node_Id;
4278 Arg_Result_Mechanism : Node_Id := Empty);
4279 -- Common processing for all extended Import and Export pragmas applying
4280 -- to subprograms. The caller omits any arguments that do not apply to
4281 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4282 -- only in the Import_Function and Export_Function cases). The argument
4283 -- names correspond to the allowed pragma association identifiers.
4285 procedure Process_Generic_List;
4286 -- Common processing for Share_Generic and Inline_Generic
4288 procedure Process_Import_Or_Interface;
4289 -- Common processing for Import or Interface
4291 procedure Process_Import_Predefined_Type;
4292 -- Processing for completing a type with pragma Import. This is used
4293 -- to declare types that match predefined C types, especially for cases
4294 -- without corresponding Ada predefined type.
4296 type Inline_Status is (Suppressed, Disabled, Enabled);
4297 -- Inline status of a subprogram, indicated as follows:
4298 -- Suppressed: inlining is suppressed for the subprogram
4299 -- Disabled: no inlining is requested for the subprogram
4300 -- Enabled: inlining is requested/required for the subprogram
4302 procedure Process_Inline (Status : Inline_Status);
4303 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4304 -- indicates the inline status specified by the pragma.
4306 procedure Process_Interface_Name
4307 (Subprogram_Def : Entity_Id;
4311 -- Given the last two arguments of pragma Import, pragma Export, or
4312 -- pragma Interface_Name, performs validity checks and sets the
4313 -- Interface_Name field of the given subprogram entity to the
4314 -- appropriate external or link name, depending on the arguments given.
4315 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4316 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4317 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4318 -- nor Link_Arg is present, the interface name is set to the default
4319 -- from the subprogram name. In addition, the pragma itself is passed
4320 -- to analyze any expressions in the case the pragma came from an aspect
4323 procedure Process_Interrupt_Or_Attach_Handler;
4324 -- Common processing for Interrupt and Attach_Handler pragmas
4326 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4327 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4328 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4329 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4330 -- is not set in the Restrictions case.
4332 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4333 -- Common processing for Suppress and Unsuppress. The boolean parameter
4334 -- Suppress_Case is True for the Suppress case, and False for the
4337 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4338 -- Subsidiary to the analysis of pragmas Independent[_Components].
4339 -- Record such a pragma N applied to entity E for future checks.
4341 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4342 -- This procedure sets the Is_Exported flag for the given entity,
4343 -- checking that the entity was not previously imported. Arg is
4344 -- the argument that specified the entity. A check is also made
4345 -- for exporting inappropriate entities.
4347 procedure Set_Extended_Import_Export_External_Name
4348 (Internal_Ent : Entity_Id;
4349 Arg_External : Node_Id);
4350 -- Common processing for all extended import export pragmas. The first
4351 -- argument, Internal_Ent, is the internal entity, which has already
4352 -- been checked for validity by the caller. Arg_External is from the
4353 -- Import or Export pragma, and may be null if no External parameter
4354 -- was present. If Arg_External is present and is a non-null string
4355 -- (a null string is treated as the default), then the Interface_Name
4356 -- field of Internal_Ent is set appropriately.
4358 procedure Set_Imported (E : Entity_Id);
4359 -- This procedure sets the Is_Imported flag for the given entity,
4360 -- checking that it is not previously exported or imported.
4362 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4363 -- Mech is a parameter passing mechanism (see Import_Function syntax
4364 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4365 -- has the right form, and if not issues an error message. If the
4366 -- argument has the right form then the Mechanism field of Ent is
4367 -- set appropriately.
4369 procedure Set_Rational_Profile;
4370 -- Activate the set of configuration pragmas and permissions that make
4371 -- up the Rational profile.
4373 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4374 -- Activate the set of configuration pragmas and restrictions that make
4375 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4376 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4377 -- pragma node, which is used for error messages on any constructs
4378 -- violating the profile.
4380 ---------------------
4381 -- Ada_2005_Pragma --
4382 ---------------------
4384 procedure Ada_2005_Pragma is
4386 if Ada_Version <= Ada_95 then
4387 Check_Restriction (No_Implementation_Pragmas, N);
4389 end Ada_2005_Pragma;
4391 ---------------------
4392 -- Ada_2012_Pragma --
4393 ---------------------
4395 procedure Ada_2012_Pragma is
4397 if Ada_Version <= Ada_2005 then
4398 Check_Restriction (No_Implementation_Pragmas, N);
4400 end Ada_2012_Pragma;
4402 ----------------------------
4403 -- Analyze_Depends_Global --
4404 ----------------------------
4406 procedure Analyze_Depends_Global
4407 (Spec_Id : out Entity_Id;
4408 Subp_Decl : out Node_Id;
4409 Legal : out Boolean)
4412 -- Assume that the pragma is illegal
4419 Check_Arg_Count (1);
4421 -- Ensure the proper placement of the pragma. Depends/Global must be
4422 -- associated with a subprogram declaration or a body that acts as a
4425 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4429 if Nkind (Subp_Decl) = N_Entry_Declaration then
4432 -- Generic subprogram
4434 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4437 -- Object declaration of a single concurrent type
4439 elsif Nkind (Subp_Decl) = N_Object_Declaration
4440 and then Is_Single_Concurrent_Object
4441 (Unique_Defining_Entity (Subp_Decl))
4447 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4450 -- Subprogram body acts as spec
4452 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4453 and then No (Corresponding_Spec (Subp_Decl))
4457 -- Subprogram body stub acts as spec
4459 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4460 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4464 -- Subprogram declaration
4466 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4468 -- Pragmas Global and Depends are forbidden on null procedures
4469 -- (SPARK RM 6.1.2(2)).
4471 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4472 and then Null_Present (Specification (Subp_Decl))
4474 Error_Msg_N (Fix_Error
4475 ("pragma % cannot apply to null procedure"), N);
4481 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4489 -- If we get here, then the pragma is legal
4492 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4494 -- When the related context is an entry, the entry must belong to a
4495 -- protected unit (SPARK RM 6.1.4(6)).
4497 if Is_Entry_Declaration (Spec_Id)
4498 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4503 -- When the related context is an anonymous object created for a
4504 -- simple concurrent type, the type must be a task
4505 -- (SPARK RM 6.1.4(6)).
4507 elsif Is_Single_Concurrent_Object (Spec_Id)
4508 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4514 -- A pragma that applies to a Ghost entity becomes Ghost for the
4515 -- purposes of legality checks and removal of ignored Ghost code.
4517 Mark_Ghost_Pragma (N, Spec_Id);
4518 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4519 end Analyze_Depends_Global;
4521 ------------------------
4522 -- Analyze_If_Present --
4523 ------------------------
4525 procedure Analyze_If_Present (Id : Pragma_Id) is
4529 pragma Assert (Is_List_Member (N));
4531 -- Inspect the declarations or statements following pragma N looking
4532 -- for another pragma whose Id matches the caller's request. If it is
4533 -- available, analyze it.
4536 while Present (Stmt) loop
4537 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4538 Analyze_Pragma (Stmt);
4541 -- The first source declaration or statement immediately following
4542 -- N ends the region where a pragma may appear.
4544 elsif Comes_From_Source (Stmt) then
4550 end Analyze_If_Present;
4552 --------------------------------
4553 -- Analyze_Pre_Post_Condition --
4554 --------------------------------
4556 procedure Analyze_Pre_Post_Condition is
4557 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4558 Subp_Decl : Node_Id;
4559 Subp_Id : Entity_Id;
4561 Duplicates_OK : Boolean := False;
4562 -- Flag set when a pre/postcondition allows multiple pragmas of the
4565 In_Body_OK : Boolean := False;
4566 -- Flag set when a pre/postcondition is allowed to appear on a body
4567 -- even though the subprogram may have a spec.
4569 Is_Pre_Post : Boolean := False;
4570 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4573 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4574 -- Implement rules in AI12-0131: an overriding operation can have
4575 -- a class-wide precondition only if one of its ancestors has an
4576 -- explicit class-wide precondition.
4578 -----------------------------
4579 -- Inherits_Class_Wide_Pre --
4580 -----------------------------
4582 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4583 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4586 Prev : Entity_Id := Overridden_Operation (E);
4589 -- Check ancestors on the overriding operation to examine the
4590 -- preconditions that may apply to them.
4592 while Present (Prev) loop
4593 Cont := Contract (Prev);
4594 if Present (Cont) then
4595 Prag := Pre_Post_Conditions (Cont);
4596 while Present (Prag) loop
4597 if Pragma_Name (Prag) = Name_Precondition
4598 and then Class_Present (Prag)
4603 Prag := Next_Pragma (Prag);
4607 -- For a type derived from a generic formal type, the operation
4608 -- inheriting the condition is a renaming, not an overriding of
4609 -- the operation of the formal. Ditto for an inherited
4610 -- operation which has no explicit contracts.
4612 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4613 or else not Comes_From_Source (Prev)
4615 Prev := Alias (Prev);
4617 Prev := Overridden_Operation (Prev);
4621 -- If the controlling type of the subprogram has progenitors, an
4622 -- interface operation implemented by the current operation may
4623 -- have a class-wide precondition.
4625 if Has_Interfaces (Typ) then
4630 Prim_Elmt : Elmt_Id;
4631 Prim_List : Elist_Id;
4634 Collect_Interfaces (Typ, Ints);
4635 Elmt := First_Elmt (Ints);
4637 -- Iterate over the primitive operations of each interface
4639 while Present (Elmt) loop
4640 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4641 Prim_Elmt := First_Elmt (Prim_List);
4642 while Present (Prim_Elmt) loop
4643 Prim := Node (Prim_Elmt);
4644 if Chars (Prim) = Chars (E)
4645 and then Present (Contract (Prim))
4646 and then Class_Present
4647 (Pre_Post_Conditions (Contract (Prim)))
4652 Next_Elmt (Prim_Elmt);
4661 end Inherits_Class_Wide_Pre;
4663 -- Start of processing for Analyze_Pre_Post_Condition
4666 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4667 -- offer uniformity among the various kinds of pre/postconditions by
4668 -- rewriting the pragma identifier. This allows the retrieval of the
4669 -- original pragma name by routine Original_Aspect_Pragma_Name.
4671 if Comes_From_Source (N) then
4672 if Pname in Name_Pre | Name_Pre_Class then
4673 Is_Pre_Post := True;
4674 Set_Class_Present (N, Pname = Name_Pre_Class);
4675 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4677 elsif Pname in Name_Post | Name_Post_Class then
4678 Is_Pre_Post := True;
4679 Set_Class_Present (N, Pname = Name_Post_Class);
4680 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4684 -- Determine the semantics with respect to duplicates and placement
4685 -- in a body. Pragmas Precondition and Postcondition were introduced
4686 -- before aspects and are not subject to the same aspect-like rules.
4688 if Pname in Name_Precondition | Name_Postcondition then
4689 Duplicates_OK := True;
4695 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4696 -- argument without an identifier.
4699 Check_Arg_Count (1);
4700 Check_No_Identifiers;
4702 -- Pragmas Precondition and Postcondition have complex argument
4706 Check_At_Least_N_Arguments (1);
4707 Check_At_Most_N_Arguments (2);
4708 Check_Optional_Identifier (Arg1, Name_Check);
4710 if Present (Arg2) then
4711 Check_Optional_Identifier (Arg2, Name_Message);
4712 Preanalyze_Spec_Expression
4713 (Get_Pragma_Arg (Arg2), Standard_String);
4717 -- For a pragma PPC in the extended main source unit, record enabled
4719 -- ??? nothing checks that the pragma is in the main source unit
4721 if Is_Checked (N) and then not Split_PPC (N) then
4722 Set_SCO_Pragma_Enabled (Loc);
4725 -- Ensure the proper placement of the pragma
4728 Find_Related_Declaration_Or_Body
4729 (N, Do_Checks => not Duplicates_OK);
4731 -- When a pre/postcondition pragma applies to an abstract subprogram,
4732 -- its original form must be an aspect with 'Class.
4734 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4735 if not From_Aspect_Specification (N) then
4737 ("pragma % cannot be applied to abstract subprogram");
4739 elsif not Class_Present (N) then
4741 ("aspect % requires ''Class for abstract subprogram");
4744 -- Entry declaration
4746 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4749 -- Generic subprogram declaration
4751 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4756 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4757 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4761 -- Subprogram body stub
4763 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4764 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4768 -- Subprogram declaration
4770 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4772 -- AI05-0230: When a pre/postcondition pragma applies to a null
4773 -- procedure, its original form must be an aspect with 'Class.
4775 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4776 and then Null_Present (Specification (Subp_Decl))
4777 and then From_Aspect_Specification (N)
4778 and then not Class_Present (N)
4780 Error_Pragma ("aspect % requires ''Class for null procedure");
4783 -- Implement the legality checks mandated by AI12-0131:
4784 -- Pre'Class shall not be specified for an overriding primitive
4785 -- subprogram of a tagged type T unless the Pre'Class aspect is
4786 -- specified for the corresponding primitive subprogram of some
4790 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4793 if Class_Present (N)
4794 and then Pragma_Name (N) = Name_Precondition
4795 and then Present (Overridden_Operation (E))
4796 and then not Inherits_Class_Wide_Pre (E)
4799 ("illegal class-wide precondition on overriding operation",
4800 Corresponding_Aspect (N));
4804 -- A renaming declaration may inherit a generated pragma, its
4805 -- placement comes from expansion, not from source.
4807 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4808 and then not Comes_From_Source (N)
4812 -- For Ada 2020, pre/postconditions can appear on formal subprograms
4814 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
4815 and then Ada_Version >= Ada_2020
4819 -- An access-to-subprogram type can have pre/postconditions, but
4820 -- these are transferred to the generated subprogram wrapper and
4823 -- Otherwise the placement of the pragma is illegal
4830 Subp_Id := Defining_Entity (Subp_Decl);
4832 -- A pragma that applies to a Ghost entity becomes Ghost for the
4833 -- purposes of legality checks and removal of ignored Ghost code.
4835 Mark_Ghost_Pragma (N, Subp_Id);
4837 -- Chain the pragma on the contract for further processing by
4838 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4840 Add_Contract_Item (N, Subp_Id);
4842 -- Fully analyze the pragma when it appears inside an entry or
4843 -- subprogram body because it cannot benefit from forward references.
4845 if Nkind (Subp_Decl) in N_Entry_Body
4847 | N_Subprogram_Body_Stub
4849 -- The legality checks of pragmas Precondition and Postcondition
4850 -- are affected by the SPARK mode in effect and the volatility of
4851 -- the context. Analyze all pragmas in a specific order.
4853 Analyze_If_Present (Pragma_SPARK_Mode);
4854 Analyze_If_Present (Pragma_Volatile_Function);
4855 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4857 end Analyze_Pre_Post_Condition;
4859 -----------------------------------------
4860 -- Analyze_Refined_Depends_Global_Post --
4861 -----------------------------------------
4863 procedure Analyze_Refined_Depends_Global_Post
4864 (Spec_Id : out Entity_Id;
4865 Body_Id : out Entity_Id;
4866 Legal : out Boolean)
4868 Body_Decl : Node_Id;
4869 Spec_Decl : Node_Id;
4872 -- Assume that the pragma is illegal
4879 Check_Arg_Count (1);
4880 Check_No_Identifiers;
4882 -- Verify the placement of the pragma and check for duplicates. The
4883 -- pragma must apply to a subprogram body [stub].
4885 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4887 if Nkind (Body_Decl) not in
4888 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
4889 N_Task_Body | N_Task_Body_Stub
4895 Body_Id := Defining_Entity (Body_Decl);
4896 Spec_Id := Unique_Defining_Entity (Body_Decl);
4898 -- The pragma must apply to the second declaration of a subprogram.
4899 -- In other words, the body [stub] cannot acts as a spec.
4901 if No (Spec_Id) then
4902 Error_Pragma ("pragma % cannot apply to a stand alone body");
4905 -- Catch the case where the subprogram body is a subunit and acts as
4906 -- the third declaration of the subprogram.
4908 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4909 Error_Pragma ("pragma % cannot apply to a subunit");
4913 -- A refined pragma can only apply to the body [stub] of a subprogram
4914 -- declared in the visible part of a package. Retrieve the context of
4915 -- the subprogram declaration.
4917 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4919 -- When dealing with protected entries or protected subprograms, use
4920 -- the enclosing protected type as the proper context.
4922 if Ekind (Spec_Id) in E_Entry
4926 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4928 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4931 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4933 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4934 & "subprogram declared in a package specification"));
4938 -- If we get here, then the pragma is legal
4942 -- A pragma that applies to a Ghost entity becomes Ghost for the
4943 -- purposes of legality checks and removal of ignored Ghost code.
4945 Mark_Ghost_Pragma (N, Spec_Id);
4947 if Pname in Name_Refined_Depends | Name_Refined_Global then
4948 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4950 end Analyze_Refined_Depends_Global_Post;
4952 ----------------------------------
4953 -- Analyze_Unmodified_Or_Unused --
4954 ----------------------------------
4956 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4961 Ghost_Error_Posted : Boolean := False;
4962 -- Flag set when an error concerning the illegal mix of Ghost and
4963 -- non-Ghost variables is emitted.
4965 Ghost_Id : Entity_Id := Empty;
4966 -- The entity of the first Ghost variable encountered while
4967 -- processing the arguments of the pragma.
4971 Check_At_Least_N_Arguments (1);
4973 -- Loop through arguments
4976 while Present (Arg) loop
4977 Check_No_Identifier (Arg);
4979 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4980 -- in fact generate reference, so that the entity will have a
4981 -- reference, which will inhibit any warnings about it not
4982 -- being referenced, and also properly show up in the ali file
4983 -- as a reference. But this reference is recorded before the
4984 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4985 -- generated for this reference.
4987 Check_Arg_Is_Local_Name (Arg);
4988 Arg_Expr := Get_Pragma_Arg (Arg);
4990 if Is_Entity_Name (Arg_Expr) then
4991 Arg_Id := Entity (Arg_Expr);
4993 -- Skip processing the argument if already flagged
4995 if Is_Assignable (Arg_Id)
4996 and then not Has_Pragma_Unmodified (Arg_Id)
4997 and then not Has_Pragma_Unused (Arg_Id)
4999 Set_Has_Pragma_Unmodified (Arg_Id);
5002 Set_Has_Pragma_Unused (Arg_Id);
5005 -- A pragma that applies to a Ghost entity becomes Ghost for
5006 -- the purposes of legality checks and removal of ignored
5009 Mark_Ghost_Pragma (N, Arg_Id);
5011 -- Capture the entity of the first Ghost variable being
5012 -- processed for error detection purposes.
5014 if Is_Ghost_Entity (Arg_Id) then
5015 if No (Ghost_Id) then
5019 -- Otherwise the variable is non-Ghost. It is illegal to mix
5020 -- references to Ghost and non-Ghost entities
5023 elsif Present (Ghost_Id)
5024 and then not Ghost_Error_Posted
5026 Ghost_Error_Posted := True;
5028 Error_Msg_Name_1 := Pname;
5030 ("pragma % cannot mention ghost and non-ghost "
5033 Error_Msg_Sloc := Sloc (Ghost_Id);
5034 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5036 Error_Msg_Sloc := Sloc (Arg_Id);
5037 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5040 -- Warn if already flagged as Unused or Unmodified
5042 elsif Has_Pragma_Unmodified (Arg_Id) then
5043 if Has_Pragma_Unused (Arg_Id) then
5045 ("??pragma Unused already given for &!", Arg_Expr,
5049 ("??pragma Unmodified already given for &!", Arg_Expr,
5053 -- Otherwise the pragma referenced an illegal entity
5057 ("pragma% can only be applied to a variable", Arg_Expr);
5063 end Analyze_Unmodified_Or_Unused;
5065 ------------------------------------
5066 -- Analyze_Unreferenced_Or_Unused --
5067 ------------------------------------
5069 procedure Analyze_Unreferenced_Or_Unused
5070 (Is_Unused : Boolean := False)
5077 Ghost_Error_Posted : Boolean := False;
5078 -- Flag set when an error concerning the illegal mix of Ghost and
5079 -- non-Ghost names is emitted.
5081 Ghost_Id : Entity_Id := Empty;
5082 -- The entity of the first Ghost name encountered while processing
5083 -- the arguments of the pragma.
5087 Check_At_Least_N_Arguments (1);
5089 -- Check case of appearing within context clause
5091 if not Is_Unused and then Is_In_Context_Clause then
5093 -- The arguments must all be units mentioned in a with clause in
5094 -- the same context clause. Note that Par.Prag already checked
5095 -- that the arguments are either identifiers or selected
5099 while Present (Arg) loop
5100 Citem := First (List_Containing (N));
5101 while Citem /= N loop
5102 Arg_Expr := Get_Pragma_Arg (Arg);
5104 if Nkind (Citem) = N_With_Clause
5105 and then Same_Name (Name (Citem), Arg_Expr)
5107 Set_Has_Pragma_Unreferenced
5110 (Library_Unit (Citem))));
5111 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5120 ("argument of pragma% is not withed unit", Arg);
5126 -- Case of not in list of context items
5130 while Present (Arg) loop
5131 Check_No_Identifier (Arg);
5133 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5134 -- in fact generate reference, so that the entity will have a
5135 -- reference, which will inhibit any warnings about it not
5136 -- being referenced, and also properly show up in the ali file
5137 -- as a reference. But this reference is recorded before the
5138 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5139 -- generated for this reference.
5141 Check_Arg_Is_Local_Name (Arg);
5142 Arg_Expr := Get_Pragma_Arg (Arg);
5144 if Is_Entity_Name (Arg_Expr) then
5145 Arg_Id := Entity (Arg_Expr);
5147 -- Warn if already flagged as Unused or Unreferenced and
5148 -- skip processing the argument.
5150 if Has_Pragma_Unreferenced (Arg_Id) then
5151 if Has_Pragma_Unused (Arg_Id) then
5153 ("??pragma Unused already given for &!", Arg_Expr,
5157 ("??pragma Unreferenced already given for &!",
5161 -- Apply Unreferenced to the entity
5164 -- If the entity is overloaded, the pragma applies to the
5165 -- most recent overloading, as documented. In this case,
5166 -- name resolution does not generate a reference, so it
5167 -- must be done here explicitly.
5169 if Is_Overloaded (Arg_Expr) then
5170 Generate_Reference (Arg_Id, N);
5173 Set_Has_Pragma_Unreferenced (Arg_Id);
5176 Set_Has_Pragma_Unused (Arg_Id);
5179 -- A pragma that applies to a Ghost entity becomes Ghost
5180 -- for the purposes of legality checks and removal of
5181 -- ignored Ghost code.
5183 Mark_Ghost_Pragma (N, Arg_Id);
5185 -- Capture the entity of the first Ghost name being
5186 -- processed for error detection purposes.
5188 if Is_Ghost_Entity (Arg_Id) then
5189 if No (Ghost_Id) then
5193 -- Otherwise the name is non-Ghost. It is illegal to mix
5194 -- references to Ghost and non-Ghost entities
5197 elsif Present (Ghost_Id)
5198 and then not Ghost_Error_Posted
5200 Ghost_Error_Posted := True;
5202 Error_Msg_Name_1 := Pname;
5204 ("pragma % cannot mention ghost and non-ghost "
5207 Error_Msg_Sloc := Sloc (Ghost_Id);
5209 ("\& # declared as ghost", N, Ghost_Id);
5211 Error_Msg_Sloc := Sloc (Arg_Id);
5213 ("\& # declared as non-ghost", N, Arg_Id);
5221 end Analyze_Unreferenced_Or_Unused;
5223 --------------------------
5224 -- Check_Ada_83_Warning --
5225 --------------------------
5227 procedure Check_Ada_83_Warning is
5229 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5230 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5232 end Check_Ada_83_Warning;
5234 ---------------------
5235 -- Check_Arg_Count --
5236 ---------------------
5238 procedure Check_Arg_Count (Required : Nat) is
5240 if Arg_Count /= Required then
5241 Error_Pragma ("wrong number of arguments for pragma%");
5243 end Check_Arg_Count;
5245 --------------------------------
5246 -- Check_Arg_Is_External_Name --
5247 --------------------------------
5249 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5250 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5253 if Nkind (Argx) = N_Identifier then
5257 Analyze_And_Resolve (Argx, Standard_String);
5259 if Is_OK_Static_Expression (Argx) then
5262 elsif Etype (Argx) = Any_Type then
5265 -- An interesting special case, if we have a string literal and
5266 -- we are in Ada 83 mode, then we allow it even though it will
5267 -- not be flagged as static. This allows expected Ada 83 mode
5268 -- use of external names which are string literals, even though
5269 -- technically these are not static in Ada 83.
5271 elsif Ada_Version = Ada_83
5272 and then Nkind (Argx) = N_String_Literal
5276 -- Here we have a real error (non-static expression)
5279 Error_Msg_Name_1 := Pname;
5280 Flag_Non_Static_Expr
5281 (Fix_Error ("argument for pragma% must be a identifier or "
5282 & "static string expression!"), Argx);
5287 end Check_Arg_Is_External_Name;
5289 -----------------------------
5290 -- Check_Arg_Is_Identifier --
5291 -----------------------------
5293 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5294 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5296 if Nkind (Argx) /= N_Identifier then
5297 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5299 end Check_Arg_Is_Identifier;
5301 ----------------------------------
5302 -- Check_Arg_Is_Integer_Literal --
5303 ----------------------------------
5305 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5306 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5308 if Nkind (Argx) /= N_Integer_Literal then
5310 ("argument for pragma% must be integer literal", Argx);
5312 end Check_Arg_Is_Integer_Literal;
5314 -------------------------------------------
5315 -- Check_Arg_Is_Library_Level_Local_Name --
5316 -------------------------------------------
5320 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5321 -- | library_unit_NAME
5323 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5325 Check_Arg_Is_Local_Name (Arg);
5327 -- If it came from an aspect, we want to give the error just as if it
5328 -- came from source.
5330 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5331 and then (Comes_From_Source (N)
5332 or else Present (Corresponding_Aspect (Parent (Arg))))
5335 ("argument for pragma% must be library level entity", Arg);
5337 end Check_Arg_Is_Library_Level_Local_Name;
5339 -----------------------------
5340 -- Check_Arg_Is_Local_Name --
5341 -----------------------------
5345 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5346 -- | library_unit_NAME
5348 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5349 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5352 -- If this pragma came from an aspect specification, we don't want to
5353 -- check for this error, because that would cause spurious errors, in
5354 -- case a type is frozen in a scope more nested than the type. The
5355 -- aspect itself of course can't be anywhere but on the declaration
5358 if Nkind (Arg) = N_Pragma_Argument_Association then
5359 if From_Aspect_Specification (Parent (Arg)) then
5363 -- Arg is the Expression of an N_Pragma_Argument_Association
5366 if From_Aspect_Specification (Parent (Parent (Arg))) then
5373 if Nkind (Argx) not in N_Direct_Name
5374 and then (Nkind (Argx) /= N_Attribute_Reference
5375 or else Present (Expressions (Argx))
5376 or else Nkind (Prefix (Argx)) /= N_Identifier)
5377 and then (not Is_Entity_Name (Argx)
5378 or else not Is_Compilation_Unit (Entity (Argx)))
5380 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5383 -- No further check required if not an entity name
5385 if not Is_Entity_Name (Argx) then
5391 Ent : constant Entity_Id := Entity (Argx);
5392 Scop : constant Entity_Id := Scope (Ent);
5395 -- Case of a pragma applied to a compilation unit: pragma must
5396 -- occur immediately after the program unit in the compilation.
5398 if Is_Compilation_Unit (Ent) then
5400 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5403 -- Case of pragma placed immediately after spec
5405 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5408 -- Case of pragma placed immediately after body
5410 elsif Nkind (Decl) = N_Subprogram_Declaration
5411 and then Present (Corresponding_Body (Decl))
5415 (Parent (Unit_Declaration_Node
5416 (Corresponding_Body (Decl))));
5418 -- All other cases are illegal
5425 -- Special restricted placement rule from 10.2.1(11.8/2)
5427 elsif Is_Generic_Formal (Ent)
5428 and then Prag_Id = Pragma_Preelaborable_Initialization
5430 OK := List_Containing (N) =
5431 Generic_Formal_Declarations
5432 (Unit_Declaration_Node (Scop));
5434 -- If this is an aspect applied to a subprogram body, the
5435 -- pragma is inserted in its declarative part.
5437 elsif From_Aspect_Specification (N)
5438 and then Ent = Current_Scope
5440 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5444 -- If the aspect is a predicate (possibly others ???) and the
5445 -- context is a record type, this is a discriminant expression
5446 -- within a type declaration, that freezes the predicated
5449 elsif From_Aspect_Specification (N)
5450 and then Prag_Id = Pragma_Predicate
5451 and then Ekind (Current_Scope) = E_Record_Type
5452 and then Scop = Scope (Current_Scope)
5456 -- Default case, just check that the pragma occurs in the scope
5457 -- of the entity denoted by the name.
5460 OK := Current_Scope = Scop;
5465 ("pragma% argument must be in same declarative part", Arg);
5469 end Check_Arg_Is_Local_Name;
5471 ---------------------------------
5472 -- Check_Arg_Is_Locking_Policy --
5473 ---------------------------------
5475 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5476 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5479 Check_Arg_Is_Identifier (Argx);
5481 if not Is_Locking_Policy_Name (Chars (Argx)) then
5482 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5484 end Check_Arg_Is_Locking_Policy;
5486 -----------------------------------------------
5487 -- Check_Arg_Is_Partition_Elaboration_Policy --
5488 -----------------------------------------------
5490 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5491 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5494 Check_Arg_Is_Identifier (Argx);
5496 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5498 ("& is not a valid partition elaboration policy name", Argx);
5500 end Check_Arg_Is_Partition_Elaboration_Policy;
5502 -------------------------
5503 -- Check_Arg_Is_One_Of --
5504 -------------------------
5506 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5507 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5510 Check_Arg_Is_Identifier (Argx);
5512 if Chars (Argx) not in N1 | N2 then
5513 Error_Msg_Name_2 := N1;
5514 Error_Msg_Name_3 := N2;
5515 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5517 end Check_Arg_Is_One_Of;
5519 procedure Check_Arg_Is_One_Of
5521 N1, N2, N3 : Name_Id)
5523 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5526 Check_Arg_Is_Identifier (Argx);
5528 if Chars (Argx) not in N1 | N2 | N3 then
5529 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5531 end Check_Arg_Is_One_Of;
5533 procedure Check_Arg_Is_One_Of
5535 N1, N2, N3, N4 : Name_Id)
5537 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5540 Check_Arg_Is_Identifier (Argx);
5542 if Chars (Argx) not in N1 | N2 | N3 | N4 then
5543 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5545 end Check_Arg_Is_One_Of;
5547 procedure Check_Arg_Is_One_Of
5549 N1, N2, N3, N4, N5 : Name_Id)
5551 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5554 Check_Arg_Is_Identifier (Argx);
5556 if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
5557 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5559 end Check_Arg_Is_One_Of;
5561 ---------------------------------
5562 -- Check_Arg_Is_Queuing_Policy --
5563 ---------------------------------
5565 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5566 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5569 Check_Arg_Is_Identifier (Argx);
5571 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5572 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5574 end Check_Arg_Is_Queuing_Policy;
5576 ---------------------------------------
5577 -- Check_Arg_Is_OK_Static_Expression --
5578 ---------------------------------------
5580 procedure Check_Arg_Is_OK_Static_Expression
5582 Typ : Entity_Id := Empty)
5585 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5586 end Check_Arg_Is_OK_Static_Expression;
5588 ------------------------------------------
5589 -- Check_Arg_Is_Task_Dispatching_Policy --
5590 ------------------------------------------
5592 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5593 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5596 Check_Arg_Is_Identifier (Argx);
5598 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5600 ("& is not an allowed task dispatching policy name", Argx);
5602 end Check_Arg_Is_Task_Dispatching_Policy;
5604 ---------------------
5605 -- Check_Arg_Order --
5606 ---------------------
5608 procedure Check_Arg_Order (Names : Name_List) is
5611 Highest_So_Far : Natural := 0;
5612 -- Highest index in Names seen do far
5616 for J in 1 .. Arg_Count loop
5617 if Chars (Arg) /= No_Name then
5618 for K in Names'Range loop
5619 if Chars (Arg) = Names (K) then
5620 if K < Highest_So_Far then
5621 Error_Msg_Name_1 := Pname;
5623 ("parameters out of order for pragma%", Arg);
5624 Error_Msg_Name_1 := Names (K);
5625 Error_Msg_Name_2 := Names (Highest_So_Far);
5626 Error_Msg_N ("\% must appear before %", Arg);
5630 Highest_So_Far := K;
5638 end Check_Arg_Order;
5640 --------------------------------
5641 -- Check_At_Least_N_Arguments --
5642 --------------------------------
5644 procedure Check_At_Least_N_Arguments (N : Nat) is
5646 if Arg_Count < N then
5647 Error_Pragma ("too few arguments for pragma%");
5649 end Check_At_Least_N_Arguments;
5651 -------------------------------
5652 -- Check_At_Most_N_Arguments --
5653 -------------------------------
5655 procedure Check_At_Most_N_Arguments (N : Nat) is
5658 if Arg_Count > N then
5660 for J in 1 .. N loop
5662 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5665 end Check_At_Most_N_Arguments;
5667 ---------------------
5668 -- Check_Component --
5669 ---------------------
5671 procedure Check_Component
5674 In_Variant_Part : Boolean := False)
5676 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5677 Sindic : constant Node_Id :=
5678 Subtype_Indication (Component_Definition (Comp));
5679 Typ : constant Entity_Id := Etype (Comp_Id);
5682 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5683 -- object constraint, then the component type shall be an Unchecked_
5686 if Nkind (Sindic) = N_Subtype_Indication
5687 and then Has_Per_Object_Constraint (Comp_Id)
5688 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5691 ("component subtype subject to per-object constraint "
5692 & "must be an Unchecked_Union", Comp);
5694 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5695 -- the body of a generic unit, or within the body of any of its
5696 -- descendant library units, no part of the type of a component
5697 -- declared in a variant_part of the unchecked union type shall be of
5698 -- a formal private type or formal private extension declared within
5699 -- the formal part of the generic unit.
5701 elsif Ada_Version >= Ada_2012
5702 and then In_Generic_Body (UU_Typ)
5703 and then In_Variant_Part
5704 and then Is_Private_Type (Typ)
5705 and then Is_Generic_Type (Typ)
5708 ("component of unchecked union cannot be of generic type", Comp);
5710 elsif Needs_Finalization (Typ) then
5712 ("component of unchecked union cannot be controlled", Comp);
5714 elsif Has_Task (Typ) then
5716 ("component of unchecked union cannot have tasks", Comp);
5718 end Check_Component;
5720 ----------------------------
5721 -- Check_Duplicate_Pragma --
5722 ----------------------------
5724 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5725 Id : Entity_Id := E;
5729 -- Nothing to do if this pragma comes from an aspect specification,
5730 -- since we could not be duplicating a pragma, and we dealt with the
5731 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5733 if From_Aspect_Specification (N) then
5737 -- Otherwise current pragma may duplicate previous pragma or a
5738 -- previously given aspect specification or attribute definition
5739 -- clause for the same pragma.
5741 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5745 -- If the entity is a type, then we have to make sure that the
5746 -- ostensible duplicate is not for a parent type from which this
5750 if Nkind (P) = N_Pragma then
5752 Args : constant List_Id :=
5753 Pragma_Argument_Associations (P);
5756 and then Is_Entity_Name (Expression (First (Args)))
5757 and then Is_Type (Entity (Expression (First (Args))))
5758 and then Entity (Expression (First (Args))) /= E
5764 elsif Nkind (P) = N_Aspect_Specification
5765 and then Is_Type (Entity (P))
5766 and then Entity (P) /= E
5772 -- Here we have a definite duplicate
5774 Error_Msg_Name_1 := Pragma_Name (N);
5775 Error_Msg_Sloc := Sloc (P);
5777 -- For a single protected or a single task object, the error is
5778 -- issued on the original entity.
5780 if Ekind (Id) in E_Task_Type | E_Protected_Type then
5781 Id := Defining_Identifier (Original_Node (Parent (Id)));
5784 if Nkind (P) = N_Aspect_Specification
5785 or else From_Aspect_Specification (P)
5787 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5789 -- If -gnatwr is set, warn in case of a duplicate pragma
5790 -- [No_]Inline which is suspicious but not an error, generate
5791 -- an error for other pragmas.
5793 if Pragma_Name (N) in Name_Inline | Name_No_Inline then
5794 if Warn_On_Redundant_Constructs then
5796 ("?r?pragma% for & duplicates pragma#", N, Id);
5799 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5805 end Check_Duplicate_Pragma;
5807 ----------------------------------
5808 -- Check_Duplicated_Export_Name --
5809 ----------------------------------
5811 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5812 String_Val : constant String_Id := Strval (Nam);
5815 -- We are only interested in the export case, and in the case of
5816 -- generics, it is the instance, not the template, that is the
5817 -- problem (the template will generate a warning in any case).
5819 if not Inside_A_Generic
5820 and then (Prag_Id = Pragma_Export
5822 Prag_Id = Pragma_Export_Procedure
5824 Prag_Id = Pragma_Export_Valued_Procedure
5826 Prag_Id = Pragma_Export_Function)
5828 for J in Externals.First .. Externals.Last loop
5829 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5830 Error_Msg_Sloc := Sloc (Externals.Table (J));
5831 Error_Msg_N ("external name duplicates name given#", Nam);
5836 Externals.Append (Nam);
5838 end Check_Duplicated_Export_Name;
5840 ----------------------------------------
5841 -- Check_Expr_Is_OK_Static_Expression --
5842 ----------------------------------------
5844 procedure Check_Expr_Is_OK_Static_Expression
5846 Typ : Entity_Id := Empty)
5849 if Present (Typ) then
5850 Analyze_And_Resolve (Expr, Typ);
5852 Analyze_And_Resolve (Expr);
5855 -- An expression cannot be considered static if its resolution failed
5856 -- or if it's erroneous. Stop the analysis of the related pragma.
5858 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5861 elsif Is_OK_Static_Expression (Expr) then
5864 -- An interesting special case, if we have a string literal and we
5865 -- are in Ada 83 mode, then we allow it even though it will not be
5866 -- flagged as static. This allows the use of Ada 95 pragmas like
5867 -- Import in Ada 83 mode. They will of course be flagged with
5868 -- warnings as usual, but will not cause errors.
5870 elsif Ada_Version = Ada_83
5871 and then Nkind (Expr) = N_String_Literal
5875 -- Finally, we have a real error
5878 Error_Msg_Name_1 := Pname;
5879 Flag_Non_Static_Expr
5880 (Fix_Error ("argument for pragma% must be a static expression!"),
5884 end Check_Expr_Is_OK_Static_Expression;
5886 -------------------------
5887 -- Check_First_Subtype --
5888 -------------------------
5890 procedure Check_First_Subtype (Arg : Node_Id) is
5891 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5892 Ent : constant Entity_Id := Entity (Argx);
5895 if Is_First_Subtype (Ent) then
5898 elsif Is_Type (Ent) then
5900 ("pragma% cannot apply to subtype", Argx);
5902 elsif Is_Object (Ent) then
5904 ("pragma% cannot apply to object, requires a type", Argx);
5908 ("pragma% cannot apply to&, requires a type", Argx);
5910 end Check_First_Subtype;
5912 ----------------------
5913 -- Check_Identifier --
5914 ----------------------
5916 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5919 and then Nkind (Arg) = N_Pragma_Argument_Association
5921 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5922 Error_Msg_Name_1 := Pname;
5923 Error_Msg_Name_2 := Id;
5924 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5928 end Check_Identifier;
5930 --------------------------------
5931 -- Check_Identifier_Is_One_Of --
5932 --------------------------------
5934 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5937 and then Nkind (Arg) = N_Pragma_Argument_Association
5939 if Chars (Arg) = No_Name then
5940 Error_Msg_Name_1 := Pname;
5941 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5944 elsif Chars (Arg) /= N1
5945 and then Chars (Arg) /= N2
5947 Error_Msg_Name_1 := Pname;
5948 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5952 end Check_Identifier_Is_One_Of;
5954 ---------------------------
5955 -- Check_In_Main_Program --
5956 ---------------------------
5958 procedure Check_In_Main_Program is
5959 P : constant Node_Id := Parent (N);
5962 -- Must be in subprogram body
5964 if Nkind (P) /= N_Subprogram_Body then
5965 Error_Pragma ("% pragma allowed only in subprogram");
5967 -- Otherwise warn if obviously not main program
5969 elsif Present (Parameter_Specifications (Specification (P)))
5970 or else not Is_Compilation_Unit (Defining_Entity (P))
5972 Error_Msg_Name_1 := Pname;
5974 ("??pragma% is only effective in main program", N);
5976 end Check_In_Main_Program;
5978 ---------------------------------------
5979 -- Check_Interrupt_Or_Attach_Handler --
5980 ---------------------------------------
5982 procedure Check_Interrupt_Or_Attach_Handler is
5983 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5984 Handler_Proc, Proc_Scope : Entity_Id;
5989 if Prag_Id = Pragma_Interrupt_Handler then
5990 Check_Restriction (No_Dynamic_Attachment, N);
5993 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5994 Proc_Scope := Scope (Handler_Proc);
5996 if Ekind (Proc_Scope) /= E_Protected_Type then
5998 ("argument of pragma% must be protected procedure", Arg1);
6001 -- For pragma case (as opposed to access case), check placement.
6002 -- We don't need to do that for aspects, because we have the
6003 -- check that they aspect applies an appropriate procedure.
6005 if not From_Aspect_Specification (N)
6006 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6008 Error_Pragma ("pragma% must be in protected definition");
6011 if not Is_Library_Level_Entity (Proc_Scope) then
6013 ("argument for pragma% must be library level entity", Arg1);
6016 -- AI05-0033: A pragma cannot appear within a generic body, because
6017 -- instance can be in a nested scope. The check that protected type
6018 -- is itself a library-level declaration is done elsewhere.
6020 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6021 -- handle code prior to AI-0033. Analysis tools typically are not
6022 -- interested in this pragma in any case, so no need to worry too
6023 -- much about its placement.
6025 if Inside_A_Generic then
6026 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6027 and then In_Package_Body (Scope (Current_Scope))
6028 and then not Relaxed_RM_Semantics
6030 Error_Pragma ("pragma% cannot be used inside a generic");
6033 end Check_Interrupt_Or_Attach_Handler;
6035 ---------------------------------
6036 -- Check_Loop_Pragma_Placement --
6037 ---------------------------------
6039 procedure Check_Loop_Pragma_Placement is
6040 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6041 -- Verify whether the current pragma is properly grouped with other
6042 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6043 -- related loop where the pragma appears.
6045 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6046 -- Determine whether an arbitrary statement Stmt denotes pragma
6047 -- Loop_Invariant or Loop_Variant.
6049 procedure Placement_Error (Constr : Node_Id);
6050 pragma No_Return (Placement_Error);
6051 -- Node Constr denotes the last loop restricted construct before we
6052 -- encountered an illegal relation between enclosing constructs. Emit
6053 -- an error depending on what Constr was.
6055 --------------------------------
6056 -- Check_Loop_Pragma_Grouping --
6057 --------------------------------
6059 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6060 Stop_Search : exception;
6061 -- This exception is used to terminate the recursive descent of
6062 -- routine Check_Grouping.
6064 procedure Check_Grouping (L : List_Id);
6065 -- Find the first group of pragmas in list L and if successful,
6066 -- ensure that the current pragma is part of that group. The
6067 -- routine raises Stop_Search once such a check is performed to
6068 -- halt the recursive descent.
6070 procedure Grouping_Error (Prag : Node_Id);
6071 pragma No_Return (Grouping_Error);
6072 -- Emit an error concerning the current pragma indicating that it
6073 -- should be placed after pragma Prag.
6075 --------------------
6076 -- Check_Grouping --
6077 --------------------
6079 procedure Check_Grouping (L : List_Id) is
6082 Prag : Node_Id := Empty; -- init to avoid warning
6085 -- Inspect the list of declarations or statements looking for
6086 -- the first grouping of pragmas:
6089 -- pragma Loop_Invariant ...;
6090 -- pragma Loop_Variant ...;
6092 -- pragma Loop_Variant ...; -- current pragma
6094 -- If the current pragma is not in the grouping, then it must
6095 -- either appear in a different declarative or statement list
6096 -- or the construct at (1) is separating the pragma from the
6100 while Present (Stmt) loop
6102 -- First pragma of the first topmost grouping has been found
6104 if Is_Loop_Pragma (Stmt) then
6106 -- The group and the current pragma are not in the same
6107 -- declarative or statement list.
6109 if not In_Same_List (Stmt, N) then
6110 Grouping_Error (Stmt);
6112 -- Try to reach the current pragma from the first pragma
6113 -- of the grouping while skipping other members:
6115 -- pragma Loop_Invariant ...; -- first pragma
6116 -- pragma Loop_Variant ...; -- member
6118 -- pragma Loop_Variant ...; -- current pragma
6121 while Present (Stmt) loop
6122 -- The current pragma is either the first pragma
6123 -- of the group or is a member of the group.
6124 -- Stop the search as the placement is legal.
6129 -- Skip group members, but keep track of the
6130 -- last pragma in the group.
6132 elsif Is_Loop_Pragma (Stmt) then
6135 -- Skip declarations and statements generated by
6136 -- the compiler during expansion. Note that some
6137 -- source statements (e.g. pragma Assert) may have
6138 -- been transformed so that they do not appear as
6139 -- coming from source anymore, so we instead look
6140 -- at their Original_Node.
6142 elsif not Comes_From_Source (Original_Node (Stmt))
6146 -- A non-pragma is separating the group from the
6147 -- current pragma, the placement is illegal.
6150 Grouping_Error (Prag);
6156 -- If the traversal did not reach the current pragma,
6157 -- then the list must be malformed.
6159 raise Program_Error;
6162 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6163 -- inside a loop or a block housed inside a loop. Inspect
6164 -- the declarations and statements of the block as they may
6165 -- contain the first grouping. This case follows the one for
6166 -- loop pragmas, as block statements which originate in a
6167 -- loop pragma (and so Is_Loop_Pragma will return True on
6168 -- that block statement) should be treated in the previous
6171 elsif Nkind (Stmt) = N_Block_Statement then
6172 HSS := Handled_Statement_Sequence (Stmt);
6174 Check_Grouping (Declarations (Stmt));
6176 if Present (HSS) then
6177 Check_Grouping (Statements (HSS));
6185 --------------------
6186 -- Grouping_Error --
6187 --------------------
6189 procedure Grouping_Error (Prag : Node_Id) is
6191 Error_Msg_Sloc := Sloc (Prag);
6192 Error_Pragma ("pragma% must appear next to pragma#");
6195 -- Start of processing for Check_Loop_Pragma_Grouping
6198 -- Inspect the statements of the loop or nested blocks housed
6199 -- within to determine whether the current pragma is part of the
6200 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6202 Check_Grouping (Statements (Loop_Stmt));
6205 when Stop_Search => null;
6206 end Check_Loop_Pragma_Grouping;
6208 --------------------
6209 -- Is_Loop_Pragma --
6210 --------------------
6212 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6213 Original_Stmt : constant Node_Id := Original_Node (Stmt);
6216 -- Inspect the original node as Loop_Invariant and Loop_Variant
6217 -- pragmas are rewritten to null when assertions are disabled.
6219 return Nkind (Original_Stmt) = N_Pragma
6220 and then Pragma_Name_Unmapped (Original_Stmt)
6221 in Name_Loop_Invariant | Name_Loop_Variant;
6224 ---------------------
6225 -- Placement_Error --
6226 ---------------------
6228 procedure Placement_Error (Constr : Node_Id) is
6229 LA : constant String := " with Loop_Entry";
6232 if Prag_Id = Pragma_Assert then
6233 Error_Msg_String (1 .. LA'Length) := LA;
6234 Error_Msg_Strlen := LA'Length;
6236 Error_Msg_Strlen := 0;
6239 if Nkind (Constr) = N_Pragma then
6241 ("pragma %~ must appear immediately within the statements "
6245 ("block containing pragma %~ must appear immediately within "
6246 & "the statements of a loop", Constr);
6248 end Placement_Error;
6250 -- Local declarations
6255 -- Start of processing for Check_Loop_Pragma_Placement
6258 -- Check that pragma appears immediately within a loop statement,
6259 -- ignoring intervening block statements.
6263 while Present (Stmt) loop
6265 -- The pragma or previous block must appear immediately within the
6266 -- current block's declarative or statement part.
6268 if Nkind (Stmt) = N_Block_Statement then
6269 if (No (Declarations (Stmt))
6270 or else List_Containing (Prev) /= Declarations (Stmt))
6272 List_Containing (Prev) /=
6273 Statements (Handled_Statement_Sequence (Stmt))
6275 Placement_Error (Prev);
6278 -- Keep inspecting the parents because we are now within a
6279 -- chain of nested blocks.
6283 Stmt := Parent (Stmt);
6286 -- The pragma or previous block must appear immediately within the
6287 -- statements of the loop.
6289 elsif Nkind (Stmt) = N_Loop_Statement then
6290 if List_Containing (Prev) /= Statements (Stmt) then
6291 Placement_Error (Prev);
6294 -- Stop the traversal because we reached the innermost loop
6295 -- regardless of whether we encountered an error or not.
6299 -- Ignore a handled statement sequence. Note that this node may
6300 -- be related to a subprogram body in which case we will emit an
6301 -- error on the next iteration of the search.
6303 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6304 Stmt := Parent (Stmt);
6306 -- Any other statement breaks the chain from the pragma to the
6310 Placement_Error (Prev);
6315 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6316 -- grouped together with other such pragmas.
6318 if Is_Loop_Pragma (N) then
6320 -- The previous check should have located the related loop
6322 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6323 Check_Loop_Pragma_Grouping (Stmt);
6325 end Check_Loop_Pragma_Placement;
6327 -------------------------------------------
6328 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6329 -------------------------------------------
6331 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6340 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6343 elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
6346 -- Note: the following tests seem a little peculiar, because
6347 -- they test for bodies, but if we were in the statement part
6348 -- of the body, we would already have hit the handled statement
6349 -- sequence, so the only way we get here is by being in the
6350 -- declarative part of the body.
6353 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6361 Error_Pragma ("pragma% is not in declarative part or package spec");
6362 end Check_Is_In_Decl_Part_Or_Package_Spec;
6364 -------------------------
6365 -- Check_No_Identifier --
6366 -------------------------
6368 procedure Check_No_Identifier (Arg : Node_Id) is
6370 if Nkind (Arg) = N_Pragma_Argument_Association
6371 and then Chars (Arg) /= No_Name
6373 Error_Pragma_Arg_Ident
6374 ("pragma% does not permit identifier& here", Arg);
6376 end Check_No_Identifier;
6378 --------------------------
6379 -- Check_No_Identifiers --
6380 --------------------------
6382 procedure Check_No_Identifiers is
6386 for J in 1 .. Arg_Count loop
6387 Check_No_Identifier (Arg_Node);
6390 end Check_No_Identifiers;
6392 ------------------------
6393 -- Check_No_Link_Name --
6394 ------------------------
6396 procedure Check_No_Link_Name is
6398 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6402 if Present (Arg4) then
6404 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6406 end Check_No_Link_Name;
6408 -------------------------------
6409 -- Check_Optional_Identifier --
6410 -------------------------------
6412 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6415 and then Nkind (Arg) = N_Pragma_Argument_Association
6416 and then Chars (Arg) /= No_Name
6418 if Chars (Arg) /= Id then
6419 Error_Msg_Name_1 := Pname;
6420 Error_Msg_Name_2 := Id;
6421 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6425 end Check_Optional_Identifier;
6427 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6429 Check_Optional_Identifier (Arg, Name_Find (Id));
6430 end Check_Optional_Identifier;
6432 -------------------------------------
6433 -- Check_Static_Boolean_Expression --
6434 -------------------------------------
6436 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6438 if Present (Expr) then
6439 Analyze_And_Resolve (Expr, Standard_Boolean);
6441 if not Is_OK_Static_Expression (Expr) then
6443 ("expression of pragma % must be static", Expr);
6446 end Check_Static_Boolean_Expression;
6448 -----------------------------
6449 -- Check_Static_Constraint --
6450 -----------------------------
6452 -- Note: for convenience in writing this procedure, in addition to
6453 -- the officially (i.e. by spec) allowed argument which is always a
6454 -- constraint, it also allows ranges and discriminant associations.
6455 -- Above is not clear ???
6457 procedure Check_Static_Constraint (Constr : Node_Id) is
6459 procedure Require_Static (E : Node_Id);
6460 -- Require given expression to be static expression
6462 --------------------
6463 -- Require_Static --
6464 --------------------
6466 procedure Require_Static (E : Node_Id) is
6468 if not Is_OK_Static_Expression (E) then
6469 Flag_Non_Static_Expr
6470 ("non-static constraint not allowed in Unchecked_Union!", E);
6475 -- Start of processing for Check_Static_Constraint
6478 case Nkind (Constr) is
6479 when N_Discriminant_Association =>
6480 Require_Static (Expression (Constr));
6483 Require_Static (Low_Bound (Constr));
6484 Require_Static (High_Bound (Constr));
6486 when N_Attribute_Reference =>
6487 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6488 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6490 when N_Range_Constraint =>
6491 Check_Static_Constraint (Range_Expression (Constr));
6493 when N_Index_Or_Discriminant_Constraint =>
6497 IDC := First (Constraints (Constr));
6498 while Present (IDC) loop
6499 Check_Static_Constraint (IDC);
6507 end Check_Static_Constraint;
6509 --------------------------------------
6510 -- Check_Valid_Configuration_Pragma --
6511 --------------------------------------
6513 -- A configuration pragma must appear in the context clause of a
6514 -- compilation unit, and only other pragmas may precede it. Note that
6515 -- the test also allows use in a configuration pragma file.
6517 procedure Check_Valid_Configuration_Pragma is
6519 if not Is_Configuration_Pragma then
6520 Error_Pragma ("incorrect placement for configuration pragma%");
6522 end Check_Valid_Configuration_Pragma;
6524 -------------------------------------
6525 -- Check_Valid_Library_Unit_Pragma --
6526 -------------------------------------
6528 procedure Check_Valid_Library_Unit_Pragma is
6530 Parent_Node : Node_Id;
6531 Unit_Name : Entity_Id;
6532 Unit_Kind : Node_Kind;
6533 Unit_Node : Node_Id;
6534 Sindex : Source_File_Index;
6537 if not Is_List_Member (N) then
6541 Plist := List_Containing (N);
6542 Parent_Node := Parent (Plist);
6544 if Parent_Node = Empty then
6547 -- Case of pragma appearing after a compilation unit. In this case
6548 -- it must have an argument with the corresponding name and must
6549 -- be part of the following pragmas of its parent.
6551 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6552 if Plist /= Pragmas_After (Parent_Node) then
6555 elsif Arg_Count = 0 then
6557 ("argument required if outside compilation unit");
6560 Check_No_Identifiers;
6561 Check_Arg_Count (1);
6562 Unit_Node := Unit (Parent (Parent_Node));
6563 Unit_Kind := Nkind (Unit_Node);
6565 Analyze (Get_Pragma_Arg (Arg1));
6567 if Unit_Kind = N_Generic_Subprogram_Declaration
6568 or else Unit_Kind = N_Subprogram_Declaration
6570 Unit_Name := Defining_Entity (Unit_Node);
6572 elsif Unit_Kind in N_Generic_Instantiation then
6573 Unit_Name := Defining_Entity (Unit_Node);
6576 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6579 if Chars (Unit_Name) /=
6580 Chars (Entity (Get_Pragma_Arg (Arg1)))
6583 ("pragma% argument is not current unit name", Arg1);
6586 if Ekind (Unit_Name) = E_Package
6587 and then Present (Renamed_Entity (Unit_Name))
6589 Error_Pragma ("pragma% not allowed for renamed package");
6593 -- Pragma appears other than after a compilation unit
6596 -- Here we check for the generic instantiation case and also
6597 -- for the case of processing a generic formal package. We
6598 -- detect these cases by noting that the Sloc on the node
6599 -- does not belong to the current compilation unit.
6601 Sindex := Source_Index (Current_Sem_Unit);
6603 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6604 Rewrite (N, Make_Null_Statement (Loc));
6607 -- If before first declaration, the pragma applies to the
6608 -- enclosing unit, and the name if present must be this name.
6610 elsif Is_Before_First_Decl (N, Plist) then
6611 Unit_Node := Unit_Declaration_Node (Current_Scope);
6612 Unit_Kind := Nkind (Unit_Node);
6614 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6617 elsif Unit_Kind = N_Subprogram_Body
6618 and then not Acts_As_Spec (Unit_Node)
6622 elsif Nkind (Parent_Node) = N_Package_Body then
6625 elsif Nkind (Parent_Node) = N_Package_Specification
6626 and then Plist = Private_Declarations (Parent_Node)
6630 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6631 or else Nkind (Parent_Node) =
6632 N_Generic_Subprogram_Declaration)
6633 and then Plist = Generic_Formal_Declarations (Parent_Node)
6637 elsif Arg_Count > 0 then
6638 Analyze (Get_Pragma_Arg (Arg1));
6640 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6642 ("name in pragma% must be enclosing unit", Arg1);
6645 -- It is legal to have no argument in this context
6651 -- Error if not before first declaration. This is because a
6652 -- library unit pragma argument must be the name of a library
6653 -- unit (RM 10.1.5(7)), but the only names permitted in this
6654 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6655 -- generic subprogram declarations or generic instantiations.
6659 ("pragma% misplaced, must be before first declaration");
6663 end Check_Valid_Library_Unit_Pragma;
6669 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6670 Clist : constant Node_Id := Component_List (Variant);
6674 Comp := First_Non_Pragma (Component_Items (Clist));
6675 while Present (Comp) loop
6676 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6677 Next_Non_Pragma (Comp);
6681 ---------------------------
6682 -- Ensure_Aggregate_Form --
6683 ---------------------------
6685 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6686 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6687 Expr : constant Node_Id := Expression (Arg);
6688 Loc : constant Source_Ptr := Sloc (Expr);
6689 Comps : List_Id := No_List;
6690 Exprs : List_Id := No_List;
6691 Nam : Name_Id := No_Name;
6692 Nam_Loc : Source_Ptr;
6695 -- The pragma argument is in positional form:
6697 -- pragma Depends (Nam => ...)
6701 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6702 -- argument association.
6704 if Nkind (Arg) = N_Pragma_Argument_Association then
6706 Nam_Loc := Sloc (Arg);
6708 -- Remove the pragma argument name as this will be captured in the
6711 Set_Chars (Arg, No_Name);
6714 -- The argument is already in aggregate form, but the presence of a
6715 -- name causes this to be interpreted as named association which in
6716 -- turn must be converted into an aggregate.
6718 -- pragma Global (In_Out => (A, B, C))
6722 -- pragma Global ((In_Out => (A, B, C)))
6724 -- aggregate aggregate
6726 if Nkind (Expr) = N_Aggregate then
6727 if Nam = No_Name then
6731 -- Do not transform a null argument into an aggregate as N_Null has
6732 -- special meaning in formal verification pragmas.
6734 elsif Nkind (Expr) = N_Null then
6738 -- Everything comes from source if the original comes from source
6740 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6742 -- Positional argument is transformed into an aggregate with an
6743 -- Expressions list.
6745 if Nam = No_Name then
6746 Exprs := New_List (Relocate_Node (Expr));
6748 -- An associative argument is transformed into an aggregate with
6749 -- Component_Associations.
6753 Make_Component_Association (Loc,
6754 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6755 Expression => Relocate_Node (Expr)));
6758 Set_Expression (Arg,
6759 Make_Aggregate (Loc,
6760 Component_Associations => Comps,
6761 Expressions => Exprs));
6763 -- Restore Comes_From_Source default
6765 Set_Comes_From_Source_Default (CFSD);
6766 end Ensure_Aggregate_Form;
6772 procedure Error_Pragma (Msg : String) is
6774 Error_Msg_Name_1 := Pname;
6775 Error_Msg_N (Fix_Error (Msg), N);
6779 ----------------------
6780 -- Error_Pragma_Arg --
6781 ----------------------
6783 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6785 Error_Msg_Name_1 := Pname;
6786 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6788 end Error_Pragma_Arg;
6790 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6792 Error_Msg_Name_1 := Pname;
6793 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6794 Error_Pragma_Arg (Msg2, Arg);
6795 end Error_Pragma_Arg;
6797 ----------------------------
6798 -- Error_Pragma_Arg_Ident --
6799 ----------------------------
6801 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6803 Error_Msg_Name_1 := Pname;
6804 Error_Msg_N (Fix_Error (Msg), Arg);
6806 end Error_Pragma_Arg_Ident;
6808 ----------------------
6809 -- Error_Pragma_Ref --
6810 ----------------------
6812 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6814 Error_Msg_Name_1 := Pname;
6815 Error_Msg_Sloc := Sloc (Ref);
6816 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6818 end Error_Pragma_Ref;
6820 ------------------------
6821 -- Find_Lib_Unit_Name --
6822 ------------------------
6824 function Find_Lib_Unit_Name return Entity_Id is
6826 -- Return inner compilation unit entity, for case of nested
6827 -- categorization pragmas. This happens in generic unit.
6829 if Nkind (Parent (N)) = N_Package_Specification
6830 and then Defining_Entity (Parent (N)) /= Current_Scope
6832 return Defining_Entity (Parent (N));
6834 return Current_Scope;
6836 end Find_Lib_Unit_Name;
6838 ----------------------------
6839 -- Find_Program_Unit_Name --
6840 ----------------------------
6842 procedure Find_Program_Unit_Name (Id : Node_Id) is
6843 Unit_Name : Entity_Id;
6844 Unit_Kind : Node_Kind;
6845 P : constant Node_Id := Parent (N);
6848 if Nkind (P) = N_Compilation_Unit then
6849 Unit_Kind := Nkind (Unit (P));
6851 if Unit_Kind in N_Subprogram_Declaration
6852 | N_Package_Declaration
6853 | N_Generic_Declaration
6855 Unit_Name := Defining_Entity (Unit (P));
6857 if Chars (Id) = Chars (Unit_Name) then
6858 Set_Entity (Id, Unit_Name);
6859 Set_Etype (Id, Etype (Unit_Name));
6861 Set_Etype (Id, Any_Type);
6863 ("cannot find program unit referenced by pragma%");
6867 Set_Etype (Id, Any_Type);
6868 Error_Pragma ("pragma% inapplicable to this unit");
6874 end Find_Program_Unit_Name;
6876 -----------------------------------------
6877 -- Find_Unique_Parameterless_Procedure --
6878 -----------------------------------------
6880 function Find_Unique_Parameterless_Procedure
6882 Arg : Node_Id) return Entity_Id
6884 Proc : Entity_Id := Empty;
6887 -- The body of this procedure needs some comments ???
6889 if not Is_Entity_Name (Name) then
6891 ("argument of pragma% must be entity name", Arg);
6893 elsif not Is_Overloaded (Name) then
6894 Proc := Entity (Name);
6896 if Ekind (Proc) /= E_Procedure
6897 or else Present (First_Formal (Proc))
6900 ("argument of pragma% must be parameterless procedure", Arg);
6905 Found : Boolean := False;
6907 Index : Interp_Index;
6910 Get_First_Interp (Name, Index, It);
6911 while Present (It.Nam) loop
6914 if Ekind (Proc) = E_Procedure
6915 and then No (First_Formal (Proc))
6919 Set_Entity (Name, Proc);
6920 Set_Is_Overloaded (Name, False);
6923 ("ambiguous handler name for pragma% ", Arg);
6927 Get_Next_Interp (Index, It);
6932 ("argument of pragma% must be parameterless procedure",
6935 Proc := Entity (Name);
6941 end Find_Unique_Parameterless_Procedure;
6947 function Fix_Error (Msg : String) return String is
6948 Res : String (Msg'Range) := Msg;
6949 Res_Last : Natural := Msg'Last;
6953 -- If we have a rewriting of another pragma, go to that pragma
6955 if Is_Rewrite_Substitution (N)
6956 and then Nkind (Original_Node (N)) = N_Pragma
6958 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6961 -- Case where pragma comes from an aspect specification
6963 if From_Aspect_Specification (N) then
6965 -- Change appearence of "pragma" in message to "aspect"
6968 while J <= Res_Last - 5 loop
6969 if Res (J .. J + 5) = "pragma" then
6970 Res (J .. J + 5) := "aspect";
6978 -- Change "argument of" at start of message to "entity for"
6981 and then Res (Res'First .. Res'First + 10) = "argument of"
6983 Res (Res'First .. Res'First + 9) := "entity for";
6984 Res (Res'First + 10 .. Res_Last - 1) :=
6985 Res (Res'First + 11 .. Res_Last);
6986 Res_Last := Res_Last - 1;
6989 -- Change "argument" at start of message to "entity"
6992 and then Res (Res'First .. Res'First + 7) = "argument"
6994 Res (Res'First .. Res'First + 5) := "entity";
6995 Res (Res'First + 6 .. Res_Last - 2) :=
6996 Res (Res'First + 8 .. Res_Last);
6997 Res_Last := Res_Last - 2;
7000 -- Get name from corresponding aspect
7002 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7005 -- Return possibly modified message
7007 return Res (Res'First .. Res_Last);
7010 -------------------------
7011 -- Gather_Associations --
7012 -------------------------
7014 procedure Gather_Associations
7016 Args : out Args_List)
7021 -- Initialize all parameters to Empty
7023 for J in Args'Range loop
7027 -- That's all we have to do if there are no argument associations
7029 if No (Pragma_Argument_Associations (N)) then
7033 -- Otherwise first deal with any positional parameters present
7035 Arg := First (Pragma_Argument_Associations (N));
7036 for Index in Args'Range loop
7037 exit when No (Arg) or else Chars (Arg) /= No_Name;
7038 Args (Index) := Get_Pragma_Arg (Arg);
7042 -- Positional parameters all processed, if any left, then we
7043 -- have too many positional parameters.
7045 if Present (Arg) and then Chars (Arg) = No_Name then
7047 ("too many positional associations for pragma%", Arg);
7050 -- Process named parameters if any are present
7052 while Present (Arg) loop
7053 if Chars (Arg) = No_Name then
7055 ("positional association cannot follow named association",
7059 for Index in Names'Range loop
7060 if Names (Index) = Chars (Arg) then
7061 if Present (Args (Index)) then
7063 ("duplicate argument association for pragma%", Arg);
7065 Args (Index) := Get_Pragma_Arg (Arg);
7070 if Index = Names'Last then
7071 Error_Msg_Name_1 := Pname;
7072 Error_Msg_N ("pragma% does not allow & argument", Arg);
7074 -- Check for possible misspelling
7076 for Index1 in Names'Range loop
7077 if Is_Bad_Spelling_Of
7078 (Chars (Arg), Names (Index1))
7080 Error_Msg_Name_1 := Names (Index1);
7081 Error_Msg_N -- CODEFIX
7082 ("\possible misspelling of%", Arg);
7094 end Gather_Associations;
7100 procedure GNAT_Pragma is
7102 -- We need to check the No_Implementation_Pragmas restriction for
7103 -- the case of a pragma from source. Note that the case of aspects
7104 -- generating corresponding pragmas marks these pragmas as not being
7105 -- from source, so this test also catches that case.
7107 if Comes_From_Source (N) then
7108 Check_Restriction (No_Implementation_Pragmas, N);
7112 --------------------------
7113 -- Is_Before_First_Decl --
7114 --------------------------
7116 function Is_Before_First_Decl
7117 (Pragma_Node : Node_Id;
7118 Decls : List_Id) return Boolean
7120 Item : Node_Id := First (Decls);
7123 -- Only other pragmas can come before this pragma, but they might
7124 -- have been rewritten so check the original node.
7127 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7130 elsif Item = Pragma_Node then
7136 end Is_Before_First_Decl;
7138 -----------------------------
7139 -- Is_Configuration_Pragma --
7140 -----------------------------
7142 -- A configuration pragma must appear in the context clause of a
7143 -- compilation unit, and only other pragmas may precede it. Note that
7144 -- the test below also permits use in a configuration pragma file.
7146 function Is_Configuration_Pragma return Boolean is
7147 Lis : constant List_Id := List_Containing (N);
7148 Par : constant Node_Id := Parent (N);
7152 -- If no parent, then we are in the configuration pragma file,
7153 -- so the placement is definitely appropriate.
7158 -- Otherwise we must be in the context clause of a compilation unit
7159 -- and the only thing allowed before us in the context list is more
7160 -- configuration pragmas.
7162 elsif Nkind (Par) = N_Compilation_Unit
7163 and then Context_Items (Par) = Lis
7170 elsif Nkind (Prg) /= N_Pragma then
7180 end Is_Configuration_Pragma;
7182 --------------------------
7183 -- Is_In_Context_Clause --
7184 --------------------------
7186 function Is_In_Context_Clause return Boolean is
7188 Parent_Node : Node_Id;
7191 if not Is_List_Member (N) then
7195 Plist := List_Containing (N);
7196 Parent_Node := Parent (Plist);
7198 if Parent_Node = Empty
7199 or else Nkind (Parent_Node) /= N_Compilation_Unit
7200 or else Context_Items (Parent_Node) /= Plist
7207 end Is_In_Context_Clause;
7209 ---------------------------------
7210 -- Is_Static_String_Expression --
7211 ---------------------------------
7213 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7214 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7215 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7218 Analyze_And_Resolve (Argx);
7220 -- Special case Ada 83, where the expression will never be static,
7221 -- but we will return true if we had a string literal to start with.
7223 if Ada_Version = Ada_83 then
7226 -- Normal case, true only if we end up with a string literal that
7227 -- is marked as being the result of evaluating a static expression.
7230 return Is_OK_Static_Expression (Argx)
7231 and then Nkind (Argx) = N_String_Literal;
7234 end Is_Static_String_Expression;
7236 ----------------------
7237 -- Pragma_Misplaced --
7238 ----------------------
7240 procedure Pragma_Misplaced is
7242 Error_Pragma ("incorrect placement of pragma%");
7243 end Pragma_Misplaced;
7245 ------------------------------------------------
7246 -- Process_Atomic_Independent_Shared_Volatile --
7247 ------------------------------------------------
7249 procedure Process_Atomic_Independent_Shared_Volatile is
7250 procedure Check_Full_Access_Only (Ent : Entity_Id);
7251 -- Apply legality checks to type or object Ent subject to the
7252 -- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)).
7254 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7255 -- Appropriately set flags on the given entity, either an array or
7256 -- record component, or an object declaration) according to the
7259 procedure Mark_Type (Ent : Entity_Id);
7260 -- Appropriately set flags on the given entity, a type
7262 procedure Set_Atomic_VFA (Ent : Entity_Id);
7263 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7264 -- no explicit alignment was given, set alignment to unknown, since
7265 -- back end knows what the alignment requirements are for atomic and
7266 -- full access arrays. Note: this is necessary for derived types.
7268 -------------------------
7269 -- Check_Full_Access_Only --
7270 -------------------------
7272 procedure Check_Full_Access_Only (Ent : Entity_Id) is
7275 Full_Access_Subcomponent : exception;
7276 -- Exception raised if a full access subcomponent is found
7278 Generic_Type_Subcomponent : exception;
7279 -- Exception raised if a subcomponent with generic type is found
7281 procedure Check_Subcomponents (Typ : Entity_Id);
7282 -- Apply checks to subcomponents recursively
7284 -------------------------
7285 -- Check_Subcomponents --
7286 -------------------------
7288 procedure Check_Subcomponents (Typ : Entity_Id) is
7292 if Is_Array_Type (Typ) then
7293 Comp := Component_Type (Typ);
7295 if Has_Atomic_Components (Typ)
7296 or else Is_Full_Access (Comp)
7298 raise Full_Access_Subcomponent;
7300 elsif Is_Generic_Type (Comp) then
7301 raise Generic_Type_Subcomponent;
7304 -- Recurse on the component type
7306 Check_Subcomponents (Comp);
7308 elsif Is_Record_Type (Typ) then
7309 Comp := First_Component_Or_Discriminant (Typ);
7310 while Present (Comp) loop
7312 if Is_Full_Access (Comp)
7313 or else Is_Full_Access (Etype (Comp))
7315 raise Full_Access_Subcomponent;
7317 elsif Is_Generic_Type (Etype (Comp)) then
7318 raise Generic_Type_Subcomponent;
7321 -- Recurse on the component type
7323 Check_Subcomponents (Etype (Comp));
7325 Next_Component_Or_Discriminant (Comp);
7328 end Check_Subcomponents;
7330 -- Start of processing for Check_Full_Access_Only
7333 -- Fetch the type in case we are dealing with an object or
7336 if Is_Type (Ent) then
7339 pragma Assert (Is_Object (Ent)
7341 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7346 if not Is_Volatile (Ent) and then not Is_Volatile (Typ) then
7348 ("cannot have Full_Access_Only without Volatile/Atomic "
7353 -- Check all the subcomponents of the type recursively, if any
7355 Check_Subcomponents (Typ);
7358 when Full_Access_Subcomponent =>
7360 ("cannot have Full_Access_Only with full access subcomponent "
7363 when Generic_Type_Subcomponent =>
7365 ("cannot have Full_Access_Only with subcomponent of generic "
7366 & "type (RM C.6(8.2))");
7368 end Check_Full_Access_Only;
7370 ------------------------------
7371 -- Mark_Component_Or_Object --
7372 ------------------------------
7374 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7376 if Prag_Id = Pragma_Atomic
7377 or else Prag_Id = Pragma_Shared
7378 or else Prag_Id = Pragma_Volatile_Full_Access
7380 if Prag_Id = Pragma_Volatile_Full_Access then
7381 Set_Is_Volatile_Full_Access (Ent);
7383 Set_Is_Atomic (Ent);
7386 -- If the object declaration has an explicit initialization, a
7387 -- temporary may have to be created to hold the expression, to
7388 -- ensure that access to the object remains atomic.
7390 if Nkind (Parent (Ent)) = N_Object_Declaration
7391 and then Present (Expression (Parent (Ent)))
7393 Set_Has_Delayed_Freeze (Ent);
7397 -- Atomic/Shared/Volatile_Full_Access imply Independent
7399 if Prag_Id /= Pragma_Volatile then
7400 Set_Is_Independent (Ent);
7402 if Prag_Id = Pragma_Independent then
7403 Record_Independence_Check (N, Ent);
7407 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7409 if Prag_Id /= Pragma_Independent then
7410 Set_Is_Volatile (Ent);
7411 Set_Treat_As_Volatile (Ent);
7413 end Mark_Component_Or_Object;
7419 procedure Mark_Type (Ent : Entity_Id) is
7421 -- Attribute belongs on the base type. If the view of the type is
7422 -- currently private, it also belongs on the underlying type.
7424 -- In Ada 2020, the pragma can apply to a formal type, for which
7425 -- there may be no underlying type.
7427 if Prag_Id = Pragma_Atomic
7428 or else Prag_Id = Pragma_Shared
7429 or else Prag_Id = Pragma_Volatile_Full_Access
7431 Set_Atomic_VFA (Ent);
7432 Set_Atomic_VFA (Base_Type (Ent));
7434 if not Is_Generic_Type (Ent) then
7435 Set_Atomic_VFA (Underlying_Type (Ent));
7439 -- Atomic/Shared/Volatile_Full_Access imply Independent
7441 if Prag_Id /= Pragma_Volatile then
7442 Set_Is_Independent (Ent);
7443 Set_Is_Independent (Base_Type (Ent));
7445 if not Is_Generic_Type (Ent) then
7446 Set_Is_Independent (Underlying_Type (Ent));
7448 if Prag_Id = Pragma_Independent then
7449 Record_Independence_Check (N, Base_Type (Ent));
7454 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7456 if Prag_Id /= Pragma_Independent then
7457 Set_Is_Volatile (Ent);
7458 Set_Is_Volatile (Base_Type (Ent));
7460 if not Is_Generic_Type (Ent) then
7461 Set_Is_Volatile (Underlying_Type (Ent));
7462 Set_Treat_As_Volatile (Underlying_Type (Ent));
7465 Set_Treat_As_Volatile (Ent);
7468 -- Apply Volatile to the composite type's individual components,
7471 if Prag_Id = Pragma_Volatile
7472 and then Is_Record_Type (Etype (Ent))
7477 Comp := First_Component (Ent);
7478 while Present (Comp) loop
7479 Mark_Component_Or_Object (Comp);
7481 Next_Component (Comp);
7487 --------------------
7488 -- Set_Atomic_VFA --
7489 --------------------
7491 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7493 if Prag_Id = Pragma_Volatile_Full_Access then
7494 Set_Is_Volatile_Full_Access (Ent);
7496 Set_Is_Atomic (Ent);
7499 if not Has_Alignment_Clause (Ent) then
7500 Set_Alignment (Ent, Uint_0);
7510 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7513 Check_Ada_83_Warning;
7514 Check_No_Identifiers;
7515 Check_Arg_Count (1);
7516 Check_Arg_Is_Local_Name (Arg1);
7517 E_Arg := Get_Pragma_Arg (Arg1);
7519 if Etype (E_Arg) = Any_Type then
7523 E := Entity (E_Arg);
7524 Decl := Declaration_Node (E);
7526 -- A pragma that applies to a Ghost entity becomes Ghost for the
7527 -- purposes of legality checks and removal of ignored Ghost code.
7529 Mark_Ghost_Pragma (N, E);
7531 -- Check duplicate before we chain ourselves
7533 Check_Duplicate_Pragma (E);
7535 -- Check the constraints of Full_Access_Only in Ada 2020. Note that
7536 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
7537 -- aspect subsumes the Volatile aspect and 2) nesting is supported
7538 -- for this aspect and the outermost enclosing VFA object prevails.
7540 -- Note also that we used to forbid specifying both Atomic and VFA on
7541 -- the same type or object, but the restriction has been lifted in
7542 -- light of the semantics of Full_Access_Only and Atomic in Ada 2020.
7544 if Prag_Id = Pragma_Volatile_Full_Access
7545 and then From_Aspect_Specification (N)
7547 Get_Aspect_Id (Corresponding_Aspect (N)) = Aspect_Full_Access_Only
7549 Check_Full_Access_Only (E);
7552 -- The following check is only relevant when SPARK_Mode is on as
7553 -- this is not a standard Ada legality rule. Pragma Volatile can
7554 -- only apply to a full type declaration or an object declaration
7555 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7556 -- untagged derived types that are rewritten as subtypes of their
7557 -- respective root types.
7560 and then Prag_Id = Pragma_Volatile
7561 and then Nkind (Original_Node (Decl)) not in
7562 N_Full_Type_Declaration |
7563 N_Formal_Type_Declaration |
7564 N_Object_Declaration |
7565 N_Single_Protected_Declaration |
7566 N_Single_Task_Declaration
7569 ("argument of pragma % must denote a full type or object "
7570 & "declaration", Arg1);
7573 -- Deal with the case where the pragma/attribute is applied to a type
7576 if Rep_Item_Too_Early (E, N)
7577 or else Rep_Item_Too_Late (E, N)
7581 Check_First_Subtype (Arg1);
7586 -- Deal with the case where the pragma/attribute applies to a
7587 -- component or object declaration.
7589 elsif Nkind (Decl) = N_Object_Declaration
7590 or else (Nkind (Decl) = N_Component_Declaration
7591 and then Original_Record_Component (E) = E)
7593 if Rep_Item_Too_Late (E, N) then
7597 Mark_Component_Or_Object (E);
7599 -- In other cases give an error
7602 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7604 end Process_Atomic_Independent_Shared_Volatile;
7606 -------------------------------------------
7607 -- Process_Compile_Time_Warning_Or_Error --
7608 -------------------------------------------
7610 procedure Process_Compile_Time_Warning_Or_Error is
7611 P : Node_Id := Parent (N);
7612 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7615 Check_Arg_Count (2);
7616 Check_No_Identifiers;
7617 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7618 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7620 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7621 -- a Check pragma in GNATprove mode, handled as an assumption in
7622 -- GNATprove. This is correct as the compiler will issue an error
7623 -- if the condition cannot be statically evaluated to False.
7624 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7625 -- same information as the compiler (in particular regarding size of
7626 -- objects decided in gigi) so it makes no sense to issue a warning
7629 if GNATprove_Mode then
7630 if Prag_Id = Pragma_Compile_Time_Error then
7634 -- Implement Compile_Time_Error by generating
7635 -- a corresponding Check pragma:
7637 -- pragma Check (name, condition);
7639 -- where name is the identifier matching the pragma name. So
7640 -- rewrite pragma in this manner and analyze the result.
7642 New_Args := New_List
7643 (Make_Pragma_Argument_Association
7645 Expression => Make_Identifier (Loc, Pname)),
7646 Make_Pragma_Argument_Association
7648 Expression => Arg1x));
7650 -- Rewrite as Check pragma
7654 Chars => Name_Check,
7655 Pragma_Argument_Associations => New_Args));
7661 Rewrite (N, Make_Null_Statement (Loc));
7667 -- If the condition is known at compile time (now), validate it now.
7668 -- Otherwise, register the expression for validation after the back
7669 -- end has been called, because it might be known at compile time
7670 -- then. For example, if the expression is "Record_Type'Size /= 32"
7671 -- it might be known after the back end has determined the size of
7672 -- Record_Type. We do not defer validation if we're inside a generic
7673 -- unit, because we will have more information in the instances.
7675 if Compile_Time_Known_Value (Arg1x) then
7676 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7678 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7680 if Nkind (P) in N_Package_Body | N_Subprogram_Body then
7681 P := Corresponding_Spec (P);
7688 Defer_Compile_Time_Warning_Error_To_BE (N);
7691 end Process_Compile_Time_Warning_Or_Error;
7693 ------------------------
7694 -- Process_Convention --
7695 ------------------------
7697 procedure Process_Convention
7698 (C : out Convention_Id;
7699 Ent : out Entity_Id)
7703 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7704 -- Called if we have more than one Export/Import/Convention pragma.
7705 -- This is generally illegal, but we have a special case of allowing
7706 -- Import and Interface to coexist if they specify the convention in
7707 -- a consistent manner. We are allowed to do this, since Interface is
7708 -- an implementation defined pragma, and we choose to do it since we
7709 -- know Rational allows this combination. S is the entity id of the
7710 -- subprogram in question. This procedure also sets the special flag
7711 -- Import_Interface_Present in both pragmas in the case where we do
7712 -- have matching Import and Interface pragmas.
7714 procedure Set_Convention_From_Pragma (E : Entity_Id);
7715 -- Set convention in entity E, and also flag that the entity has a
7716 -- convention pragma. If entity is for a private or incomplete type,
7717 -- also set convention and flag on underlying type. This procedure
7718 -- also deals with the special case of C_Pass_By_Copy convention,
7719 -- and error checks for inappropriate convention specification.
7721 -------------------------------
7722 -- Diagnose_Multiple_Pragmas --
7723 -------------------------------
7725 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7726 Pdec : constant Node_Id := Declaration_Node (S);
7730 function Same_Convention (Decl : Node_Id) return Boolean;
7731 -- Decl is a pragma node. This function returns True if this
7732 -- pragma has a first argument that is an identifier with a
7733 -- Chars field corresponding to the Convention_Id C.
7735 function Same_Name (Decl : Node_Id) return Boolean;
7736 -- Decl is a pragma node. This function returns True if this
7737 -- pragma has a second argument that is an identifier with a
7738 -- Chars field that matches the Chars of the current subprogram.
7740 ---------------------
7741 -- Same_Convention --
7742 ---------------------
7744 function Same_Convention (Decl : Node_Id) return Boolean is
7745 Arg1 : constant Node_Id :=
7746 First (Pragma_Argument_Associations (Decl));
7749 if Present (Arg1) then
7751 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7753 if Nkind (Arg) = N_Identifier
7754 and then Is_Convention_Name (Chars (Arg))
7755 and then Get_Convention_Id (Chars (Arg)) = C
7763 end Same_Convention;
7769 function Same_Name (Decl : Node_Id) return Boolean is
7770 Arg1 : constant Node_Id :=
7771 First (Pragma_Argument_Associations (Decl));
7779 Arg2 := Next (Arg1);
7786 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7788 if Nkind (Arg) = N_Identifier
7789 and then Chars (Arg) = Chars (S)
7798 -- Start of processing for Diagnose_Multiple_Pragmas
7803 -- Definitely give message if we have Convention/Export here
7805 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7808 -- If we have an Import or Export, scan back from pragma to
7809 -- find any previous pragma applying to the same procedure.
7810 -- The scan will be terminated by the start of the list, or
7811 -- hitting the subprogram declaration. This won't allow one
7812 -- pragma to appear in the public part and one in the private
7813 -- part, but that seems very unlikely in practice.
7817 while Present (Decl) and then Decl /= Pdec loop
7819 -- Look for pragma with same name as us
7821 if Nkind (Decl) = N_Pragma
7822 and then Same_Name (Decl)
7824 -- Give error if same as our pragma or Export/Convention
7826 if Pragma_Name_Unmapped (Decl)
7829 | Pragma_Name_Unmapped (N)
7833 -- Case of Import/Interface or the other way round
7835 elsif Pragma_Name_Unmapped (Decl)
7836 in Name_Interface | Name_Import
7838 -- Here we know that we have Import and Interface. It
7839 -- doesn't matter which way round they are. See if
7840 -- they specify the same convention. If so, all OK,
7841 -- and set special flags to stop other messages
7843 if Same_Convention (Decl) then
7844 Set_Import_Interface_Present (N);
7845 Set_Import_Interface_Present (Decl);
7848 -- If different conventions, special message
7851 Error_Msg_Sloc := Sloc (Decl);
7853 ("convention differs from that given#", Arg1);
7863 -- Give message if needed if we fall through those tests
7864 -- except on Relaxed_RM_Semantics where we let go: either this
7865 -- is a case accepted/ignored by other Ada compilers (e.g.
7866 -- a mix of Convention and Import), or another error will be
7867 -- generated later (e.g. using both Import and Export).
7869 if Err and not Relaxed_RM_Semantics then
7871 ("at most one Convention/Export/Import pragma is allowed",
7874 end Diagnose_Multiple_Pragmas;
7876 --------------------------------
7877 -- Set_Convention_From_Pragma --
7878 --------------------------------
7880 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7882 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7883 -- for an overridden dispatching operation. Technically this is
7884 -- an amendment and should only be done in Ada 2005 mode. However,
7885 -- this is clearly a mistake, since the problem that is addressed
7886 -- by this AI is that there is a clear gap in the RM.
7888 if Is_Dispatching_Operation (E)
7889 and then Present (Overridden_Operation (E))
7890 and then C /= Convention (Overridden_Operation (E))
7893 ("cannot change convention for overridden dispatching "
7894 & "operation", Arg1);
7896 -- Special check for convention Stdcall: a dispatching call is not
7897 -- allowed. A dispatching subprogram cannot be used to interface
7898 -- to the Win32 API, so this check actually does not impose any
7899 -- effective restriction.
7901 elsif Is_Dispatching_Operation (E)
7902 and then C = Convention_Stdcall
7904 -- Note: make this unconditional so that if there is more
7905 -- than one call to which the pragma applies, we get a
7906 -- message for each call. Also don't use Error_Pragma,
7907 -- so that we get multiple messages.
7909 Error_Msg_Sloc := Sloc (E);
7911 ("dispatching subprogram# cannot use Stdcall convention!",
7912 Get_Pragma_Arg (Arg1));
7915 -- Set the convention
7917 Set_Convention (E, C);
7918 Set_Has_Convention_Pragma (E);
7920 -- For the case of a record base type, also set the convention of
7921 -- any anonymous access types declared in the record which do not
7922 -- currently have a specified convention.
7923 -- Similarly for an array base type and anonymous access types
7926 if Is_Base_Type (E) then
7927 if Is_Record_Type (E) then
7932 Comp := First_Component (E);
7933 while Present (Comp) loop
7934 if Present (Etype (Comp))
7936 Ekind (Etype (Comp)) in
7937 E_Anonymous_Access_Type |
7938 E_Anonymous_Access_Subprogram_Type
7939 and then not Has_Convention_Pragma (Comp)
7941 Set_Convention (Comp, C);
7944 Next_Component (Comp);
7948 elsif Is_Array_Type (E)
7949 and then Ekind (Component_Type (E)) in
7950 E_Anonymous_Access_Type |
7951 E_Anonymous_Access_Subprogram_Type
7953 Set_Convention (Designated_Type (Component_Type (E)), C);
7957 -- Deal with incomplete/private type case, where underlying type
7958 -- is available, so set convention of that underlying type.
7960 if Is_Incomplete_Or_Private_Type (E)
7961 and then Present (Underlying_Type (E))
7963 Set_Convention (Underlying_Type (E), C);
7964 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7967 -- A class-wide type should inherit the convention of the specific
7968 -- root type (although this isn't specified clearly by the RM).
7970 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7971 Set_Convention (Class_Wide_Type (E), C);
7974 -- If the entity is a record type, then check for special case of
7975 -- C_Pass_By_Copy, which is treated the same as C except that the
7976 -- special record flag is set. This convention is only permitted
7977 -- on record types (see AI95-00131).
7979 if Cname = Name_C_Pass_By_Copy then
7980 if Is_Record_Type (E) then
7981 Set_C_Pass_By_Copy (Base_Type (E));
7982 elsif Is_Incomplete_Or_Private_Type (E)
7983 and then Is_Record_Type (Underlying_Type (E))
7985 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7988 ("C_Pass_By_Copy convention allowed only for record type",
7993 -- If the entity is a derived boolean type, check for the special
7994 -- case of convention C, C++, or Fortran, where we consider any
7995 -- nonzero value to represent true.
7997 if Is_Discrete_Type (E)
7998 and then Root_Type (Etype (E)) = Standard_Boolean
8004 C = Convention_Fortran)
8006 Set_Nonzero_Is_True (Base_Type (E));
8008 end Set_Convention_From_Pragma;
8012 Comp_Unit : Unit_Number_Type;
8018 -- Start of processing for Process_Convention
8021 Check_At_Least_N_Arguments (2);
8022 Check_Optional_Identifier (Arg1, Name_Convention);
8023 Check_Arg_Is_Identifier (Arg1);
8024 Cname := Chars (Get_Pragma_Arg (Arg1));
8026 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8027 -- tested again below to set the critical flag).
8029 if Cname = Name_C_Pass_By_Copy then
8032 -- Otherwise we must have something in the standard convention list
8034 elsif Is_Convention_Name (Cname) then
8035 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8037 -- Otherwise warn on unrecognized convention
8040 if Warn_On_Export_Import then
8042 ("??unrecognized convention name, C assumed",
8043 Get_Pragma_Arg (Arg1));
8049 Check_Optional_Identifier (Arg2, Name_Entity);
8050 Check_Arg_Is_Local_Name (Arg2);
8052 Id := Get_Pragma_Arg (Arg2);
8055 if not Is_Entity_Name (Id) then
8056 Error_Pragma_Arg ("entity name required", Arg2);
8061 -- Set entity to return
8065 -- Ada_Pass_By_Copy special checking
8067 if C = Convention_Ada_Pass_By_Copy then
8068 if not Is_First_Subtype (E) then
8070 ("convention `Ada_Pass_By_Copy` only allowed for types",
8074 if Is_By_Reference_Type (E) then
8076 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8080 -- Ada_Pass_By_Reference special checking
8082 elsif C = Convention_Ada_Pass_By_Reference then
8083 if not Is_First_Subtype (E) then
8085 ("convention `Ada_Pass_By_Reference` only allowed for types",
8089 if Is_By_Copy_Type (E) then
8091 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8096 -- Go to renamed subprogram if present, since convention applies to
8097 -- the actual renamed entity, not to the renaming entity. If the
8098 -- subprogram is inherited, go to parent subprogram.
8100 if Is_Subprogram (E)
8101 and then Present (Alias (E))
8103 if Nkind (Parent (Declaration_Node (E))) =
8104 N_Subprogram_Renaming_Declaration
8106 if Scope (E) /= Scope (Alias (E)) then
8108 ("cannot apply pragma% to non-local entity&#", E);
8113 elsif Nkind (Parent (E)) in
8114 N_Full_Type_Declaration | N_Private_Extension_Declaration
8115 and then Scope (E) = Scope (Alias (E))
8119 -- Return the parent subprogram the entity was inherited from
8125 -- Check that we are not applying this to a specless body. Relax this
8126 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8128 if Is_Subprogram (E)
8129 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8130 and then not Relaxed_RM_Semantics
8133 ("pragma% requires separate spec and must come before body");
8136 -- Check that we are not applying this to a named constant
8138 if Is_Named_Number (E) then
8139 Error_Msg_Name_1 := Pname;
8141 ("cannot apply pragma% to named constant!",
8142 Get_Pragma_Arg (Arg2));
8144 ("\supply appropriate type for&!", Arg2);
8147 if Ekind (E) = E_Enumeration_Literal then
8148 Error_Pragma ("enumeration literal not allowed for pragma%");
8151 -- Check for rep item appearing too early or too late
8153 if Etype (E) = Any_Type
8154 or else Rep_Item_Too_Early (E, N)
8158 elsif Present (Underlying_Type (E)) then
8159 E := Underlying_Type (E);
8162 if Rep_Item_Too_Late (E, N) then
8166 if Has_Convention_Pragma (E) then
8167 Diagnose_Multiple_Pragmas (E);
8169 elsif Convention (E) = Convention_Protected
8170 or else Ekind (Scope (E)) = E_Protected_Type
8173 ("a protected operation cannot be given a different convention",
8177 -- For Intrinsic, a subprogram is required
8179 if C = Convention_Intrinsic
8180 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8182 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8184 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8185 if From_Aspect_Specification (N) then
8187 ("entity for aspect% must be a subprogram", Arg2);
8190 ("second argument of pragma% must be a subprogram", Arg2);
8194 -- Special checks for C_Variadic_n
8196 elsif C in Convention_C_Variadic then
8198 -- Several allowed cases
8200 if Is_Subprogram_Or_Generic_Subprogram (E) then
8203 -- An access to subprogram is also allowed
8205 elsif Is_Access_Type (E)
8206 and then Ekind (Designated_Type (E)) = E_Subprogram_Type
8208 Subp := Designated_Type (E);
8210 -- Allow internal call to set convention of subprogram type
8212 elsif Ekind (E) = E_Subprogram_Type then
8217 ("argument of pragma% must be subprogram or access type",
8222 -- ISO C requires a named parameter before the ellipsis, so a
8223 -- variadic C function taking 0 fixed parameter cannot exist.
8225 if C = Convention_C_Variadic_0 then
8228 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8229 Get_Pragma_Arg (Arg2));
8231 -- Now check the number of parameters of the subprogram and give
8232 -- an error if it is lower than n.
8234 elsif Present (Subp) then
8236 Minimum : constant Nat :=
8237 Convention_Id'Pos (C) -
8238 Convention_Id'Pos (Convention_C_Variadic_0);
8245 Formal := First_Formal (Subp);
8246 while Present (Formal) loop
8248 Next_Formal (Formal);
8251 if Count < Minimum then
8252 Error_Msg_Uint_1 := UI_From_Int (Minimum);
8254 ("argument of pragma% must have at least"
8255 & "^ parameters", Arg2);
8260 -- Special checks for Stdcall
8262 elsif C = Convention_Stdcall then
8264 -- Several allowed cases
8266 if Is_Subprogram_Or_Generic_Subprogram (E)
8270 or else Ekind (E) = E_Variable
8272 -- A component as well. The entity does not have its Ekind
8273 -- set until the enclosing record declaration is fully
8276 or else Nkind (Parent (E)) = N_Component_Declaration
8278 -- An access to subprogram is also allowed
8282 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8284 -- Allow internal call to set convention of subprogram type
8286 or else Ekind (E) = E_Subprogram_Type
8292 ("argument of pragma% must be subprogram or access type",
8297 Set_Convention_From_Pragma (E);
8299 -- Deal with non-subprogram cases
8301 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8304 -- The pragma must apply to a first subtype, but it can also
8305 -- apply to a generic type in a generic formal part, in which
8306 -- case it will also appear in the corresponding instance.
8308 if Is_Generic_Type (E) or else In_Instance then
8311 Check_First_Subtype (Arg2);
8314 Set_Convention_From_Pragma (Base_Type (E));
8316 -- For access subprograms, we must set the convention on the
8317 -- internally generated directly designated type as well.
8319 if Ekind (E) = E_Access_Subprogram_Type then
8320 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8324 -- For the subprogram case, set proper convention for all homonyms
8325 -- in same scope and the same declarative part, i.e. the same
8326 -- compilation unit.
8329 -- Treat a pragma Import as an implicit body, and pragma import
8330 -- as implicit reference (for navigation in GNAT Studio).
8332 if Prag_Id = Pragma_Import then
8333 Generate_Reference (E, Id, 'b');
8335 -- For exported entities we restrict the generation of references
8336 -- to entities exported to foreign languages since entities
8337 -- exported to Ada do not provide further information to
8338 -- GNAT Studio and add undesired references to the output of the
8341 elsif Prag_Id = Pragma_Export
8342 and then Convention (E) /= Convention_Ada
8344 Generate_Reference (E, Id, 'i');
8347 -- If the pragma comes from an aspect, it only applies to the
8348 -- given entity, not its homonyms.
8350 if From_Aspect_Specification (N) then
8351 if C = Convention_Intrinsic
8352 and then Nkind (Ent) = N_Defining_Operator_Symbol
8354 if Is_Fixed_Point_Type (Etype (Ent))
8355 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8356 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8359 ("no intrinsic operator available for this fixed-point "
8362 ("\use expression functions with the desired "
8363 & "conversions made explicit", N);
8370 -- Otherwise Loop through the homonyms of the pragma argument's
8371 -- entity, an apply convention to those in the current scope.
8373 Comp_Unit := Get_Source_Unit (E);
8378 exit when No (E1) or else Scope (E1) /= Current_Scope;
8380 -- Ignore entry for which convention is already set
8382 if Has_Convention_Pragma (E1) then
8386 if Is_Subprogram (E1)
8387 and then Nkind (Parent (Declaration_Node (E1))) =
8389 and then not Relaxed_RM_Semantics
8391 Set_Has_Completion (E); -- to prevent cascaded error
8393 ("pragma% requires separate spec and must come before "
8397 -- Do not set the pragma on inherited operations or on formal
8400 if Comes_From_Source (E1)
8401 and then Comp_Unit = Get_Source_Unit (E1)
8402 and then not Is_Formal_Subprogram (E1)
8403 and then Nkind (Original_Node (Parent (E1))) /=
8404 N_Full_Type_Declaration
8406 if Present (Alias (E1))
8407 and then Scope (E1) /= Scope (Alias (E1))
8410 ("cannot apply pragma% to non-local entity& declared#",
8414 Set_Convention_From_Pragma (E1);
8416 if Prag_Id = Pragma_Import then
8417 Generate_Reference (E1, Id, 'b');
8425 end Process_Convention;
8427 ----------------------------------------
8428 -- Process_Disable_Enable_Atomic_Sync --
8429 ----------------------------------------
8431 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8433 Check_No_Identifiers;
8434 Check_At_Most_N_Arguments (1);
8436 -- Modeled internally as
8437 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8442 Pragma_Argument_Associations => New_List (
8443 Make_Pragma_Argument_Association (Loc,
8445 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8447 if Present (Arg1) then
8448 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8452 end Process_Disable_Enable_Atomic_Sync;
8454 -------------------------------------------------
8455 -- Process_Extended_Import_Export_Internal_Arg --
8456 -------------------------------------------------
8458 procedure Process_Extended_Import_Export_Internal_Arg
8459 (Arg_Internal : Node_Id := Empty)
8462 if No (Arg_Internal) then
8463 Error_Pragma ("Internal parameter required for pragma%");
8466 if Nkind (Arg_Internal) = N_Identifier then
8469 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8470 and then (Prag_Id = Pragma_Import_Function
8472 Prag_Id = Pragma_Export_Function)
8478 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8481 Check_Arg_Is_Local_Name (Arg_Internal);
8482 end Process_Extended_Import_Export_Internal_Arg;
8484 --------------------------------------------------
8485 -- Process_Extended_Import_Export_Object_Pragma --
8486 --------------------------------------------------
8488 procedure Process_Extended_Import_Export_Object_Pragma
8489 (Arg_Internal : Node_Id;
8490 Arg_External : Node_Id;
8496 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8497 Def_Id := Entity (Arg_Internal);
8499 if Ekind (Def_Id) not in E_Constant | E_Variable then
8501 ("pragma% must designate an object", Arg_Internal);
8504 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8506 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8509 ("previous Common/Psect_Object applies, pragma % not permitted",
8513 if Rep_Item_Too_Late (Def_Id, N) then
8517 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8519 if Present (Arg_Size) then
8520 Check_Arg_Is_External_Name (Arg_Size);
8523 -- Export_Object case
8525 if Prag_Id = Pragma_Export_Object then
8526 if not Is_Library_Level_Entity (Def_Id) then
8528 ("argument for pragma% must be library level entity",
8532 if Ekind (Current_Scope) = E_Generic_Package then
8533 Error_Pragma ("pragma& cannot appear in a generic unit");
8536 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8538 ("exported object must have compile time known size",
8542 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8543 Error_Msg_N ("??duplicate Export_Object pragma", N);
8545 Set_Exported (Def_Id, Arg_Internal);
8548 -- Import_Object case
8551 if Is_Concurrent_Type (Etype (Def_Id)) then
8553 ("cannot use pragma% for task/protected object",
8557 if Ekind (Def_Id) = E_Constant then
8559 ("cannot import a constant", Arg_Internal);
8562 if Warn_On_Export_Import
8563 and then Has_Discriminants (Etype (Def_Id))
8566 ("imported value must be initialized??", Arg_Internal);
8569 if Warn_On_Export_Import
8570 and then Is_Access_Type (Etype (Def_Id))
8573 ("cannot import object of an access type??", Arg_Internal);
8576 if Warn_On_Export_Import
8577 and then Is_Imported (Def_Id)
8579 Error_Msg_N ("??duplicate Import_Object pragma", N);
8581 -- Check for explicit initialization present. Note that an
8582 -- initialization generated by the code generator, e.g. for an
8583 -- access type, does not count here.
8585 elsif Present (Expression (Parent (Def_Id)))
8588 (Original_Node (Expression (Parent (Def_Id))))
8590 Error_Msg_Sloc := Sloc (Def_Id);
8592 ("imported entities cannot be initialized (RM B.1(24))",
8593 "\no initialization allowed for & declared#", Arg1);
8595 Set_Imported (Def_Id);
8596 Note_Possible_Modification (Arg_Internal, Sure => False);
8599 end Process_Extended_Import_Export_Object_Pragma;
8601 ------------------------------------------------------
8602 -- Process_Extended_Import_Export_Subprogram_Pragma --
8603 ------------------------------------------------------
8605 procedure Process_Extended_Import_Export_Subprogram_Pragma
8606 (Arg_Internal : Node_Id;
8607 Arg_External : Node_Id;
8608 Arg_Parameter_Types : Node_Id;
8609 Arg_Result_Type : Node_Id := Empty;
8610 Arg_Mechanism : Node_Id;
8611 Arg_Result_Mechanism : Node_Id := Empty)
8617 Ambiguous : Boolean;
8620 function Same_Base_Type
8622 Formal : Entity_Id) return Boolean;
8623 -- Determines if Ptype references the type of Formal. Note that only
8624 -- the base types need to match according to the spec. Ptype here is
8625 -- the argument from the pragma, which is either a type name, or an
8626 -- access attribute.
8628 --------------------
8629 -- Same_Base_Type --
8630 --------------------
8632 function Same_Base_Type
8634 Formal : Entity_Id) return Boolean
8636 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8640 -- Case where pragma argument is typ'Access
8642 if Nkind (Ptype) = N_Attribute_Reference
8643 and then Attribute_Name (Ptype) = Name_Access
8645 Pref := Prefix (Ptype);
8648 if not Is_Entity_Name (Pref)
8649 or else Entity (Pref) = Any_Type
8654 -- We have a match if the corresponding argument is of an
8655 -- anonymous access type, and its designated type matches the
8656 -- type of the prefix of the access attribute
8658 return Ekind (Ftyp) = E_Anonymous_Access_Type
8659 and then Base_Type (Entity (Pref)) =
8660 Base_Type (Etype (Designated_Type (Ftyp)));
8662 -- Case where pragma argument is a type name
8667 if not Is_Entity_Name (Ptype)
8668 or else Entity (Ptype) = Any_Type
8673 -- We have a match if the corresponding argument is of the type
8674 -- given in the pragma (comparing base types)
8676 return Base_Type (Entity (Ptype)) = Ftyp;
8680 -- Start of processing for
8681 -- Process_Extended_Import_Export_Subprogram_Pragma
8684 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8688 -- Loop through homonyms (overloadings) of the entity
8690 Hom_Id := Entity (Arg_Internal);
8691 while Present (Hom_Id) loop
8692 Def_Id := Get_Base_Subprogram (Hom_Id);
8694 -- We need a subprogram in the current scope
8696 if not Is_Subprogram (Def_Id)
8697 or else Scope (Def_Id) /= Current_Scope
8704 -- Pragma cannot apply to subprogram body
8706 if Is_Subprogram (Def_Id)
8707 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8711 ("pragma% requires separate spec and must come before "
8715 -- Test result type if given, note that the result type
8716 -- parameter can only be present for the function cases.
8718 if Present (Arg_Result_Type)
8719 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8723 elsif Etype (Def_Id) /= Standard_Void_Type
8725 Pname in Name_Export_Procedure | Name_Import_Procedure
8729 -- Test parameter types if given. Note that this parameter has
8730 -- not been analyzed (and must not be, since it is semantic
8731 -- nonsense), so we get it as the parser left it.
8733 elsif Present (Arg_Parameter_Types) then
8734 Check_Matching_Types : declare
8739 Formal := First_Formal (Def_Id);
8741 if Nkind (Arg_Parameter_Types) = N_Null then
8742 if Present (Formal) then
8746 -- A list of one type, e.g. (List) is parsed as a
8747 -- parenthesized expression.
8749 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8750 and then Paren_Count (Arg_Parameter_Types) = 1
8753 or else Present (Next_Formal (Formal))
8758 Same_Base_Type (Arg_Parameter_Types, Formal);
8761 -- A list of more than one type is parsed as a aggregate
8763 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8764 and then Paren_Count (Arg_Parameter_Types) = 0
8766 Ptype := First (Expressions (Arg_Parameter_Types));
8767 while Present (Ptype) or else Present (Formal) loop
8770 or else not Same_Base_Type (Ptype, Formal)
8775 Next_Formal (Formal);
8780 -- Anything else is of the wrong form
8784 ("wrong form for Parameter_Types parameter",
8785 Arg_Parameter_Types);
8787 end Check_Matching_Types;
8790 -- Match is now False if the entry we found did not match
8791 -- either a supplied Parameter_Types or Result_Types argument
8797 -- Ambiguous case, the flag Ambiguous shows if we already
8798 -- detected this and output the initial messages.
8801 if not Ambiguous then
8803 Error_Msg_Name_1 := Pname;
8805 ("pragma% does not uniquely identify subprogram!",
8807 Error_Msg_Sloc := Sloc (Ent);
8808 Error_Msg_N ("matching subprogram #!", N);
8812 Error_Msg_Sloc := Sloc (Def_Id);
8813 Error_Msg_N ("matching subprogram #!", N);
8818 Hom_Id := Homonym (Hom_Id);
8821 -- See if we found an entry
8824 if not Ambiguous then
8825 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8827 ("pragma% cannot be given for generic subprogram");
8830 ("pragma% does not identify local subprogram");
8837 -- Import pragmas must be for imported entities
8839 if Prag_Id = Pragma_Import_Function
8841 Prag_Id = Pragma_Import_Procedure
8843 Prag_Id = Pragma_Import_Valued_Procedure
8845 if not Is_Imported (Ent) then
8847 ("pragma Import or Interface must precede pragma%");
8850 -- Here we have the Export case which can set the entity as exported
8852 -- But does not do so if the specified external name is null, since
8853 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8854 -- compatible) to request no external name.
8856 elsif Nkind (Arg_External) = N_String_Literal
8857 and then String_Length (Strval (Arg_External)) = 0
8861 -- In all other cases, set entity as exported
8864 Set_Exported (Ent, Arg_Internal);
8867 -- Special processing for Valued_Procedure cases
8869 if Prag_Id = Pragma_Import_Valued_Procedure
8871 Prag_Id = Pragma_Export_Valued_Procedure
8873 Formal := First_Formal (Ent);
8876 Error_Pragma ("at least one parameter required for pragma%");
8878 elsif Ekind (Formal) /= E_Out_Parameter then
8879 Error_Pragma ("first parameter must have mode out for pragma%");
8882 Set_Is_Valued_Procedure (Ent);
8886 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8888 -- Process Result_Mechanism argument if present. We have already
8889 -- checked that this is only allowed for the function case.
8891 if Present (Arg_Result_Mechanism) then
8892 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8895 -- Process Mechanism parameter if present. Note that this parameter
8896 -- is not analyzed, and must not be analyzed since it is semantic
8897 -- nonsense, so we get it in exactly as the parser left it.
8899 if Present (Arg_Mechanism) then
8907 -- A single mechanism association without a formal parameter
8908 -- name is parsed as a parenthesized expression. All other
8909 -- cases are parsed as aggregates, so we rewrite the single
8910 -- parameter case as an aggregate for consistency.
8912 if Nkind (Arg_Mechanism) /= N_Aggregate
8913 and then Paren_Count (Arg_Mechanism) = 1
8915 Rewrite (Arg_Mechanism,
8916 Make_Aggregate (Sloc (Arg_Mechanism),
8917 Expressions => New_List (
8918 Relocate_Node (Arg_Mechanism))));
8921 -- Case of only mechanism name given, applies to all formals
8923 if Nkind (Arg_Mechanism) /= N_Aggregate then
8924 Formal := First_Formal (Ent);
8925 while Present (Formal) loop
8926 Set_Mechanism_Value (Formal, Arg_Mechanism);
8927 Next_Formal (Formal);
8930 -- Case of list of mechanism associations given
8933 if Null_Record_Present (Arg_Mechanism) then
8935 ("inappropriate form for Mechanism parameter",
8939 -- Deal with positional ones first
8941 Formal := First_Formal (Ent);
8943 if Present (Expressions (Arg_Mechanism)) then
8944 Mname := First (Expressions (Arg_Mechanism));
8945 while Present (Mname) loop
8948 ("too many mechanism associations", Mname);
8951 Set_Mechanism_Value (Formal, Mname);
8952 Next_Formal (Formal);
8957 -- Deal with named entries
8959 if Present (Component_Associations (Arg_Mechanism)) then
8960 Massoc := First (Component_Associations (Arg_Mechanism));
8961 while Present (Massoc) loop
8962 Choice := First (Choices (Massoc));
8964 if Nkind (Choice) /= N_Identifier
8965 or else Present (Next (Choice))
8968 ("incorrect form for mechanism association",
8972 Formal := First_Formal (Ent);
8976 ("parameter name & not present", Choice);
8979 if Chars (Choice) = Chars (Formal) then
8981 (Formal, Expression (Massoc));
8983 -- Set entity on identifier for proper tree
8986 Set_Entity (Choice, Formal);
8991 Next_Formal (Formal);
9000 end Process_Extended_Import_Export_Subprogram_Pragma;
9002 --------------------------
9003 -- Process_Generic_List --
9004 --------------------------
9006 procedure Process_Generic_List is
9011 Check_No_Identifiers;
9012 Check_At_Least_N_Arguments (1);
9014 -- Check all arguments are names of generic units or instances
9017 while Present (Arg) loop
9018 Exp := Get_Pragma_Arg (Arg);
9021 if not Is_Entity_Name (Exp)
9023 (not Is_Generic_Instance (Entity (Exp))
9025 not Is_Generic_Unit (Entity (Exp)))
9028 ("pragma% argument must be name of generic unit/instance",
9034 end Process_Generic_List;
9036 ------------------------------------
9037 -- Process_Import_Predefined_Type --
9038 ------------------------------------
9040 procedure Process_Import_Predefined_Type is
9041 Loc : constant Source_Ptr := Sloc (N);
9043 Ftyp : Node_Id := Empty;
9049 Nam := String_To_Name (Strval (Expression (Arg3)));
9051 Elmt := First_Elmt (Predefined_Float_Types);
9052 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9056 Ftyp := Node (Elmt);
9058 if Present (Ftyp) then
9060 -- Don't build a derived type declaration, because predefined C
9061 -- types have no declaration anywhere, so cannot really be named.
9062 -- Instead build a full type declaration, starting with an
9063 -- appropriate type definition is built
9065 if Is_Floating_Point_Type (Ftyp) then
9066 Def := Make_Floating_Point_Definition (Loc,
9067 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9068 Make_Real_Range_Specification (Loc,
9069 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9070 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9072 -- Should never have a predefined type we cannot handle
9075 raise Program_Error;
9078 -- Build and insert a Full_Type_Declaration, which will be
9079 -- analyzed as soon as this list entry has been analyzed.
9081 Decl := Make_Full_Type_Declaration (Loc,
9082 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9083 Type_Definition => Def);
9085 Insert_After (N, Decl);
9086 Mark_Rewrite_Insertion (Decl);
9089 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9091 end Process_Import_Predefined_Type;
9093 ---------------------------------
9094 -- Process_Import_Or_Interface --
9095 ---------------------------------
9097 procedure Process_Import_Or_Interface is
9103 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9104 -- pragma Import (Entity, "external name");
9106 if Relaxed_RM_Semantics
9107 and then Arg_Count = 2
9108 and then Prag_Id = Pragma_Import
9109 and then Nkind (Expression (Arg2)) = N_String_Literal
9112 Def_Id := Get_Pragma_Arg (Arg1);
9115 if not Is_Entity_Name (Def_Id) then
9116 Error_Pragma_Arg ("entity name required", Arg1);
9119 Def_Id := Entity (Def_Id);
9120 Kill_Size_Check_Code (Def_Id);
9121 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9124 Process_Convention (C, Def_Id);
9126 -- A pragma that applies to a Ghost entity becomes Ghost for the
9127 -- purposes of legality checks and removal of ignored Ghost code.
9129 Mark_Ghost_Pragma (N, Def_Id);
9130 Kill_Size_Check_Code (Def_Id);
9131 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9134 -- Various error checks
9136 if Ekind (Def_Id) in E_Variable | E_Constant then
9138 -- We do not permit Import to apply to a renaming declaration
9140 if Present (Renamed_Object (Def_Id)) then
9142 ("pragma% not allowed for object renaming", Arg2);
9144 -- User initialization is not allowed for imported object, but
9145 -- the object declaration may contain a default initialization,
9146 -- that will be discarded. Note that an explicit initialization
9147 -- only counts if it comes from source, otherwise it is simply
9148 -- the code generator making an implicit initialization explicit.
9150 elsif Present (Expression (Parent (Def_Id)))
9151 and then Comes_From_Source
9152 (Original_Node (Expression (Parent (Def_Id))))
9154 -- Set imported flag to prevent cascaded errors
9156 Set_Is_Imported (Def_Id);
9158 Error_Msg_Sloc := Sloc (Def_Id);
9160 ("no initialization allowed for declaration of& #",
9161 "\imported entities cannot be initialized (RM B.1(24))",
9165 -- If the pragma comes from an aspect specification the
9166 -- Is_Imported flag has already been set.
9168 if not From_Aspect_Specification (N) then
9169 Set_Imported (Def_Id);
9172 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9174 -- Note that we do not set Is_Public here. That's because we
9175 -- only want to set it if there is no address clause, and we
9176 -- don't know that yet, so we delay that processing till
9179 -- pragma Import completes deferred constants
9181 if Ekind (Def_Id) = E_Constant then
9182 Set_Has_Completion (Def_Id);
9185 -- It is not possible to import a constant of an unconstrained
9186 -- array type (e.g. string) because there is no simple way to
9187 -- write a meaningful subtype for it.
9189 if Is_Array_Type (Etype (Def_Id))
9190 and then not Is_Constrained (Etype (Def_Id))
9193 ("imported constant& must have a constrained subtype",
9198 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9200 -- If the name is overloaded, pragma applies to all of the denoted
9201 -- entities in the same declarative part, unless the pragma comes
9202 -- from an aspect specification or was generated by the compiler
9203 -- (such as for pragma Provide_Shift_Operators).
9206 while Present (Hom_Id) loop
9208 Def_Id := Get_Base_Subprogram (Hom_Id);
9210 -- Ignore inherited subprograms because the pragma will apply
9211 -- to the parent operation, which is the one called.
9213 if Is_Overloadable (Def_Id)
9214 and then Present (Alias (Def_Id))
9218 -- If it is not a subprogram, it must be in an outer scope and
9219 -- pragma does not apply.
9221 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9224 -- The pragma does not apply to primitives of interfaces
9226 elsif Is_Dispatching_Operation (Def_Id)
9227 and then Present (Find_Dispatching_Type (Def_Id))
9228 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9232 -- Verify that the homonym is in the same declarative part (not
9233 -- just the same scope). If the pragma comes from an aspect
9234 -- specification we know that it is part of the declaration.
9236 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9237 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9238 and then not From_Aspect_Specification (N)
9243 -- If the pragma comes from an aspect specification the
9244 -- Is_Imported flag has already been set.
9246 if not From_Aspect_Specification (N) then
9247 Set_Imported (Def_Id);
9250 -- Reject an Import applied to an abstract subprogram
9252 if Is_Subprogram (Def_Id)
9253 and then Is_Abstract_Subprogram (Def_Id)
9255 Error_Msg_Sloc := Sloc (Def_Id);
9257 ("cannot import abstract subprogram& declared#",
9261 -- Special processing for Convention_Intrinsic
9263 if C = Convention_Intrinsic then
9265 -- Link_Name argument not allowed for intrinsic
9269 Set_Is_Intrinsic_Subprogram (Def_Id);
9271 -- If no external name is present, then check that this
9272 -- is a valid intrinsic subprogram. If an external name
9273 -- is present, then this is handled by the back end.
9276 Check_Intrinsic_Subprogram
9277 (Def_Id, Get_Pragma_Arg (Arg2));
9281 -- Verify that the subprogram does not have a completion
9282 -- through a renaming declaration. For other completions the
9283 -- pragma appears as a too late representation.
9286 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9290 and then Nkind (Decl) = N_Subprogram_Declaration
9291 and then Present (Corresponding_Body (Decl))
9292 and then Nkind (Unit_Declaration_Node
9293 (Corresponding_Body (Decl))) =
9294 N_Subprogram_Renaming_Declaration
9296 Error_Msg_Sloc := Sloc (Def_Id);
9298 ("cannot import&, renaming already provided for "
9299 & "declaration #", N, Def_Id);
9303 -- If the pragma comes from an aspect specification, there
9304 -- must be an Import aspect specified as well. In the rare
9305 -- case where Import is set to False, the suprogram needs to
9306 -- have a local completion.
9309 Imp_Aspect : constant Node_Id :=
9310 Find_Aspect (Def_Id, Aspect_Import);
9314 if Present (Imp_Aspect)
9315 and then Present (Expression (Imp_Aspect))
9317 Expr := Expression (Imp_Aspect);
9318 Analyze_And_Resolve (Expr, Standard_Boolean);
9320 if Is_Entity_Name (Expr)
9321 and then Entity (Expr) = Standard_True
9323 Set_Has_Completion (Def_Id);
9326 -- If there is no expression, the default is True, as for
9327 -- all boolean aspects. Same for the older pragma.
9330 Set_Has_Completion (Def_Id);
9334 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9337 if Is_Compilation_Unit (Hom_Id) then
9339 -- Its possible homonyms are not affected by the pragma.
9340 -- Such homonyms might be present in the context of other
9341 -- units being compiled.
9345 elsif From_Aspect_Specification (N) then
9348 -- If the pragma was created by the compiler, then we don't
9349 -- want it to apply to other homonyms. This kind of case can
9350 -- occur when using pragma Provide_Shift_Operators, which
9351 -- generates implicit shift and rotate operators with Import
9352 -- pragmas that might apply to earlier explicit or implicit
9353 -- declarations marked with Import (for example, coming from
9354 -- an earlier pragma Provide_Shift_Operators for another type),
9355 -- and we don't generally want other homonyms being treated
9356 -- as imported or the pragma flagged as an illegal duplicate.
9358 elsif not Comes_From_Source (N) then
9362 Hom_Id := Homonym (Hom_Id);
9366 -- Import a CPP class
9368 elsif C = Convention_CPP
9369 and then (Is_Record_Type (Def_Id)
9370 or else Ekind (Def_Id) = E_Incomplete_Type)
9372 if Ekind (Def_Id) = E_Incomplete_Type then
9373 if Present (Full_View (Def_Id)) then
9374 Def_Id := Full_View (Def_Id);
9378 ("cannot import 'C'P'P type before full declaration seen",
9379 Get_Pragma_Arg (Arg2));
9381 -- Although we have reported the error we decorate it as
9382 -- CPP_Class to avoid reporting spurious errors
9384 Set_Is_CPP_Class (Def_Id);
9389 -- Types treated as CPP classes must be declared limited (note:
9390 -- this used to be a warning but there is no real benefit to it
9391 -- since we did effectively intend to treat the type as limited
9394 if not Is_Limited_Type (Def_Id) then
9396 ("imported 'C'P'P type must be limited",
9397 Get_Pragma_Arg (Arg2));
9400 if Etype (Def_Id) /= Def_Id
9401 and then not Is_CPP_Class (Root_Type (Def_Id))
9403 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9406 Set_Is_CPP_Class (Def_Id);
9408 -- Imported CPP types must not have discriminants (because C++
9409 -- classes do not have discriminants).
9411 if Has_Discriminants (Def_Id) then
9413 ("imported 'C'P'P type cannot have discriminants",
9414 First (Discriminant_Specifications
9415 (Declaration_Node (Def_Id))));
9418 -- Check that components of imported CPP types do not have default
9419 -- expressions. For private types this check is performed when the
9420 -- full view is analyzed (see Process_Full_View).
9422 if not Is_Private_Type (Def_Id) then
9423 Check_CPP_Type_Has_No_Defaults (Def_Id);
9426 -- Import a CPP exception
9428 elsif C = Convention_CPP
9429 and then Ekind (Def_Id) = E_Exception
9433 ("'External_'Name arguments is required for 'Cpp exception",
9436 -- As only a string is allowed, Check_Arg_Is_External_Name
9439 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9442 if Present (Arg4) then
9444 ("Link_Name argument not allowed for imported Cpp exception",
9448 -- Do not call Set_Interface_Name as the name of the exception
9449 -- shouldn't be modified (and in particular it shouldn't be
9450 -- the External_Name). For exceptions, the External_Name is the
9451 -- name of the RTTI structure.
9453 -- ??? Emit an error if pragma Import/Export_Exception is present
9455 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9457 Check_Arg_Count (3);
9458 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9460 Process_Import_Predefined_Type;
9463 if From_Aspect_Specification (N) then
9465 ("entity for aspect% must be object, subprogram "
9466 & "or incomplete type",
9470 ("second argument of pragma% must be object, subprogram "
9471 & "or incomplete type",
9476 -- If this pragma applies to a compilation unit, then the unit, which
9477 -- is a subprogram, does not require (or allow) a body. We also do
9478 -- not need to elaborate imported procedures.
9480 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9482 Cunit : constant Node_Id := Parent (Parent (N));
9484 Set_Body_Required (Cunit, False);
9487 end Process_Import_Or_Interface;
9489 --------------------
9490 -- Process_Inline --
9491 --------------------
9493 procedure Process_Inline (Status : Inline_Status) is
9500 Ghost_Error_Posted : Boolean := False;
9501 -- Flag set when an error concerning the illegal mix of Ghost and
9502 -- non-Ghost subprograms is emitted.
9504 Ghost_Id : Entity_Id := Empty;
9505 -- The entity of the first Ghost subprogram encountered while
9506 -- processing the arguments of the pragma.
9508 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9509 -- Verify the placement of pragma Inline_Always with respect to the
9510 -- initial declaration of subprogram Spec_Id.
9512 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9513 -- Returns True if it can be determined at this stage that inlining
9514 -- is not possible, for example if the body is available and contains
9515 -- exception handlers, we prevent inlining, since otherwise we can
9516 -- get undefined symbols at link time. This function also emits a
9517 -- warning if the pragma appears too late.
9519 -- ??? is business with link symbols still valid, or does it relate
9520 -- to front end ZCX which is being phased out ???
9522 procedure Make_Inline (Subp : Entity_Id);
9523 -- Subp is the defining unit name of the subprogram declaration. If
9524 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9525 -- the corresponding body, if there is one present.
9527 procedure Set_Inline_Flags (Subp : Entity_Id);
9528 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9529 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9531 -----------------------------------
9532 -- Check_Inline_Always_Placement --
9533 -----------------------------------
9535 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9536 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9538 function Compilation_Unit_OK return Boolean;
9539 pragma Inline (Compilation_Unit_OK);
9540 -- Determine whether pragma Inline_Always applies to a compatible
9541 -- compilation unit denoted by Spec_Id.
9543 function Declarative_List_OK return Boolean;
9544 pragma Inline (Declarative_List_OK);
9545 -- Determine whether the initial declaration of subprogram Spec_Id
9546 -- and the pragma appear in compatible declarative lists.
9548 function Subprogram_Body_OK return Boolean;
9549 pragma Inline (Subprogram_Body_OK);
9550 -- Determine whether pragma Inline_Always applies to a compatible
9551 -- subprogram body denoted by Spec_Id.
9553 -------------------------
9554 -- Compilation_Unit_OK --
9555 -------------------------
9557 function Compilation_Unit_OK return Boolean is
9558 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9561 -- The pragma appears after the initial declaration of a
9562 -- compilation unit.
9564 -- procedure Comp_Unit;
9565 -- pragma Inline_Always (Comp_Unit);
9567 -- Note that for compatibility reasons, the following case is
9570 -- procedure Stand_Alone_Body_Comp_Unit is
9572 -- end Stand_Alone_Body_Comp_Unit;
9573 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9576 Nkind (Comp_Unit) = N_Compilation_Unit
9577 and then Present (Aux_Decls_Node (Comp_Unit))
9578 and then Is_List_Member (N)
9579 and then List_Containing (N) =
9580 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9581 end Compilation_Unit_OK;
9583 -------------------------
9584 -- Declarative_List_OK --
9585 -------------------------
9587 function Declarative_List_OK return Boolean is
9588 Context : constant Node_Id := Parent (Spec_Decl);
9590 Init_Decl : Node_Id;
9591 Init_List : List_Id;
9592 Prag_List : List_Id;
9595 -- Determine the proper initial declaration. In general this is
9596 -- the declaration node of the subprogram except when the input
9597 -- denotes a generic instantiation.
9599 -- procedure Inst is new Gen;
9600 -- pragma Inline_Always (Inst);
9602 -- In this case the original subprogram is moved inside an
9603 -- anonymous package while pragma Inline_Always remains at the
9604 -- level of the anonymous package. Use the declaration of the
9605 -- package because it reflects the placement of the original
9608 -- package Anon_Pack is
9609 -- procedure Inst is ... end Inst; -- original
9612 -- procedure Inst renames Anon_Pack.Inst;
9613 -- pragma Inline_Always (Inst);
9615 if Is_Generic_Instance (Spec_Id) then
9616 Init_Decl := Parent (Parent (Spec_Decl));
9617 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9619 Init_Decl := Spec_Decl;
9622 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9623 Init_List := List_Containing (Init_Decl);
9624 Prag_List := List_Containing (N);
9626 -- The pragma and then initial declaration appear within the
9627 -- same declarative list.
9629 if Init_List = Prag_List then
9632 -- A special case of the above is when both the pragma and
9633 -- the initial declaration appear in different lists of a
9634 -- package spec, protected definition, or a task definition.
9639 -- pragma Inline_Always (Proc);
9642 elsif Nkind (Context) in N_Package_Specification
9643 | N_Protected_Definition
9645 and then Init_List = Visible_Declarations (Context)
9646 and then Prag_List = Private_Declarations (Context)
9653 end Declarative_List_OK;
9655 ------------------------
9656 -- Subprogram_Body_OK --
9657 ------------------------
9659 function Subprogram_Body_OK return Boolean is
9660 Body_Decl : Node_Id;
9663 -- The pragma appears within the declarative list of a stand-
9664 -- alone subprogram body.
9666 -- procedure Stand_Alone_Body is
9667 -- pragma Inline_Always (Stand_Alone_Body);
9670 -- end Stand_Alone_Body;
9672 -- The compiler creates a dummy spec in this case, however the
9673 -- pragma remains within the declarative list of the body.
9675 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9676 and then not Comes_From_Source (Spec_Decl)
9677 and then Present (Corresponding_Body (Spec_Decl))
9680 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9682 if Present (Declarations (Body_Decl))
9683 and then Is_List_Member (N)
9684 and then List_Containing (N) = Declarations (Body_Decl)
9691 end Subprogram_Body_OK;
9693 -- Start of processing for Check_Inline_Always_Placement
9696 -- This check is relevant only for pragma Inline_Always
9698 if Pname /= Name_Inline_Always then
9701 -- Nothing to do when the pragma is internally generated on the
9702 -- assumption that it is properly placed.
9704 elsif not Comes_From_Source (N) then
9707 -- Nothing to do for internally generated subprograms that act
9708 -- as accidental homonyms of a source subprogram being inlined.
9710 elsif not Comes_From_Source (Spec_Id) then
9713 -- Nothing to do for generic formal subprograms that act as
9714 -- homonyms of another source subprogram being inlined.
9716 elsif Is_Formal_Subprogram (Spec_Id) then
9719 elsif Compilation_Unit_OK
9720 or else Declarative_List_OK
9721 or else Subprogram_Body_OK
9726 -- At this point it is known that the pragma applies to or appears
9727 -- within a completing body, a completing stub, or a subunit.
9729 Error_Msg_Name_1 := Pname;
9730 Error_Msg_Name_2 := Chars (Spec_Id);
9731 Error_Msg_Sloc := Sloc (Spec_Id);
9734 ("pragma % must appear on initial declaration of subprogram "
9735 & "% defined #", N);
9736 end Check_Inline_Always_Placement;
9738 ---------------------------
9739 -- Inlining_Not_Possible --
9740 ---------------------------
9742 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9743 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9747 if Nkind (Decl) = N_Subprogram_Body then
9748 Stats := Handled_Statement_Sequence (Decl);
9749 return Present (Exception_Handlers (Stats))
9750 or else Present (At_End_Proc (Stats));
9752 elsif Nkind (Decl) = N_Subprogram_Declaration
9753 and then Present (Corresponding_Body (Decl))
9755 if Analyzed (Corresponding_Body (Decl)) then
9756 Error_Msg_N ("pragma appears too late, ignored??", N);
9759 -- If the subprogram is a renaming as body, the body is just a
9760 -- call to the renamed subprogram, and inlining is trivially
9764 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9765 N_Subprogram_Renaming_Declaration
9771 Handled_Statement_Sequence
9772 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9775 Present (Exception_Handlers (Stats))
9776 or else Present (At_End_Proc (Stats));
9780 -- If body is not available, assume the best, the check is
9781 -- performed again when compiling enclosing package bodies.
9785 end Inlining_Not_Possible;
9791 procedure Make_Inline (Subp : Entity_Id) is
9792 Kind : constant Entity_Kind := Ekind (Subp);
9793 Inner_Subp : Entity_Id := Subp;
9796 -- Ignore if bad type, avoid cascaded error
9798 if Etype (Subp) = Any_Type then
9802 -- If inlining is not possible, for now do not treat as an error
9804 elsif Status /= Suppressed
9805 and then Front_End_Inlining
9806 and then Inlining_Not_Possible (Subp)
9811 -- Here we have a candidate for inlining, but we must exclude
9812 -- derived operations. Otherwise we would end up trying to inline
9813 -- a phantom declaration, and the result would be to drag in a
9814 -- body which has no direct inlining associated with it. That
9815 -- would not only be inefficient but would also result in the
9816 -- backend doing cross-unit inlining in cases where it was
9817 -- definitely inappropriate to do so.
9819 -- However, a simple Comes_From_Source test is insufficient, since
9820 -- we do want to allow inlining of generic instances which also do
9821 -- not come from source. We also need to recognize specs generated
9822 -- by the front-end for bodies that carry the pragma. Finally,
9823 -- predefined operators do not come from source but are not
9824 -- inlineable either.
9826 elsif Is_Generic_Instance (Subp)
9827 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9831 elsif not Comes_From_Source (Subp)
9832 and then Scope (Subp) /= Standard_Standard
9838 -- The referenced entity must either be the enclosing entity, or
9839 -- an entity declared within the current open scope.
9841 if Present (Scope (Subp))
9842 and then Scope (Subp) /= Current_Scope
9843 and then Subp /= Current_Scope
9846 ("argument of% must be entity in current scope", Assoc);
9850 -- Processing for procedure, operator or function. If subprogram
9851 -- is aliased (as for an instance) indicate that the renamed
9852 -- entity (if declared in the same unit) is inlined.
9853 -- If this is the anonymous subprogram created for a subprogram
9854 -- instance, the inlining applies to it directly. Otherwise we
9855 -- retrieve it as the alias of the visible subprogram instance.
9857 if Is_Subprogram (Subp) then
9859 -- Ensure that pragma Inline_Always is associated with the
9860 -- initial declaration of the subprogram.
9862 Check_Inline_Always_Placement (Subp);
9864 if Is_Wrapper_Package (Scope (Subp)) then
9867 Inner_Subp := Ultimate_Alias (Inner_Subp);
9870 if In_Same_Source_Unit (Subp, Inner_Subp) then
9871 Set_Inline_Flags (Inner_Subp);
9873 Decl := Parent (Parent (Inner_Subp));
9875 if Nkind (Decl) = N_Subprogram_Declaration
9876 and then Present (Corresponding_Body (Decl))
9878 Set_Inline_Flags (Corresponding_Body (Decl));
9880 elsif Is_Generic_Instance (Subp)
9881 and then Comes_From_Source (Subp)
9883 -- Indicate that the body needs to be created for
9884 -- inlining subsequent calls. The instantiation node
9885 -- follows the declaration of the wrapper package
9886 -- created for it. The subprogram that requires the
9887 -- body is the anonymous one in the wrapper package.
9889 if Scope (Subp) /= Standard_Standard
9891 Need_Subprogram_Instance_Body
9892 (Next (Unit_Declaration_Node
9893 (Scope (Alias (Subp)))), Subp)
9898 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9899 -- appear in a formal part to apply to a formal subprogram.
9900 -- Do not apply check within an instance or a formal package
9901 -- the test will have been applied to the original generic.
9903 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9904 and then In_Same_List (Decl, N)
9905 and then not In_Instance
9908 ("Inline cannot apply to a formal subprogram", N);
9914 -- For a generic subprogram set flag as well, for use at the point
9915 -- of instantiation, to determine whether the body should be
9918 elsif Is_Generic_Subprogram (Subp) then
9919 Set_Inline_Flags (Subp);
9922 -- Literals are by definition inlined
9924 elsif Kind = E_Enumeration_Literal then
9927 -- Anything else is an error
9931 ("expect subprogram name for pragma%", Assoc);
9935 ----------------------
9936 -- Set_Inline_Flags --
9937 ----------------------
9939 procedure Set_Inline_Flags (Subp : Entity_Id) is
9941 -- First set the Has_Pragma_XXX flags and issue the appropriate
9942 -- errors and warnings for suspicious combinations.
9944 if Prag_Id = Pragma_No_Inline then
9945 if Has_Pragma_Inline_Always (Subp) then
9947 ("Inline_Always and No_Inline are mutually exclusive", N);
9948 elsif Has_Pragma_Inline (Subp) then
9950 ("Inline and No_Inline both specified for& ??",
9951 N, Entity (Subp_Id));
9954 Set_Has_Pragma_No_Inline (Subp);
9956 if Prag_Id = Pragma_Inline_Always then
9957 if Has_Pragma_No_Inline (Subp) then
9959 ("Inline_Always and No_Inline are mutually exclusive",
9963 Set_Has_Pragma_Inline_Always (Subp);
9965 if Has_Pragma_No_Inline (Subp) then
9967 ("Inline and No_Inline both specified for& ??",
9968 N, Entity (Subp_Id));
9972 Set_Has_Pragma_Inline (Subp);
9975 -- Then adjust the Is_Inlined flag. It can never be set if the
9976 -- subprogram is subject to pragma No_Inline.
9980 Set_Is_Inlined (Subp, False);
9986 if not Has_Pragma_No_Inline (Subp) then
9987 Set_Is_Inlined (Subp, True);
9991 -- A pragma that applies to a Ghost entity becomes Ghost for the
9992 -- purposes of legality checks and removal of ignored Ghost code.
9994 Mark_Ghost_Pragma (N, Subp);
9996 -- Capture the entity of the first Ghost subprogram being
9997 -- processed for error detection purposes.
9999 if Is_Ghost_Entity (Subp) then
10000 if No (Ghost_Id) then
10004 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10005 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10007 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
10008 Ghost_Error_Posted := True;
10010 Error_Msg_Name_1 := Pname;
10012 ("pragma % cannot mention ghost and non-ghost subprograms",
10015 Error_Msg_Sloc := Sloc (Ghost_Id);
10016 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10018 Error_Msg_Sloc := Sloc (Subp);
10019 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10021 end Set_Inline_Flags;
10023 -- Start of processing for Process_Inline
10026 -- An inlined subprogram may grant access to its private enclosing
10027 -- context depending on the placement of its body. From elaboration
10028 -- point of view, the flow of execution may enter this private
10029 -- context, and then reach an external unit, thus producing a
10030 -- dependency on that external unit. For such a path to be properly
10031 -- discovered and encoded in the ALI file of the main unit, let the
10032 -- ABE mechanism process the body of the main unit, and encode all
10033 -- relevant invocation constructs and the relations between them.
10035 Mark_Save_Invocation_Graph_Of_Body;
10037 Check_No_Identifiers;
10038 Check_At_Least_N_Arguments (1);
10040 if Status = Enabled then
10041 Inline_Processing_Required := True;
10045 while Present (Assoc) loop
10046 Subp_Id := Get_Pragma_Arg (Assoc);
10050 if Is_Entity_Name (Subp_Id) then
10051 Subp := Entity (Subp_Id);
10053 if Subp = Any_Id then
10055 -- If previous error, avoid cascaded errors
10057 Check_Error_Detected;
10061 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10062 -- is given that directly specifies an aspect of an entity,
10063 -- then it is illegal to give another [...]
10064 -- aspect_specification that directly specifies the same
10065 -- aspect of the entity.
10066 -- We only check Subp directly as per "directly specifies"
10067 -- above and because the case of pragma Inline is really
10068 -- special given its pre aspect usage.
10070 Check_Duplicate_Pragma (Subp);
10071 Record_Rep_Item (Subp, N);
10073 Make_Inline (Subp);
10075 -- For the pragma case, climb homonym chain. This is
10076 -- what implements allowing the pragma in the renaming
10077 -- case, with the result applying to the ancestors, and
10078 -- also allows Inline to apply to all previous homonyms.
10080 if not From_Aspect_Specification (N) then
10081 while Present (Homonym (Subp))
10082 and then Scope (Homonym (Subp)) = Current_Scope
10084 Subp := Homonym (Subp);
10085 Make_Inline (Subp);
10091 if not Applies then
10092 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10098 -- If the context is a package declaration, the pragma indicates
10099 -- that inlining will require the presence of the corresponding
10100 -- body. (this may be further refined).
10103 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10104 N_Package_Declaration
10106 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10108 end Process_Inline;
10110 ----------------------------
10111 -- Process_Interface_Name --
10112 ----------------------------
10114 procedure Process_Interface_Name
10115 (Subprogram_Def : Entity_Id;
10117 Link_Arg : Node_Id;
10121 Link_Nam : Node_Id;
10122 String_Val : String_Id;
10124 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10125 -- SN is a string literal node for an interface name. This routine
10126 -- performs some minimal checks that the name is reasonable. In
10127 -- particular that no spaces or other obviously incorrect characters
10128 -- appear. This is only a warning, since any characters are allowed.
10130 ----------------------------------
10131 -- Check_Form_Of_Interface_Name --
10132 ----------------------------------
10134 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10135 S : constant String_Id := Strval (Expr_Value_S (SN));
10136 SL : constant Nat := String_Length (S);
10141 Error_Msg_N ("interface name cannot be null string", SN);
10144 for J in 1 .. SL loop
10145 C := Get_String_Char (S, J);
10147 -- Look for dubious character and issue unconditional warning.
10148 -- Definitely dubious if not in character range.
10150 if not In_Character_Range (C)
10152 -- Commas, spaces and (back)slashes are dubious
10154 or else Get_Character (C) = ','
10155 or else Get_Character (C) = '\'
10156 or else Get_Character (C) = ' '
10157 or else Get_Character (C) = '/'
10160 ("??interface name contains illegal character",
10161 Sloc (SN) + Source_Ptr (J));
10164 end Check_Form_Of_Interface_Name;
10166 -- Start of processing for Process_Interface_Name
10169 -- If we are looking at a pragma that comes from an aspect then it
10170 -- needs to have its corresponding aspect argument expressions
10171 -- analyzed in addition to the generated pragma so that aspects
10172 -- within generic units get properly resolved.
10174 if Present (Prag) and then From_Aspect_Specification (Prag) then
10176 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10184 -- Obtain all interfacing aspects used to construct the pragma
10186 Get_Interfacing_Aspects
10187 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10189 -- Analyze the expression of aspect External_Name
10191 if Present (EN) then
10192 Analyze (Expression (EN));
10195 -- Analyze the expressio of aspect Link_Name
10197 if Present (LN) then
10198 Analyze (Expression (LN));
10203 if No (Link_Arg) then
10204 if No (Ext_Arg) then
10207 elsif Chars (Ext_Arg) = Name_Link_Name then
10209 Link_Nam := Expression (Ext_Arg);
10212 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10213 Ext_Nam := Expression (Ext_Arg);
10218 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10219 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10220 Ext_Nam := Expression (Ext_Arg);
10221 Link_Nam := Expression (Link_Arg);
10224 -- Check expressions for external name and link name are static
10226 if Present (Ext_Nam) then
10227 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10228 Check_Form_Of_Interface_Name (Ext_Nam);
10230 -- Verify that external name is not the name of a local entity,
10231 -- which would hide the imported one and could lead to run-time
10232 -- surprises. The problem can only arise for entities declared in
10233 -- a package body (otherwise the external name is fully qualified
10234 -- and will not conflict).
10242 if Prag_Id = Pragma_Import then
10243 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10244 E := Entity_Id (Get_Name_Table_Int (Nam));
10246 if Nam /= Chars (Subprogram_Def)
10247 and then Present (E)
10248 and then not Is_Overloadable (E)
10249 and then Is_Immediately_Visible (E)
10250 and then not Is_Imported (E)
10251 and then Ekind (Scope (E)) = E_Package
10254 while Present (Par) loop
10255 if Nkind (Par) = N_Package_Body then
10256 Error_Msg_Sloc := Sloc (E);
10258 ("imported entity is hidden by & declared#",
10263 Par := Parent (Par);
10270 if Present (Link_Nam) then
10271 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10272 Check_Form_Of_Interface_Name (Link_Nam);
10275 -- If there is no link name, just set the external name
10277 if No (Link_Nam) then
10278 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10280 -- For the Link_Name case, the given literal is preceded by an
10281 -- asterisk, which indicates to GCC that the given name should be
10282 -- taken literally, and in particular that no prepending of
10283 -- underlines should occur, even in systems where this is the
10288 Store_String_Char (Get_Char_Code ('*'));
10289 String_Val := Strval (Expr_Value_S (Link_Nam));
10290 Store_String_Chars (String_Val);
10292 Make_String_Literal (Sloc (Link_Nam),
10293 Strval => End_String);
10296 -- Set the interface name. If the entity is a generic instance, use
10297 -- its alias, which is the callable entity.
10299 if Is_Generic_Instance (Subprogram_Def) then
10300 Set_Encoded_Interface_Name
10301 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10303 Set_Encoded_Interface_Name
10304 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10307 Check_Duplicated_Export_Name (Link_Nam);
10308 end Process_Interface_Name;
10310 -----------------------------------------
10311 -- Process_Interrupt_Or_Attach_Handler --
10312 -----------------------------------------
10314 procedure Process_Interrupt_Or_Attach_Handler is
10315 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10316 Prot_Typ : constant Entity_Id := Scope (Handler);
10319 -- A pragma that applies to a Ghost entity becomes Ghost for the
10320 -- purposes of legality checks and removal of ignored Ghost code.
10322 Mark_Ghost_Pragma (N, Handler);
10323 Set_Is_Interrupt_Handler (Handler);
10325 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10327 Record_Rep_Item (Prot_Typ, N);
10329 -- Chain the pragma on the contract for completeness
10331 Add_Contract_Item (N, Handler);
10332 end Process_Interrupt_Or_Attach_Handler;
10334 --------------------------------------------------
10335 -- Process_Restrictions_Or_Restriction_Warnings --
10336 --------------------------------------------------
10338 -- Note: some of the simple identifier cases were handled in par-prag,
10339 -- but it is harmless (and more straightforward) to simply handle all
10340 -- cases here, even if it means we repeat a bit of work in some cases.
10342 procedure Process_Restrictions_Or_Restriction_Warnings
10346 R_Id : Restriction_Id;
10352 -- Ignore all Restrictions pragmas in CodePeer mode
10354 if CodePeer_Mode then
10358 Check_Ada_83_Warning;
10359 Check_At_Least_N_Arguments (1);
10360 Check_Valid_Configuration_Pragma;
10363 while Present (Arg) loop
10365 Expr := Get_Pragma_Arg (Arg);
10367 -- Case of no restriction identifier present
10369 if Id = No_Name then
10370 if Nkind (Expr) /= N_Identifier then
10372 ("invalid form for restriction", Arg);
10377 (Process_Restriction_Synonyms (Expr));
10379 if R_Id not in All_Boolean_Restrictions then
10380 Error_Msg_Name_1 := Pname;
10382 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10384 -- Check for possible misspelling
10386 for J in Restriction_Id loop
10388 Rnm : constant String := Restriction_Id'Image (J);
10391 Name_Buffer (1 .. Rnm'Length) := Rnm;
10392 Name_Len := Rnm'Length;
10393 Set_Casing (All_Lower_Case);
10395 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10398 (Source_Index (Current_Sem_Unit)));
10399 Error_Msg_String (1 .. Rnm'Length) :=
10400 Name_Buffer (1 .. Name_Len);
10401 Error_Msg_Strlen := Rnm'Length;
10402 Error_Msg_N -- CODEFIX
10403 ("\possible misspelling of ""~""",
10404 Get_Pragma_Arg (Arg));
10413 if Implementation_Restriction (R_Id) then
10414 Check_Restriction (No_Implementation_Restrictions, Arg);
10417 -- Special processing for No_Elaboration_Code restriction
10419 if R_Id = No_Elaboration_Code then
10421 -- Restriction is only recognized within a configuration
10422 -- pragma file, or within a unit of the main extended
10423 -- program. Note: the test for Main_Unit is needed to
10424 -- properly include the case of configuration pragma files.
10426 if not (Current_Sem_Unit = Main_Unit
10427 or else In_Extended_Main_Source_Unit (N))
10431 -- Don't allow in a subunit unless already specified in
10434 elsif Nkind (Parent (N)) = N_Compilation_Unit
10435 and then Nkind (Unit (Parent (N))) = N_Subunit
10436 and then not Restriction_Active (No_Elaboration_Code)
10439 ("invalid specification of ""No_Elaboration_Code""",
10442 ("\restriction cannot be specified in a subunit", N);
10444 ("\unless also specified in body or spec", N);
10447 -- If we accept a No_Elaboration_Code restriction, then it
10448 -- needs to be added to the configuration restriction set so
10449 -- that we get proper application to other units in the main
10450 -- extended source as required.
10453 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10456 -- Special processing for No_Tasking restriction (not just a
10457 -- warning) when it appears as a configuration pragma.
10459 elsif R_Id = No_Tasking
10460 and then No (Cunit (Main_Unit))
10463 Set_Global_No_Tasking;
10466 Set_Restriction (R_Id, N, Warn);
10468 if R_Id = No_Dynamic_CPU_Assignment
10469 or else R_Id = No_Tasks_Unassigned_To_CPU
10471 -- These imply No_Dependence =>
10472 -- "System.Multiprocessors.Dispatching_Domains".
10473 -- This is not strictly what the AI says, but it eliminates
10474 -- the need for run-time checks, which are undesirable in
10477 Set_Restriction_No_Dependence
10479 (Sel_Comp ("system", "multiprocessors", Loc),
10480 "dispatching_domains"),
10484 if R_Id = No_Tasks_Unassigned_To_CPU then
10485 -- Likewise, imply No_Dynamic_CPU_Assignment
10487 Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
10490 -- Check for obsolescent restrictions in Ada 2005 mode
10493 and then Ada_Version >= Ada_2005
10494 and then (R_Id = No_Asynchronous_Control
10496 R_Id = No_Unchecked_Deallocation
10498 R_Id = No_Unchecked_Conversion)
10500 Check_Restriction (No_Obsolescent_Features, N);
10503 -- A very special case that must be processed here: pragma
10504 -- Restrictions (No_Exceptions) turns off all run-time
10505 -- checking. This is a bit dubious in terms of the formal
10506 -- language definition, but it is what is intended by RM
10507 -- H.4(12). Restriction_Warnings never affects generated code
10508 -- so this is done only in the real restriction case.
10510 -- Atomic_Synchronization is not a real check, so it is not
10511 -- affected by this processing).
10513 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10514 -- run-time checks in CodePeer and GNATprove modes: we want to
10515 -- generate checks for analysis purposes, as set respectively
10516 -- by -gnatC and -gnatd.F
10519 and then not (CodePeer_Mode or GNATprove_Mode)
10520 and then R_Id = No_Exceptions
10522 for J in Scope_Suppress.Suppress'Range loop
10523 if J /= Atomic_Synchronization then
10524 Scope_Suppress.Suppress (J) := True;
10529 -- Case of No_Dependence => unit-name. Note that the parser
10530 -- already made the necessary entry in the No_Dependence table.
10532 elsif Id = Name_No_Dependence then
10533 if not OK_No_Dependence_Unit_Name (Expr) then
10537 -- Case of No_Specification_Of_Aspect => aspect-identifier
10539 elsif Id = Name_No_Specification_Of_Aspect then
10544 if Nkind (Expr) /= N_Identifier then
10547 A_Id := Get_Aspect_Id (Chars (Expr));
10550 if A_Id = No_Aspect then
10551 Error_Pragma_Arg ("invalid restriction name", Arg);
10553 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10557 -- Case of No_Use_Of_Attribute => attribute-identifier
10559 elsif Id = Name_No_Use_Of_Attribute then
10560 if Nkind (Expr) /= N_Identifier
10561 or else not Is_Attribute_Name (Chars (Expr))
10563 Error_Msg_N ("unknown attribute name??", Expr);
10566 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10569 -- Case of No_Use_Of_Entity => fully-qualified-name
10571 elsif Id = Name_No_Use_Of_Entity then
10573 -- Restriction is only recognized within a configuration
10574 -- pragma file, or within a unit of the main extended
10575 -- program. Note: the test for Main_Unit is needed to
10576 -- properly include the case of configuration pragma files.
10578 if Current_Sem_Unit = Main_Unit
10579 or else In_Extended_Main_Source_Unit (N)
10581 if not OK_No_Dependence_Unit_Name (Expr) then
10582 Error_Msg_N ("wrong form for entity name", Expr);
10584 Set_Restriction_No_Use_Of_Entity
10585 (Expr, Warn, No_Profile);
10589 -- Case of No_Use_Of_Pragma => pragma-identifier
10591 elsif Id = Name_No_Use_Of_Pragma then
10592 if Nkind (Expr) /= N_Identifier
10593 or else not Is_Pragma_Name (Chars (Expr))
10595 Error_Msg_N ("unknown pragma name??", Expr);
10597 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10600 -- All other cases of restriction identifier present
10603 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10604 Analyze_And_Resolve (Expr, Any_Integer);
10606 if R_Id not in All_Parameter_Restrictions then
10608 ("invalid restriction parameter identifier", Arg);
10610 elsif not Is_OK_Static_Expression (Expr) then
10611 Flag_Non_Static_Expr
10612 ("value must be static expression!", Expr);
10615 elsif not Is_Integer_Type (Etype (Expr))
10616 or else Expr_Value (Expr) < 0
10619 ("value must be non-negative integer", Arg);
10622 -- Restriction pragma is active
10624 Val := Expr_Value (Expr);
10626 if not UI_Is_In_Int_Range (Val) then
10628 ("pragma ignored, value too large??", Arg);
10631 Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
10636 end Process_Restrictions_Or_Restriction_Warnings;
10638 ---------------------------------
10639 -- Process_Suppress_Unsuppress --
10640 ---------------------------------
10642 -- Note: this procedure makes entries in the check suppress data
10643 -- structures managed by Sem. See spec of package Sem for full
10644 -- details on how we handle recording of check suppression.
10646 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10651 In_Package_Spec : constant Boolean :=
10652 Is_Package_Or_Generic_Package (Current_Scope)
10653 and then not In_Package_Body (Current_Scope);
10655 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10656 -- Used to suppress a single check on the given entity
10658 --------------------------------
10659 -- Suppress_Unsuppress_Echeck --
10660 --------------------------------
10662 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10664 -- Check for error of trying to set atomic synchronization for
10665 -- a non-atomic variable.
10667 if C = Atomic_Synchronization
10668 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10671 ("pragma & requires atomic type or variable",
10672 Pragma_Identifier (Original_Node (N)));
10675 Set_Checks_May_Be_Suppressed (E);
10677 if In_Package_Spec then
10678 Push_Global_Suppress_Stack_Entry
10681 Suppress => Suppress_Case);
10683 Push_Local_Suppress_Stack_Entry
10686 Suppress => Suppress_Case);
10689 -- If this is a first subtype, and the base type is distinct,
10690 -- then also set the suppress flags on the base type.
10692 if Is_First_Subtype (E) and then Etype (E) /= E then
10693 Suppress_Unsuppress_Echeck (Etype (E), C);
10695 end Suppress_Unsuppress_Echeck;
10697 -- Start of processing for Process_Suppress_Unsuppress
10700 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10701 -- on user code: we want to generate checks for analysis purposes, as
10702 -- set respectively by -gnatC and -gnatd.F
10704 if Comes_From_Source (N)
10705 and then (CodePeer_Mode or GNATprove_Mode)
10710 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10711 -- declarative part or a package spec (RM 11.5(5)).
10713 if not Is_Configuration_Pragma then
10714 Check_Is_In_Decl_Part_Or_Package_Spec;
10717 Check_At_Least_N_Arguments (1);
10718 Check_At_Most_N_Arguments (2);
10719 Check_No_Identifier (Arg1);
10720 Check_Arg_Is_Identifier (Arg1);
10722 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10724 if C = No_Check_Id then
10726 ("argument of pragma% is not valid check name", Arg1);
10729 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10731 if C = Elaboration_Check and then SPARK_Mode = On then
10733 ("Suppress of Elaboration_Check ignored in SPARK??",
10734 "\elaboration checking rules are statically enforced "
10735 & "(SPARK RM 7.7)", Arg1);
10738 -- One-argument case
10740 if Arg_Count = 1 then
10742 -- Make an entry in the local scope suppress table. This is the
10743 -- table that directly shows the current value of the scope
10744 -- suppress check for any check id value.
10746 if C = All_Checks then
10748 -- For All_Checks, we set all specific predefined checks with
10749 -- the exception of Elaboration_Check, which is handled
10750 -- specially because of not wanting All_Checks to have the
10751 -- effect of deactivating static elaboration order processing.
10752 -- Atomic_Synchronization is also not affected, since this is
10753 -- not a real check.
10755 for J in Scope_Suppress.Suppress'Range loop
10756 if J /= Elaboration_Check
10758 J /= Atomic_Synchronization
10760 Scope_Suppress.Suppress (J) := Suppress_Case;
10764 -- If not All_Checks, and predefined check, then set appropriate
10765 -- scope entry. Note that we will set Elaboration_Check if this
10766 -- is explicitly specified. Atomic_Synchronization is allowed
10767 -- only if internally generated and entity is atomic.
10769 elsif C in Predefined_Check_Id
10770 and then (not Comes_From_Source (N)
10771 or else C /= Atomic_Synchronization)
10773 Scope_Suppress.Suppress (C) := Suppress_Case;
10776 -- Also make an entry in the Local_Entity_Suppress table
10778 Push_Local_Suppress_Stack_Entry
10781 Suppress => Suppress_Case);
10783 -- Case of two arguments present, where the check is suppressed for
10784 -- a specified entity (given as the second argument of the pragma)
10787 -- This is obsolescent in Ada 2005 mode
10789 if Ada_Version >= Ada_2005 then
10790 Check_Restriction (No_Obsolescent_Features, Arg2);
10793 Check_Optional_Identifier (Arg2, Name_On);
10794 E_Id := Get_Pragma_Arg (Arg2);
10797 if not Is_Entity_Name (E_Id) then
10799 ("second argument of pragma% must be entity name", Arg2);
10802 E := Entity (E_Id);
10808 -- A pragma that applies to a Ghost entity becomes Ghost for the
10809 -- purposes of legality checks and removal of ignored Ghost code.
10811 Mark_Ghost_Pragma (N, E);
10813 -- Enforce RM 11.5(7) which requires that for a pragma that
10814 -- appears within a package spec, the named entity must be
10815 -- within the package spec. We allow the package name itself
10816 -- to be mentioned since that makes sense, although it is not
10817 -- strictly allowed by 11.5(7).
10820 and then E /= Current_Scope
10821 and then Scope (E) /= Current_Scope
10824 ("entity in pragma% is not in package spec (RM 11.5(7))",
10828 -- Loop through homonyms. As noted below, in the case of a package
10829 -- spec, only homonyms within the package spec are considered.
10832 Suppress_Unsuppress_Echeck (E, C);
10834 if Is_Generic_Instance (E)
10835 and then Is_Subprogram (E)
10836 and then Present (Alias (E))
10838 Suppress_Unsuppress_Echeck (Alias (E), C);
10841 -- Move to next homonym if not aspect spec case
10843 exit when From_Aspect_Specification (N);
10847 -- If we are within a package specification, the pragma only
10848 -- applies to homonyms in the same scope.
10850 exit when In_Package_Spec
10851 and then Scope (E) /= Current_Scope;
10854 end Process_Suppress_Unsuppress;
10856 -------------------------------
10857 -- Record_Independence_Check --
10858 -------------------------------
10860 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10861 pragma Unreferenced (N, E);
10863 -- For GCC back ends the validation is done a priori
10864 -- ??? This code is dead, might be useful in the future
10866 -- if not AAMP_On_Target then
10870 -- Independence_Checks.Append ((N, E));
10873 end Record_Independence_Check;
10879 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10881 if Is_Imported (E) then
10883 ("cannot export entity& that was previously imported", Arg);
10885 elsif Present (Address_Clause (E))
10886 and then not Relaxed_RM_Semantics
10889 ("cannot export entity& that has an address clause", Arg);
10892 Set_Is_Exported (E);
10894 -- Generate a reference for entity explicitly, because the
10895 -- identifier may be overloaded and name resolution will not
10898 Generate_Reference (E, Arg);
10900 -- Deal with exporting non-library level entity
10902 if not Is_Library_Level_Entity (E) then
10904 -- Not allowed at all for subprograms
10906 if Is_Subprogram (E) then
10907 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10909 -- Otherwise set public and statically allocated
10913 Set_Is_Statically_Allocated (E);
10915 -- Warn if the corresponding W flag is set
10917 if Warn_On_Export_Import
10919 -- Only do this for something that was in the source. Not
10920 -- clear if this can be False now (there used for sure to be
10921 -- cases on some systems where it was False), but anyway the
10922 -- test is harmless if not needed, so it is retained.
10924 and then Comes_From_Source (Arg)
10927 ("?x?& has been made static as a result of Export",
10930 ("\?x?this usage is non-standard and non-portable",
10936 if Warn_On_Export_Import and then Is_Type (E) then
10937 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10940 if Warn_On_Export_Import and Inside_A_Generic then
10942 ("all instances of& will have the same external name?x?",
10947 ----------------------------------------------
10948 -- Set_Extended_Import_Export_External_Name --
10949 ----------------------------------------------
10951 procedure Set_Extended_Import_Export_External_Name
10952 (Internal_Ent : Entity_Id;
10953 Arg_External : Node_Id)
10955 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10956 New_Name : Node_Id;
10959 if No (Arg_External) then
10963 Check_Arg_Is_External_Name (Arg_External);
10965 if Nkind (Arg_External) = N_String_Literal then
10966 if String_Length (Strval (Arg_External)) = 0 then
10969 New_Name := Adjust_External_Name_Case (Arg_External);
10972 elsif Nkind (Arg_External) = N_Identifier then
10973 New_Name := Get_Default_External_Name (Arg_External);
10975 -- Check_Arg_Is_External_Name should let through only identifiers and
10976 -- string literals or static string expressions (which are folded to
10977 -- string literals).
10980 raise Program_Error;
10983 -- If we already have an external name set (by a prior normal Import
10984 -- or Export pragma), then the external names must match
10986 if Present (Interface_Name (Internal_Ent)) then
10988 -- Ignore mismatching names in CodePeer mode, to support some
10989 -- old compilers which would export the same procedure under
10990 -- different names, e.g:
10992 -- pragma Export_Procedure (P, "a");
10993 -- pragma Export_Procedure (P, "b");
10995 if CodePeer_Mode then
10999 Check_Matching_Internal_Names : declare
11000 S1 : constant String_Id := Strval (Old_Name);
11001 S2 : constant String_Id := Strval (New_Name);
11003 procedure Mismatch;
11004 pragma No_Return (Mismatch);
11005 -- Called if names do not match
11011 procedure Mismatch is
11013 Error_Msg_Sloc := Sloc (Old_Name);
11015 ("external name does not match that given #",
11019 -- Start of processing for Check_Matching_Internal_Names
11022 if String_Length (S1) /= String_Length (S2) then
11026 for J in 1 .. String_Length (S1) loop
11027 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11032 end Check_Matching_Internal_Names;
11034 -- Otherwise set the given name
11037 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11038 Check_Duplicated_Export_Name (New_Name);
11040 end Set_Extended_Import_Export_External_Name;
11046 procedure Set_Imported (E : Entity_Id) is
11048 -- Error message if already imported or exported
11050 if Is_Exported (E) or else Is_Imported (E) then
11052 -- Error if being set Exported twice
11054 if Is_Exported (E) then
11055 Error_Msg_NE ("entity& was previously exported", N, E);
11057 -- Ignore error in CodePeer mode where we treat all imported
11058 -- subprograms as unknown.
11060 elsif CodePeer_Mode then
11063 -- OK if Import/Interface case
11065 elsif Import_Interface_Present (N) then
11068 -- Error if being set Imported twice
11071 Error_Msg_NE ("entity& was previously imported", N, E);
11074 Error_Msg_Name_1 := Pname;
11076 ("\(pragma% applies to all previous entities)", N);
11078 Error_Msg_Sloc := Sloc (E);
11079 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11081 -- Here if not previously imported or exported, OK to import
11084 Set_Is_Imported (E);
11086 -- For subprogram, set Import_Pragma field
11088 if Is_Subprogram (E) then
11089 Set_Import_Pragma (E, N);
11092 -- If the entity is an object that is not at the library level,
11093 -- then it is statically allocated. We do not worry about objects
11094 -- with address clauses in this context since they are not really
11095 -- imported in the linker sense.
11098 and then not Is_Library_Level_Entity (E)
11099 and then No (Address_Clause (E))
11101 Set_Is_Statically_Allocated (E);
11108 -------------------------
11109 -- Set_Mechanism_Value --
11110 -------------------------
11112 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11113 -- analyzed, since it is semantic nonsense), so we get it in the exact
11114 -- form created by the parser.
11116 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11117 procedure Bad_Mechanism;
11118 pragma No_Return (Bad_Mechanism);
11119 -- Signal bad mechanism name
11121 -------------------
11122 -- Bad_Mechanism --
11123 -------------------
11125 procedure Bad_Mechanism is
11127 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11130 -- Start of processing for Set_Mechanism_Value
11133 if Mechanism (Ent) /= Default_Mechanism then
11135 ("mechanism for & has already been set", Mech_Name, Ent);
11138 -- MECHANISM_NAME ::= value | reference
11140 if Nkind (Mech_Name) = N_Identifier then
11141 if Chars (Mech_Name) = Name_Value then
11142 Set_Mechanism (Ent, By_Copy);
11145 elsif Chars (Mech_Name) = Name_Reference then
11146 Set_Mechanism (Ent, By_Reference);
11149 elsif Chars (Mech_Name) = Name_Copy then
11151 ("bad mechanism name, Value assumed", Mech_Name);
11160 end Set_Mechanism_Value;
11162 --------------------------
11163 -- Set_Rational_Profile --
11164 --------------------------
11166 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11167 -- extension to the semantics of renaming declarations.
11169 procedure Set_Rational_Profile is
11171 Implicit_Packing := True;
11172 Overriding_Renamings := True;
11173 Use_VADS_Size := True;
11174 end Set_Rational_Profile;
11176 ---------------------------
11177 -- Set_Ravenscar_Profile --
11178 ---------------------------
11180 -- The tasks to be done here are
11182 -- Set required policies
11184 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11185 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11186 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11187 -- (For GNAT_Ravenscar_EDF profile)
11188 -- pragma Locking_Policy (Ceiling_Locking)
11190 -- Set Detect_Blocking mode
11192 -- Set required restrictions (see System.Rident for detailed list)
11194 -- Set the No_Dependence rules
11195 -- No_Dependence => Ada.Asynchronous_Task_Control
11196 -- No_Dependence => Ada.Calendar
11197 -- No_Dependence => Ada.Execution_Time.Group_Budget
11198 -- No_Dependence => Ada.Execution_Time.Timers
11199 -- No_Dependence => Ada.Task_Attributes
11200 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11202 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11203 procedure Set_Error_Msg_To_Profile_Name;
11204 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11207 -----------------------------------
11208 -- Set_Error_Msg_To_Profile_Name --
11209 -----------------------------------
11211 procedure Set_Error_Msg_To_Profile_Name is
11212 Prof_Nam : constant Node_Id :=
11214 (First (Pragma_Argument_Associations (N)));
11217 Get_Name_String (Chars (Prof_Nam));
11218 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11219 Error_Msg_Strlen := Name_Len;
11220 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11221 end Set_Error_Msg_To_Profile_Name;
11223 Profile_Dispatching_Policy : Character;
11225 -- Start of processing for Set_Ravenscar_Profile
11228 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11230 if Profile = GNAT_Ravenscar_EDF then
11231 Profile_Dispatching_Policy := 'E';
11233 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11236 Profile_Dispatching_Policy := 'F';
11239 if Task_Dispatching_Policy /= ' '
11240 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11242 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11243 Set_Error_Msg_To_Profile_Name;
11244 Error_Pragma ("Profile (~) incompatible with policy#");
11246 -- Set the FIFO_Within_Priorities policy, but always preserve
11247 -- System_Location since we like the error message with the run time
11251 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11253 if Task_Dispatching_Policy_Sloc /= System_Location then
11254 Task_Dispatching_Policy_Sloc := Loc;
11258 -- pragma Locking_Policy (Ceiling_Locking)
11260 if Locking_Policy /= ' '
11261 and then Locking_Policy /= 'C'
11263 Error_Msg_Sloc := Locking_Policy_Sloc;
11264 Set_Error_Msg_To_Profile_Name;
11265 Error_Pragma ("Profile (~) incompatible with policy#");
11267 -- Set the Ceiling_Locking policy, but preserve System_Location since
11268 -- we like the error message with the run time name.
11271 Locking_Policy := 'C';
11273 if Locking_Policy_Sloc /= System_Location then
11274 Locking_Policy_Sloc := Loc;
11278 -- pragma Detect_Blocking
11280 Detect_Blocking := True;
11282 -- Set the corresponding restrictions
11284 Set_Profile_Restrictions
11285 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11287 -- Set the No_Dependence restrictions
11289 -- The following No_Dependence restrictions:
11290 -- No_Dependence => Ada.Asynchronous_Task_Control
11291 -- No_Dependence => Ada.Calendar
11292 -- No_Dependence => Ada.Task_Attributes
11293 -- are already set by previous call to Set_Profile_Restrictions.
11296 -- Set the following restrictions which were added to Ada 2005:
11297 -- No_Dependence => Ada.Execution_Time.Group_Budget
11298 -- No_Dependence => Ada.Execution_Time.Timers
11300 if Ada_Version >= Ada_2005 then
11302 Execution_Time : constant Node_Id :=
11303 Sel_Comp ("ada", "execution_time", Loc);
11304 Group_Budgets : constant Node_Id :=
11305 Sel_Comp (Execution_Time, "group_budgets");
11306 Timers : constant Node_Id :=
11307 Sel_Comp (Execution_Time, "timers");
11309 Set_Restriction_No_Dependence
11310 (Unit => Group_Budgets,
11311 Warn => Treat_Restrictions_As_Warnings,
11312 Profile => Ravenscar);
11313 Set_Restriction_No_Dependence
11315 Warn => Treat_Restrictions_As_Warnings,
11316 Profile => Ravenscar);
11320 -- Set the following restriction which was added to Ada 2012 (see
11322 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11324 if Ada_Version >= Ada_2012 then
11325 Set_Restriction_No_Dependence
11327 (Sel_Comp ("system", "multiprocessors", Loc),
11328 "dispatching_domains"),
11329 Warn => Treat_Restrictions_As_Warnings,
11330 Profile => Ravenscar);
11332 -- Set the following restriction which was added to Ada 2020,
11333 -- but as a binding interpretation:
11334 -- No_Dependence => Ada.Synchronous_Barriers
11335 -- for Ravenscar (and therefore for Ravenscar variants) but not
11336 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11337 -- in Ada2012 (AI05-0174).
11339 if Profile /= Jorvik then
11340 Set_Restriction_No_Dependence
11341 (Sel_Comp ("ada", "synchronous_barriers", Loc),
11342 Warn => Treat_Restrictions_As_Warnings,
11343 Profile => Ravenscar);
11347 end Set_Ravenscar_Profile;
11349 -- Start of processing for Analyze_Pragma
11352 -- The following code is a defense against recursion. Not clear that
11353 -- this can happen legitimately, but perhaps some error situations can
11354 -- cause it, and we did see this recursion during testing.
11356 if Analyzed (N) then
11362 Check_Restriction_No_Use_Of_Pragma (N);
11364 if Get_Aspect_Id (Chars (Pragma_Identifier (N))) /= No_Aspect then
11365 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11366 -- no aspect_specification, attribute_definition_clause, or pragma
11368 Check_Restriction_No_Specification_Of_Aspect (N);
11371 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11372 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11374 if Should_Ignore_Pragma_Sem (N)
11375 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11376 and then Ignore_Rep_Clauses)
11381 -- Deal with unrecognized pragma
11383 if not Is_Pragma_Name (Pname) then
11385 Msg_Issued : Boolean := False;
11388 (Msg_Issued, No_Unrecognized_Pragmas, Pragma_Identifier (N));
11389 if not Msg_Issued and then Warn_On_Unrecognized_Pragma then
11390 Error_Msg_Name_1 := Pname;
11391 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11393 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11394 if Is_Bad_Spelling_Of (Pname, PN) then
11395 Error_Msg_Name_1 := PN;
11396 Error_Msg_N -- CODEFIX
11397 ("\?g?possible misspelling of %!",
11398 Pragma_Identifier (N));
11408 -- Here to start processing for recognized pragma
11410 Pname := Original_Aspect_Pragma_Name (N);
11412 -- Capture setting of Opt.Uneval_Old
11414 case Opt.Uneval_Old is
11416 Set_Uneval_Old_Accept (N);
11422 Set_Uneval_Old_Warn (N);
11425 raise Program_Error;
11428 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11429 -- is already set, indicating that we have already checked the policy
11430 -- at the right point. This happens for example in the case of a pragma
11431 -- that is derived from an Aspect.
11433 if Is_Ignored (N) or else Is_Checked (N) then
11436 -- For a pragma that is a rewriting of another pragma, copy the
11437 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11439 elsif Is_Rewrite_Substitution (N)
11440 and then Nkind (Original_Node (N)) = N_Pragma
11442 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11443 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11445 -- Otherwise query the applicable policy at this point
11448 Check_Applicable_Policy (N);
11450 -- If pragma is disabled, rewrite as NULL and skip analysis
11452 if Is_Disabled (N) then
11453 Rewrite (N, Make_Null_Statement (Loc));
11459 -- Mark assertion pragmas as Ghost depending on their enclosing context
11461 if Assertion_Expression_Pragma (Prag_Id) then
11462 Mark_Ghost_Pragma (N, Current_Scope);
11465 -- Preset arguments
11474 if Present (Pragma_Argument_Associations (N)) then
11475 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11476 Arg1 := First (Pragma_Argument_Associations (N));
11478 if Present (Arg1) then
11479 Arg2 := Next (Arg1);
11481 if Present (Arg2) then
11482 Arg3 := Next (Arg2);
11484 if Present (Arg3) then
11485 Arg4 := Next (Arg3);
11487 if Present (Arg4) then
11488 Arg5 := Next (Arg4);
11495 -- An enumeration type defines the pragmas that are supported by the
11496 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11497 -- into the corresponding enumeration value for the following case.
11505 -- pragma Abort_Defer;
11507 when Pragma_Abort_Defer =>
11509 Check_Arg_Count (0);
11511 -- The only required semantic processing is to check the
11512 -- placement. This pragma must appear at the start of the
11513 -- statement sequence of a handled sequence of statements.
11515 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11516 or else N /= First (Statements (Parent (N)))
11521 --------------------
11522 -- Abstract_State --
11523 --------------------
11525 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11527 -- ABSTRACT_STATE_LIST ::=
11529 -- | STATE_NAME_WITH_OPTIONS
11530 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11532 -- STATE_NAME_WITH_OPTIONS ::=
11534 -- | (STATE_NAME with OPTION_LIST)
11536 -- OPTION_LIST ::= OPTION {, OPTION}
11540 -- | NAME_VALUE_OPTION
11542 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11544 -- NAME_VALUE_OPTION ::=
11545 -- Part_Of => ABSTRACT_STATE
11546 -- | External [=> EXTERNAL_PROPERTY_LIST]
11548 -- EXTERNAL_PROPERTY_LIST ::=
11549 -- EXTERNAL_PROPERTY
11550 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11552 -- EXTERNAL_PROPERTY ::=
11553 -- Async_Readers [=> boolean_EXPRESSION]
11554 -- | Async_Writers [=> boolean_EXPRESSION]
11555 -- | Effective_Reads [=> boolean_EXPRESSION]
11556 -- | Effective_Writes [=> boolean_EXPRESSION]
11557 -- others => boolean_EXPRESSION
11559 -- STATE_NAME ::= defining_identifier
11561 -- ABSTRACT_STATE ::= name
11563 -- Characteristics:
11565 -- * Analysis - The annotation is fully analyzed immediately upon
11566 -- elaboration as it cannot forward reference entities.
11568 -- * Expansion - None.
11570 -- * Template - The annotation utilizes the generic template of the
11571 -- related package declaration.
11573 -- * Globals - The annotation cannot reference global entities.
11575 -- * Instance - The annotation is instantiated automatically when
11576 -- the related generic package is instantiated.
11578 when Pragma_Abstract_State => Abstract_State : declare
11579 Missing_Parentheses : Boolean := False;
11580 -- Flag set when a state declaration with options is not properly
11583 -- Flags used to verify the consistency of states
11585 Non_Null_Seen : Boolean := False;
11586 Null_Seen : Boolean := False;
11588 procedure Analyze_Abstract_State
11590 Pack_Id : Entity_Id);
11591 -- Verify the legality of a single state declaration. Create and
11592 -- decorate a state abstraction entity and introduce it into the
11593 -- visibility chain. Pack_Id denotes the entity or the related
11594 -- package where pragma Abstract_State appears.
11596 procedure Malformed_State_Error (State : Node_Id);
11597 -- Emit an error concerning the illegal declaration of abstract
11598 -- state State. This routine diagnoses syntax errors that lead to
11599 -- a different parse tree. The error is issued regardless of the
11600 -- SPARK mode in effect.
11602 ----------------------------
11603 -- Analyze_Abstract_State --
11604 ----------------------------
11606 procedure Analyze_Abstract_State
11608 Pack_Id : Entity_Id)
11610 -- Flags used to verify the consistency of options
11612 AR_Seen : Boolean := False;
11613 AW_Seen : Boolean := False;
11614 ER_Seen : Boolean := False;
11615 EW_Seen : Boolean := False;
11616 External_Seen : Boolean := False;
11617 Ghost_Seen : Boolean := False;
11618 Others_Seen : Boolean := False;
11619 Part_Of_Seen : Boolean := False;
11620 Relaxed_Initialization_Seen : Boolean := False;
11621 Synchronous_Seen : Boolean := False;
11623 -- Flags used to store the static value of all external states'
11626 AR_Val : Boolean := False;
11627 AW_Val : Boolean := False;
11628 ER_Val : Boolean := False;
11629 EW_Val : Boolean := False;
11631 State_Id : Entity_Id := Empty;
11632 -- The entity to be generated for the current state declaration
11634 procedure Analyze_External_Option (Opt : Node_Id);
11635 -- Verify the legality of option External
11637 procedure Analyze_External_Property
11639 Expr : Node_Id := Empty);
11640 -- Verify the legailty of a single external property. Prop
11641 -- denotes the external property. Expr is the expression used
11642 -- to set the property.
11644 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11645 -- Verify the legality of option Part_Of
11647 procedure Check_Duplicate_Option
11649 Status : in out Boolean);
11650 -- Flag Status denotes whether a particular option has been
11651 -- seen while processing a state. This routine verifies that
11652 -- Opt is not a duplicate option and sets the flag Status
11653 -- (SPARK RM 7.1.4(1)).
11655 procedure Check_Duplicate_Property
11657 Status : in out Boolean);
11658 -- Flag Status denotes whether a particular property has been
11659 -- seen while processing option External. This routine verifies
11660 -- that Prop is not a duplicate property and sets flag Status.
11661 -- Opt is not a duplicate property and sets the flag Status.
11662 -- (SPARK RM 7.1.4(2))
11664 procedure Check_Ghost_Synchronous;
11665 -- Ensure that the abstract state is not subject to both Ghost
11666 -- and Synchronous simple options. Emit an error if this is the
11669 procedure Create_Abstract_State
11673 Is_Null : Boolean);
11674 -- Generate an abstract state entity with name Nam and enter it
11675 -- into visibility. Decl is the "declaration" of the state as
11676 -- it appears in pragma Abstract_State. Loc is the location of
11677 -- the related state "declaration". Flag Is_Null should be set
11678 -- when the associated Abstract_State pragma defines a null
11681 -----------------------------
11682 -- Analyze_External_Option --
11683 -----------------------------
11685 procedure Analyze_External_Option (Opt : Node_Id) is
11686 Errors : constant Nat := Serious_Errors_Detected;
11688 Props : Node_Id := Empty;
11691 if Nkind (Opt) = N_Component_Association then
11692 Props := Expression (Opt);
11695 -- External state with properties
11697 if Present (Props) then
11699 -- Multiple properties appear as an aggregate
11701 if Nkind (Props) = N_Aggregate then
11703 -- Simple property form
11705 Prop := First (Expressions (Props));
11706 while Present (Prop) loop
11707 Analyze_External_Property (Prop);
11711 -- Property with expression form
11713 Prop := First (Component_Associations (Props));
11714 while Present (Prop) loop
11715 Analyze_External_Property
11716 (Prop => First (Choices (Prop)),
11717 Expr => Expression (Prop));
11725 Analyze_External_Property (Props);
11728 -- An external state defined without any properties defaults
11729 -- all properties to True.
11738 -- Once all external properties have been processed, verify
11739 -- their mutual interaction. Do not perform the check when
11740 -- at least one of the properties is illegal as this will
11741 -- produce a bogus error.
11743 if Errors = Serious_Errors_Detected then
11744 Check_External_Properties
11745 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11747 end Analyze_External_Option;
11749 -------------------------------
11750 -- Analyze_External_Property --
11751 -------------------------------
11753 procedure Analyze_External_Property
11755 Expr : Node_Id := Empty)
11757 Expr_Val : Boolean;
11760 -- Check the placement of "others" (if available)
11762 if Nkind (Prop) = N_Others_Choice then
11763 if Others_Seen then
11765 ("only one others choice allowed in option External",
11768 Others_Seen := True;
11771 elsif Others_Seen then
11773 ("others must be the last property in option External",
11776 -- The only remaining legal options are the four predefined
11777 -- external properties.
11779 elsif Nkind (Prop) = N_Identifier
11780 and then Chars (Prop) in Name_Async_Readers
11781 | Name_Async_Writers
11782 | Name_Effective_Reads
11783 | Name_Effective_Writes
11787 -- Otherwise the construct is not a valid property
11790 SPARK_Msg_N ("invalid external state property", Prop);
11794 -- Ensure that the expression of the external state property
11795 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11797 if Present (Expr) then
11798 Analyze_And_Resolve (Expr, Standard_Boolean);
11800 if Is_OK_Static_Expression (Expr) then
11801 Expr_Val := Is_True (Expr_Value (Expr));
11804 ("expression of external state property must be "
11809 -- The lack of expression defaults the property to True
11815 -- Named properties
11817 if Nkind (Prop) = N_Identifier then
11818 if Chars (Prop) = Name_Async_Readers then
11819 Check_Duplicate_Property (Prop, AR_Seen);
11820 AR_Val := Expr_Val;
11822 elsif Chars (Prop) = Name_Async_Writers then
11823 Check_Duplicate_Property (Prop, AW_Seen);
11824 AW_Val := Expr_Val;
11826 elsif Chars (Prop) = Name_Effective_Reads then
11827 Check_Duplicate_Property (Prop, ER_Seen);
11828 ER_Val := Expr_Val;
11831 Check_Duplicate_Property (Prop, EW_Seen);
11832 EW_Val := Expr_Val;
11835 -- The handling of property "others" must take into account
11836 -- all other named properties that have been encountered so
11837 -- far. Only those that have not been seen are affected by
11841 if not AR_Seen then
11842 AR_Val := Expr_Val;
11845 if not AW_Seen then
11846 AW_Val := Expr_Val;
11849 if not ER_Seen then
11850 ER_Val := Expr_Val;
11853 if not EW_Seen then
11854 EW_Val := Expr_Val;
11857 end Analyze_External_Property;
11859 ----------------------------
11860 -- Analyze_Part_Of_Option --
11861 ----------------------------
11863 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11864 Encap : constant Node_Id := Expression (Opt);
11865 Constits : Elist_Id;
11866 Encap_Id : Entity_Id;
11870 Check_Duplicate_Option (Opt, Part_Of_Seen);
11873 (Indic => First (Choices (Opt)),
11874 Item_Id => State_Id,
11876 Encap_Id => Encap_Id,
11879 -- The Part_Of indicator transforms the abstract state into
11880 -- a constituent of the encapsulating state or single
11881 -- concurrent type.
11884 pragma Assert (Present (Encap_Id));
11885 Constits := Part_Of_Constituents (Encap_Id);
11887 if No (Constits) then
11888 Constits := New_Elmt_List;
11889 Set_Part_Of_Constituents (Encap_Id, Constits);
11892 Append_Elmt (State_Id, Constits);
11893 Set_Encapsulating_State (State_Id, Encap_Id);
11895 end Analyze_Part_Of_Option;
11897 ----------------------------
11898 -- Check_Duplicate_Option --
11899 ----------------------------
11901 procedure Check_Duplicate_Option
11903 Status : in out Boolean)
11907 SPARK_Msg_N ("duplicate state option", Opt);
11911 end Check_Duplicate_Option;
11913 ------------------------------
11914 -- Check_Duplicate_Property --
11915 ------------------------------
11917 procedure Check_Duplicate_Property
11919 Status : in out Boolean)
11923 SPARK_Msg_N ("duplicate external property", Prop);
11927 end Check_Duplicate_Property;
11929 -----------------------------
11930 -- Check_Ghost_Synchronous --
11931 -----------------------------
11933 procedure Check_Ghost_Synchronous is
11935 -- A synchronized abstract state cannot be Ghost and vice
11936 -- versa (SPARK RM 6.9(19)).
11938 if Ghost_Seen and Synchronous_Seen then
11939 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11941 end Check_Ghost_Synchronous;
11943 ---------------------------
11944 -- Create_Abstract_State --
11945 ---------------------------
11947 procedure Create_Abstract_State
11954 -- The abstract state may be semi-declared when the related
11955 -- package was withed through a limited with clause. In that
11956 -- case reuse the entity to fully declare the state.
11958 if Present (Decl) and then Present (Entity (Decl)) then
11959 State_Id := Entity (Decl);
11961 -- Otherwise the elaboration of pragma Abstract_State
11962 -- declares the state.
11965 State_Id := Make_Defining_Identifier (Loc, Nam);
11967 if Present (Decl) then
11968 Set_Entity (Decl, State_Id);
11972 -- Null states never come from source
11974 Set_Comes_From_Source (State_Id, not Is_Null);
11975 Set_Parent (State_Id, State);
11976 Set_Ekind (State_Id, E_Abstract_State);
11977 Set_Etype (State_Id, Standard_Void_Type);
11978 Set_Encapsulating_State (State_Id, Empty);
11980 -- Set the SPARK mode from the current context
11982 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
11983 Set_SPARK_Pragma_Inherited (State_Id);
11985 -- An abstract state declared within a Ghost region becomes
11986 -- Ghost (SPARK RM 6.9(2)).
11988 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11989 Set_Is_Ghost_Entity (State_Id);
11992 -- Establish a link between the state declaration and the
11993 -- abstract state entity. Note that a null state remains as
11994 -- N_Null and does not carry any linkages.
11996 if not Is_Null then
11997 if Present (Decl) then
11998 Set_Entity (Decl, State_Id);
11999 Set_Etype (Decl, Standard_Void_Type);
12002 -- Every non-null state must be defined, nameable and
12005 Push_Scope (Pack_Id);
12006 Generate_Definition (State_Id);
12007 Enter_Name (State_Id);
12010 end Create_Abstract_State;
12017 -- Start of processing for Analyze_Abstract_State
12020 -- A package with a null abstract state is not allowed to
12021 -- declare additional states.
12025 ("package & has null abstract state", State, Pack_Id);
12027 -- Null states appear as internally generated entities
12029 elsif Nkind (State) = N_Null then
12030 Create_Abstract_State
12031 (Nam => New_Internal_Name ('S'),
12033 Loc => Sloc (State),
12037 -- Catch a case where a null state appears in a list of
12038 -- non-null states.
12040 if Non_Null_Seen then
12042 ("package & has non-null abstract state",
12046 -- Simple state declaration
12048 elsif Nkind (State) = N_Identifier then
12049 Create_Abstract_State
12050 (Nam => Chars (State),
12052 Loc => Sloc (State),
12054 Non_Null_Seen := True;
12056 -- State declaration with various options. This construct
12057 -- appears as an extension aggregate in the tree.
12059 elsif Nkind (State) = N_Extension_Aggregate then
12060 if Nkind (Ancestor_Part (State)) = N_Identifier then
12061 Create_Abstract_State
12062 (Nam => Chars (Ancestor_Part (State)),
12063 Decl => Ancestor_Part (State),
12064 Loc => Sloc (Ancestor_Part (State)),
12066 Non_Null_Seen := True;
12069 ("state name must be an identifier",
12070 Ancestor_Part (State));
12073 -- Options External, Ghost and Synchronous appear as
12076 Opt := First (Expressions (State));
12077 while Present (Opt) loop
12078 if Nkind (Opt) = N_Identifier then
12082 if Chars (Opt) = Name_External then
12083 Check_Duplicate_Option (Opt, External_Seen);
12084 Analyze_External_Option (Opt);
12088 elsif Chars (Opt) = Name_Ghost then
12089 Check_Duplicate_Option (Opt, Ghost_Seen);
12090 Check_Ghost_Synchronous;
12092 if Present (State_Id) then
12093 Set_Is_Ghost_Entity (State_Id);
12098 elsif Chars (Opt) = Name_Synchronous then
12099 Check_Duplicate_Option (Opt, Synchronous_Seen);
12100 Check_Ghost_Synchronous;
12102 -- Relaxed_Initialization
12104 elsif Chars (Opt) = Name_Relaxed_Initialization then
12105 Check_Duplicate_Option
12106 (Opt, Relaxed_Initialization_Seen);
12108 -- Option Part_Of without an encapsulating state is
12109 -- illegal (SPARK RM 7.1.4(8)).
12111 elsif Chars (Opt) = Name_Part_Of then
12113 ("indicator Part_Of must denote abstract state, "
12114 & "single protected type or single task type",
12117 -- Do not emit an error message when a previous state
12118 -- declaration with options was not parenthesized as
12119 -- the option is actually another state declaration.
12121 -- with Abstract_State
12122 -- (State_1 with ..., -- missing parentheses
12123 -- (State_2 with ...),
12124 -- State_3) -- ok state declaration
12126 elsif Missing_Parentheses then
12129 -- Otherwise the option is not allowed. Note that it
12130 -- is not possible to distinguish between an option
12131 -- and a state declaration when a previous state with
12132 -- options not properly parentheses.
12134 -- with Abstract_State
12135 -- (State_1 with ..., -- missing parentheses
12136 -- State_2); -- could be an option
12140 ("simple option not allowed in state declaration",
12144 -- Catch a case where missing parentheses around a state
12145 -- declaration with options cause a subsequent state
12146 -- declaration with options to be treated as an option.
12148 -- with Abstract_State
12149 -- (State_1 with ..., -- missing parentheses
12150 -- (State_2 with ...))
12152 elsif Nkind (Opt) = N_Extension_Aggregate then
12153 Missing_Parentheses := True;
12155 ("state declaration must be parenthesized",
12156 Ancestor_Part (State));
12158 -- Otherwise the option is malformed
12161 SPARK_Msg_N ("malformed option", Opt);
12167 -- Options External and Part_Of appear as component
12170 Opt := First (Component_Associations (State));
12171 while Present (Opt) loop
12172 Opt_Nam := First (Choices (Opt));
12174 if Nkind (Opt_Nam) = N_Identifier then
12175 if Chars (Opt_Nam) = Name_External then
12176 Analyze_External_Option (Opt);
12178 elsif Chars (Opt_Nam) = Name_Part_Of then
12179 Analyze_Part_Of_Option (Opt);
12182 SPARK_Msg_N ("invalid state option", Opt);
12185 SPARK_Msg_N ("invalid state option", Opt);
12191 -- Any other attempt to declare a state is illegal
12194 Malformed_State_Error (State);
12198 -- Guard against a junk state. In such cases no entity is
12199 -- generated and the subsequent checks cannot be applied.
12201 if Present (State_Id) then
12203 -- Verify whether the state does not introduce an illegal
12204 -- hidden state within a package subject to a null abstract
12207 Check_No_Hidden_State (State_Id);
12209 -- Check whether the lack of option Part_Of agrees with the
12210 -- placement of the abstract state with respect to the state
12213 if not Part_Of_Seen then
12214 Check_Missing_Part_Of (State_Id);
12217 -- Associate the state with its related package
12219 if No (Abstract_States (Pack_Id)) then
12220 Set_Abstract_States (Pack_Id, New_Elmt_List);
12223 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12225 end Analyze_Abstract_State;
12227 ---------------------------
12228 -- Malformed_State_Error --
12229 ---------------------------
12231 procedure Malformed_State_Error (State : Node_Id) is
12233 Error_Msg_N ("malformed abstract state declaration", State);
12235 -- An abstract state with a simple option is being declared
12236 -- with "=>" rather than the legal "with". The state appears
12237 -- as a component association.
12239 if Nkind (State) = N_Component_Association then
12240 Error_Msg_N ("\use WITH to specify simple option", State);
12242 end Malformed_State_Error;
12246 Pack_Decl : Node_Id;
12247 Pack_Id : Entity_Id;
12251 -- Start of processing for Abstract_State
12255 Check_No_Identifiers;
12256 Check_Arg_Count (1);
12258 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12260 if Nkind (Pack_Decl) not in
12261 N_Generic_Package_Declaration | N_Package_Declaration
12267 Pack_Id := Defining_Entity (Pack_Decl);
12269 -- A pragma that applies to a Ghost entity becomes Ghost for the
12270 -- purposes of legality checks and removal of ignored Ghost code.
12272 Mark_Ghost_Pragma (N, Pack_Id);
12273 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12275 -- Chain the pragma on the contract for completeness
12277 Add_Contract_Item (N, Pack_Id);
12279 -- The legality checks of pragmas Abstract_State, Initializes, and
12280 -- Initial_Condition are affected by the SPARK mode in effect. In
12281 -- addition, these three pragmas are subject to an inherent order:
12283 -- 1) Abstract_State
12285 -- 3) Initial_Condition
12287 -- Analyze all these pragmas in the order outlined above
12289 Analyze_If_Present (Pragma_SPARK_Mode);
12290 States := Expression (Get_Argument (N, Pack_Id));
12292 -- Multiple non-null abstract states appear as an aggregate
12294 if Nkind (States) = N_Aggregate then
12295 State := First (Expressions (States));
12296 while Present (State) loop
12297 Analyze_Abstract_State (State, Pack_Id);
12301 -- An abstract state with a simple option is being illegaly
12302 -- declared with "=>" rather than "with". In this case the
12303 -- state declaration appears as a component association.
12305 if Present (Component_Associations (States)) then
12306 State := First (Component_Associations (States));
12307 while Present (State) loop
12308 Malformed_State_Error (State);
12313 -- Various forms of a single abstract state. Note that these may
12314 -- include malformed state declarations.
12317 Analyze_Abstract_State (States, Pack_Id);
12320 Analyze_If_Present (Pragma_Initializes);
12321 Analyze_If_Present (Pragma_Initial_Condition);
12322 end Abstract_State;
12330 -- Note: this pragma also has some specific processing in Par.Prag
12331 -- because we want to set the Ada version mode during parsing.
12333 when Pragma_Ada_83 =>
12335 Check_Arg_Count (0);
12337 -- We really should check unconditionally for proper configuration
12338 -- pragma placement, since we really don't want mixed Ada modes
12339 -- within a single unit, and the GNAT reference manual has always
12340 -- said this was a configuration pragma, but we did not check and
12341 -- are hesitant to add the check now.
12343 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12344 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12345 -- or Ada 2012 mode.
12347 if Ada_Version >= Ada_2005 then
12348 Check_Valid_Configuration_Pragma;
12351 -- Now set Ada 83 mode
12353 if Latest_Ada_Only then
12354 Error_Pragma ("??pragma% ignored");
12356 Ada_Version := Ada_83;
12357 Ada_Version_Explicit := Ada_83;
12358 Ada_Version_Pragma := N;
12367 -- Note: this pragma also has some specific processing in Par.Prag
12368 -- because we want to set the Ada 83 version mode during parsing.
12370 when Pragma_Ada_95 =>
12372 Check_Arg_Count (0);
12374 -- We really should check unconditionally for proper configuration
12375 -- pragma placement, since we really don't want mixed Ada modes
12376 -- within a single unit, and the GNAT reference manual has always
12377 -- said this was a configuration pragma, but we did not check and
12378 -- are hesitant to add the check now.
12380 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12381 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12383 if Ada_Version >= Ada_2005 then
12384 Check_Valid_Configuration_Pragma;
12387 -- Now set Ada 95 mode
12389 if Latest_Ada_Only then
12390 Error_Pragma ("??pragma% ignored");
12392 Ada_Version := Ada_95;
12393 Ada_Version_Explicit := Ada_95;
12394 Ada_Version_Pragma := N;
12397 ---------------------
12398 -- Ada_05/Ada_2005 --
12399 ---------------------
12402 -- pragma Ada_05 (LOCAL_NAME);
12404 -- pragma Ada_2005;
12405 -- pragma Ada_2005 (LOCAL_NAME):
12407 -- Note: these pragmas also have some specific processing in Par.Prag
12408 -- because we want to set the Ada 2005 version mode during parsing.
12410 -- The one argument form is used for managing the transition from
12411 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12412 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12413 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12414 -- mode, a preference rule is established which does not choose
12415 -- such an entity unless it is unambiguously specified. This avoids
12416 -- extra subprograms marked this way from generating ambiguities in
12417 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12418 -- intended for exclusive use in the GNAT run-time library.
12429 if Arg_Count = 1 then
12430 Check_Arg_Is_Local_Name (Arg1);
12431 E_Id := Get_Pragma_Arg (Arg1);
12433 if Etype (E_Id) = Any_Type then
12437 Set_Is_Ada_2005_Only (Entity (E_Id));
12438 Record_Rep_Item (Entity (E_Id), N);
12441 Check_Arg_Count (0);
12443 -- For Ada_2005 we unconditionally enforce the documented
12444 -- configuration pragma placement, since we do not want to
12445 -- tolerate mixed modes in a unit involving Ada 2005. That
12446 -- would cause real difficulties for those cases where there
12447 -- are incompatibilities between Ada 95 and Ada 2005.
12449 Check_Valid_Configuration_Pragma;
12451 -- Now set appropriate Ada mode
12453 if Latest_Ada_Only then
12454 Error_Pragma ("??pragma% ignored");
12456 Ada_Version := Ada_2005;
12457 Ada_Version_Explicit := Ada_2005;
12458 Ada_Version_Pragma := N;
12463 ---------------------
12464 -- Ada_12/Ada_2012 --
12465 ---------------------
12468 -- pragma Ada_12 (LOCAL_NAME);
12470 -- pragma Ada_2012;
12471 -- pragma Ada_2012 (LOCAL_NAME):
12473 -- Note: these pragmas also have some specific processing in Par.Prag
12474 -- because we want to set the Ada 2012 version mode during parsing.
12476 -- The one argument form is used for managing the transition from Ada
12477 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12478 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12479 -- mode will generate a warning. In addition, in any pre-Ada_2012
12480 -- mode, a preference rule is established which does not choose
12481 -- such an entity unless it is unambiguously specified. This avoids
12482 -- extra subprograms marked this way from generating ambiguities in
12483 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12484 -- intended for exclusive use in the GNAT run-time library.
12495 if Arg_Count = 1 then
12496 Check_Arg_Is_Local_Name (Arg1);
12497 E_Id := Get_Pragma_Arg (Arg1);
12499 if Etype (E_Id) = Any_Type then
12503 Set_Is_Ada_2012_Only (Entity (E_Id));
12504 Record_Rep_Item (Entity (E_Id), N);
12507 Check_Arg_Count (0);
12509 -- For Ada_2012 we unconditionally enforce the documented
12510 -- configuration pragma placement, since we do not want to
12511 -- tolerate mixed modes in a unit involving Ada 2012. That
12512 -- would cause real difficulties for those cases where there
12513 -- are incompatibilities between Ada 95 and Ada 2012. We could
12514 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12516 Check_Valid_Configuration_Pragma;
12518 -- Now set appropriate Ada mode
12520 Ada_Version := Ada_2012;
12521 Ada_Version_Explicit := Ada_2012;
12522 Ada_Version_Pragma := N;
12530 -- pragma Ada_2020;
12532 -- Note: this pragma also has some specific processing in Par.Prag
12533 -- because we want to set the Ada 2020 version mode during parsing.
12535 when Pragma_Ada_2020 =>
12538 Check_Arg_Count (0);
12540 Check_Valid_Configuration_Pragma;
12542 -- Now set appropriate Ada mode
12544 Ada_Version := Ada_2020;
12545 Ada_Version_Explicit := Ada_2020;
12546 Ada_Version_Pragma := N;
12548 -------------------------------------
12549 -- Aggregate_Individually_Assign --
12550 -------------------------------------
12552 -- pragma Aggregate_Individually_Assign;
12554 when Pragma_Aggregate_Individually_Assign =>
12556 Check_Arg_Count (0);
12557 Check_Valid_Configuration_Pragma;
12558 Aggregate_Individually_Assign := True;
12560 ----------------------
12561 -- All_Calls_Remote --
12562 ----------------------
12564 -- pragma All_Calls_Remote [(library_package_NAME)];
12566 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12567 Lib_Entity : Entity_Id;
12570 Check_Ada_83_Warning;
12571 Check_Valid_Library_Unit_Pragma;
12573 Lib_Entity := Find_Lib_Unit_Name;
12575 -- A pragma that applies to a Ghost entity becomes Ghost for the
12576 -- purposes of legality checks and removal of ignored Ghost code.
12578 Mark_Ghost_Pragma (N, Lib_Entity);
12580 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12582 if Present (Lib_Entity) and then not Debug_Flag_U then
12583 if not Is_Remote_Call_Interface (Lib_Entity) then
12584 Error_Pragma ("pragma% only apply to rci unit");
12586 -- Set flag for entity of the library unit
12589 Set_Has_All_Calls_Remote (Lib_Entity);
12592 end All_Calls_Remote;
12594 ---------------------------
12595 -- Allow_Integer_Address --
12596 ---------------------------
12598 -- pragma Allow_Integer_Address;
12600 when Pragma_Allow_Integer_Address =>
12602 Check_Valid_Configuration_Pragma;
12603 Check_Arg_Count (0);
12605 -- If Address is a private type, then set the flag to allow
12606 -- integer address values. If Address is not private, then this
12607 -- pragma has no purpose, so it is simply ignored. Not clear if
12608 -- there are any such targets now.
12610 if Opt.Address_Is_Private then
12611 Opt.Allow_Integer_Address := True;
12619 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12620 -- ARG ::= NAME | EXPRESSION
12622 -- The first two arguments are by convention intended to refer to an
12623 -- external tool and a tool-specific function. These arguments are
12626 when Pragma_Annotate => Annotate : declare
12631 --------------------------
12632 -- Inferred_String_Type --
12633 --------------------------
12635 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12636 -- Infer the type to use for a string literal or a concatentation
12637 -- of operands whose types can be inferred. For such expressions,
12638 -- returns the "narrowest" of the three predefined string types
12639 -- that can represent the characters occurring in the expression.
12640 -- For other expressions, returns Empty.
12642 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12644 case Nkind (Expr) is
12645 when N_String_Literal =>
12646 if Has_Wide_Wide_Character (Expr) then
12647 return Standard_Wide_Wide_String;
12648 elsif Has_Wide_Character (Expr) then
12649 return Standard_Wide_String;
12651 return Standard_String;
12654 when N_Op_Concat =>
12656 L_Type : constant Entity_Id
12657 := Preferred_String_Type (Left_Opnd (Expr));
12658 R_Type : constant Entity_Id
12659 := Preferred_String_Type (Right_Opnd (Expr));
12661 Type_Table : constant array (1 .. 4) of Entity_Id
12663 Standard_Wide_Wide_String,
12664 Standard_Wide_String,
12667 for Idx in Type_Table'Range loop
12668 if (L_Type = Type_Table (Idx)) or
12669 (R_Type = Type_Table (Idx))
12671 return Type_Table (Idx);
12674 raise Program_Error;
12680 end Preferred_String_Type;
12683 Check_At_Least_N_Arguments (1);
12685 Nam_Arg := Last (Pragma_Argument_Associations (N));
12687 -- Determine whether the last argument is "Entity => local_NAME"
12688 -- and if it is, perform the required semantic checks. Remove the
12689 -- argument from further processing.
12691 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12692 and then Chars (Nam_Arg) = Name_Entity
12694 Check_Arg_Is_Local_Name (Nam_Arg);
12695 Arg_Count := Arg_Count - 1;
12697 -- A pragma that applies to a Ghost entity becomes Ghost for
12698 -- the purposes of legality checks and removal of ignored Ghost
12701 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12702 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12704 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12707 -- Not allowed in compiler units (bootstrap issues)
12709 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12712 -- Continue the processing with last argument removed for now
12714 Check_Arg_Is_Identifier (Arg1);
12715 Check_No_Identifiers;
12718 -- The second parameter is optional, it is never analyzed
12723 -- Otherwise there is a second parameter
12726 -- The second parameter must be an identifier
12728 Check_Arg_Is_Identifier (Arg2);
12730 -- Process the remaining parameters (if any)
12732 Arg := Next (Arg2);
12733 while Present (Arg) loop
12734 Expr := Get_Pragma_Arg (Arg);
12737 if Is_Entity_Name (Expr) then
12740 -- For string literals and concatenations of string literals
12741 -- we assume Standard_String as the type, unless the string
12742 -- contains wide or wide_wide characters.
12744 elsif Present (Preferred_String_Type (Expr)) then
12745 Resolve (Expr, Preferred_String_Type (Expr));
12747 elsif Is_Overloaded (Expr) then
12748 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12759 -------------------------------------------------
12760 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12761 -------------------------------------------------
12764 -- ( [Check => ] Boolean_EXPRESSION
12765 -- [, [Message =>] Static_String_EXPRESSION]);
12767 -- pragma Assert_And_Cut
12768 -- ( [Check => ] Boolean_EXPRESSION
12769 -- [, [Message =>] Static_String_EXPRESSION]);
12772 -- ( [Check => ] Boolean_EXPRESSION
12773 -- [, [Message =>] Static_String_EXPRESSION]);
12775 -- pragma Loop_Invariant
12776 -- ( [Check => ] Boolean_EXPRESSION
12777 -- [, [Message =>] Static_String_EXPRESSION]);
12780 | Pragma_Assert_And_Cut
12782 | Pragma_Loop_Invariant
12785 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12786 -- Determine whether expression Expr contains a Loop_Entry
12787 -- attribute reference.
12789 -------------------------
12790 -- Contains_Loop_Entry --
12791 -------------------------
12793 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12794 Has_Loop_Entry : Boolean := False;
12796 function Process (N : Node_Id) return Traverse_Result;
12797 -- Process function for traversal to look for Loop_Entry
12803 function Process (N : Node_Id) return Traverse_Result is
12805 if Nkind (N) = N_Attribute_Reference
12806 and then Attribute_Name (N) = Name_Loop_Entry
12808 Has_Loop_Entry := True;
12815 procedure Traverse is new Traverse_Proc (Process);
12817 -- Start of processing for Contains_Loop_Entry
12821 return Has_Loop_Entry;
12822 end Contains_Loop_Entry;
12827 New_Args : List_Id;
12829 -- Start of processing for Assert
12832 -- Assert is an Ada 2005 RM-defined pragma
12834 if Prag_Id = Pragma_Assert then
12837 -- The remaining ones are GNAT pragmas
12843 Check_At_Least_N_Arguments (1);
12844 Check_At_Most_N_Arguments (2);
12845 Check_Arg_Order ((Name_Check, Name_Message));
12846 Check_Optional_Identifier (Arg1, Name_Check);
12847 Expr := Get_Pragma_Arg (Arg1);
12849 -- Special processing for Loop_Invariant, Loop_Variant or for
12850 -- other cases where a Loop_Entry attribute is present. If the
12851 -- assertion pragma contains attribute Loop_Entry, ensure that
12852 -- the related pragma is within a loop.
12854 if Prag_Id = Pragma_Loop_Invariant
12855 or else Prag_Id = Pragma_Loop_Variant
12856 or else Contains_Loop_Entry (Expr)
12858 Check_Loop_Pragma_Placement;
12860 -- Perform preanalysis to deal with embedded Loop_Entry
12863 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12866 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12867 -- a corresponding Check pragma:
12869 -- pragma Check (name, condition [, msg]);
12871 -- Where name is the identifier matching the pragma name. So
12872 -- rewrite pragma in this manner, transfer the message argument
12873 -- if present, and analyze the result
12875 -- Note: When dealing with a semantically analyzed tree, the
12876 -- information that a Check node N corresponds to a source Assert,
12877 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12878 -- pragma kind of Original_Node(N).
12880 New_Args := New_List (
12881 Make_Pragma_Argument_Association (Loc,
12882 Expression => Make_Identifier (Loc, Pname)),
12883 Make_Pragma_Argument_Association (Sloc (Expr),
12884 Expression => Expr));
12886 if Arg_Count > 1 then
12887 Check_Optional_Identifier (Arg2, Name_Message);
12889 -- Provide semantic annotations for optional argument, for
12890 -- ASIS use, before rewriting.
12891 -- Is this still needed???
12893 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12894 Append_To (New_Args, New_Copy_Tree (Arg2));
12897 -- Rewrite as Check pragma
12901 Chars => Name_Check,
12902 Pragma_Argument_Associations => New_Args));
12907 ----------------------
12908 -- Assertion_Policy --
12909 ----------------------
12911 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12913 -- The following form is Ada 2012 only, but we allow it in all modes
12915 -- Pragma Assertion_Policy (
12916 -- ASSERTION_KIND => POLICY_IDENTIFIER
12917 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12919 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12921 -- RM_ASSERTION_KIND ::= Assert |
12922 -- Static_Predicate |
12923 -- Dynamic_Predicate |
12928 -- Type_Invariant |
12929 -- Type_Invariant'Class |
12930 -- Default_Initial_Condition
12932 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12934 -- Contract_Cases |
12937 -- Initial_Condition |
12938 -- Loop_Invariant |
12944 -- Statement_Assertions |
12945 -- Subprogram_Variant
12947 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12948 -- ID_ASSERTION_KIND list contains implementation-defined additions
12949 -- recognized by GNAT. The effect is to control the behavior of
12950 -- identically named aspects and pragmas, depending on the specified
12951 -- policy identifier:
12953 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12955 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12956 -- implementation-defined addition that results in totally ignoring
12957 -- the corresponding assertion. If Disable is specified, then the
12958 -- argument of the assertion is not even analyzed. This is useful
12959 -- when the aspect/pragma argument references entities in a with'ed
12960 -- package that is replaced by a dummy package in the final build.
12962 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12963 -- and Type_Invariant'Class were recognized by the parser and
12964 -- transformed into references to the special internal identifiers
12965 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12966 -- processing is required here.
12968 when Pragma_Assertion_Policy => Assertion_Policy : declare
12969 procedure Resolve_Suppressible (Policy : Node_Id);
12970 -- Converts the assertion policy 'Suppressible' to either Check or
12971 -- Ignore based on whether checks are suppressed via -gnatp.
12973 --------------------------
12974 -- Resolve_Suppressible --
12975 --------------------------
12977 procedure Resolve_Suppressible (Policy : Node_Id) is
12978 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12982 -- Transform policy argument Suppressible into either Ignore or
12983 -- Check depending on whether checks are enabled or suppressed.
12985 if Chars (Arg) = Name_Suppressible then
12986 if Suppress_Checks then
12987 Nam := Name_Ignore;
12992 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12994 end Resolve_Suppressible;
13006 -- This can always appear as a configuration pragma
13008 if Is_Configuration_Pragma then
13011 -- It can also appear in a declarative part or package spec in Ada
13012 -- 2012 mode. We allow this in other modes, but in that case we
13013 -- consider that we have an Ada 2012 pragma on our hands.
13016 Check_Is_In_Decl_Part_Or_Package_Spec;
13020 -- One argument case with no identifier (first form above)
13023 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13024 or else Chars (Arg1) = No_Name)
13026 Check_Arg_Is_One_Of (Arg1,
13027 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13029 Resolve_Suppressible (Arg1);
13031 -- Treat one argument Assertion_Policy as equivalent to:
13033 -- pragma Check_Policy (Assertion, policy)
13035 -- So rewrite pragma in that manner and link on to the chain
13036 -- of Check_Policy pragmas, marking the pragma as analyzed.
13038 Policy := Get_Pragma_Arg (Arg1);
13042 Chars => Name_Check_Policy,
13043 Pragma_Argument_Associations => New_List (
13044 Make_Pragma_Argument_Association (Loc,
13045 Expression => Make_Identifier (Loc, Name_Assertion)),
13047 Make_Pragma_Argument_Association (Loc,
13049 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13052 -- Here if we have two or more arguments
13055 Check_At_Least_N_Arguments (1);
13058 -- Loop through arguments
13061 while Present (Arg) loop
13062 LocP := Sloc (Arg);
13064 -- Kind must be specified
13066 if Nkind (Arg) /= N_Pragma_Argument_Association
13067 or else Chars (Arg) = No_Name
13070 ("missing assertion kind for pragma%", Arg);
13073 -- Check Kind and Policy have allowed forms
13075 Kind := Chars (Arg);
13076 Policy := Get_Pragma_Arg (Arg);
13078 if not Is_Valid_Assertion_Kind (Kind) then
13080 ("invalid assertion kind for pragma%", Arg);
13083 Check_Arg_Is_One_Of (Arg,
13084 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13086 Resolve_Suppressible (Arg);
13088 if Kind = Name_Ghost then
13090 -- The Ghost policy must be either Check or Ignore
13091 -- (SPARK RM 6.9(6)).
13093 if Chars (Policy) not in Name_Check | Name_Ignore then
13095 ("argument of pragma % Ghost must be Check or "
13096 & "Ignore", Policy);
13099 -- Pragma Assertion_Policy specifying a Ghost policy
13100 -- cannot occur within a Ghost subprogram or package
13101 -- (SPARK RM 6.9(14)).
13103 if Ghost_Mode > None then
13105 ("pragma % cannot appear within ghost subprogram or "
13110 -- Rewrite the Assertion_Policy pragma as a series of
13111 -- Check_Policy pragmas of the form:
13113 -- Check_Policy (Kind, Policy);
13115 -- Note: the insertion of the pragmas cannot be done with
13116 -- Insert_Action because in the configuration case, there
13117 -- are no scopes on the scope stack and the mechanism will
13120 Insert_Before_And_Analyze (N,
13122 Chars => Name_Check_Policy,
13123 Pragma_Argument_Associations => New_List (
13124 Make_Pragma_Argument_Association (LocP,
13125 Expression => Make_Identifier (LocP, Kind)),
13126 Make_Pragma_Argument_Association (LocP,
13127 Expression => Policy))));
13132 -- Rewrite the Assertion_Policy pragma as null since we have
13133 -- now inserted all the equivalent Check pragmas.
13135 Rewrite (N, Make_Null_Statement (Loc));
13138 end Assertion_Policy;
13140 ------------------------------
13141 -- Assume_No_Invalid_Values --
13142 ------------------------------
13144 -- pragma Assume_No_Invalid_Values (On | Off);
13146 when Pragma_Assume_No_Invalid_Values =>
13148 Check_Valid_Configuration_Pragma;
13149 Check_Arg_Count (1);
13150 Check_No_Identifiers;
13151 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13153 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13154 Assume_No_Invalid_Values := True;
13156 Assume_No_Invalid_Values := False;
13159 --------------------------
13160 -- Attribute_Definition --
13161 --------------------------
13163 -- pragma Attribute_Definition
13164 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13165 -- [Entity =>] LOCAL_NAME,
13166 -- [Expression =>] EXPRESSION | NAME);
13168 when Pragma_Attribute_Definition => Attribute_Definition : declare
13169 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13174 Check_Arg_Count (3);
13175 Check_Optional_Identifier (Arg1, "attribute");
13176 Check_Optional_Identifier (Arg2, "entity");
13177 Check_Optional_Identifier (Arg3, "expression");
13179 if Nkind (Attribute_Designator) /= N_Identifier then
13180 Error_Msg_N ("attribute name expected", Attribute_Designator);
13184 Check_Arg_Is_Local_Name (Arg2);
13186 -- If the attribute is not recognized, then issue a warning (not
13187 -- an error), and ignore the pragma.
13189 Aname := Chars (Attribute_Designator);
13191 if not Is_Attribute_Name (Aname) then
13192 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13196 -- Otherwise, rewrite the pragma as an attribute definition clause
13199 Make_Attribute_Definition_Clause (Loc,
13200 Name => Get_Pragma_Arg (Arg2),
13202 Expression => Get_Pragma_Arg (Arg3)));
13204 end Attribute_Definition;
13206 ------------------------------------------------------------------
13207 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13209 ------------------------------------------------------------------
13211 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13212 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13213 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13214 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13215 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13217 when Pragma_Async_Readers
13218 | Pragma_Async_Writers
13219 | Pragma_Effective_Reads
13220 | Pragma_Effective_Writes
13221 | Pragma_No_Caching
13223 Async_Effective : declare
13224 Obj_Or_Type_Decl : Node_Id;
13225 Obj_Or_Type_Id : Entity_Id;
13228 Check_No_Identifiers;
13229 Check_At_Most_N_Arguments (1);
13231 Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
13233 -- Pragma must apply to a object declaration or to a type
13234 -- declaration (only the former in the No_Caching case).
13235 -- Original_Node is necessary to account for untagged derived
13236 -- types that are rewritten as subtypes of their
13237 -- respective root types.
13239 if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then
13240 if Prag_Id = Pragma_No_Caching
13241 or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in
13242 N_Full_Type_Declaration |
13243 N_Private_Type_Declaration |
13244 N_Formal_Type_Declaration |
13245 N_Task_Type_Declaration |
13246 N_Protected_Type_Declaration
13253 Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
13255 -- Perform minimal verification to ensure that the argument is at
13256 -- least a variable or a type. Subsequent finer grained checks
13257 -- will be done at the end of the declarative region that
13258 -- contains the pragma.
13260 if Ekind (Obj_Or_Type_Id) = E_Variable
13261 or else Is_Type (Obj_Or_Type_Id)
13264 -- In the case of a type, pragma is a type-related
13265 -- representation item and so requires checks common to
13266 -- all type-related representation items.
13268 if Is_Type (Obj_Or_Type_Id)
13269 and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
13274 -- A pragma that applies to a Ghost entity becomes Ghost for
13275 -- the purposes of legality checks and removal of ignored Ghost
13278 Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
13280 -- Chain the pragma on the contract for further processing by
13281 -- Analyze_External_Property_In_Decl_Part.
13283 Add_Contract_Item (N, Obj_Or_Type_Id);
13285 -- Analyze the Boolean expression (if any)
13287 if Present (Arg1) then
13288 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13291 -- Otherwise the external property applies to a constant
13295 ("pragma % must apply to a volatile type or object");
13297 end Async_Effective;
13303 -- pragma Asynchronous (LOCAL_NAME);
13305 when Pragma_Asynchronous => Asynchronous : declare
13308 Formal : Entity_Id;
13313 procedure Process_Async_Pragma;
13314 -- Common processing for procedure and access-to-procedure case
13316 --------------------------
13317 -- Process_Async_Pragma --
13318 --------------------------
13320 procedure Process_Async_Pragma is
13323 Set_Is_Asynchronous (Nm);
13327 -- The formals should be of mode IN (RM E.4.1(6))
13330 while Present (S) loop
13331 Formal := Defining_Identifier (S);
13333 if Nkind (Formal) = N_Defining_Identifier
13334 and then Ekind (Formal) /= E_In_Parameter
13337 ("pragma% procedure can only have IN parameter",
13344 Set_Is_Asynchronous (Nm);
13345 end Process_Async_Pragma;
13347 -- Start of processing for pragma Asynchronous
13350 Check_Ada_83_Warning;
13351 Check_No_Identifiers;
13352 Check_Arg_Count (1);
13353 Check_Arg_Is_Local_Name (Arg1);
13355 if Debug_Flag_U then
13359 C_Ent := Cunit_Entity (Current_Sem_Unit);
13360 Analyze (Get_Pragma_Arg (Arg1));
13361 Nm := Entity (Get_Pragma_Arg (Arg1));
13363 -- A pragma that applies to a Ghost entity becomes Ghost for the
13364 -- purposes of legality checks and removal of ignored Ghost code.
13366 Mark_Ghost_Pragma (N, Nm);
13368 if not Is_Remote_Call_Interface (C_Ent)
13369 and then not Is_Remote_Types (C_Ent)
13371 -- This pragma should only appear in an RCI or Remote Types
13372 -- unit (RM E.4.1(4)).
13375 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13378 if Ekind (Nm) = E_Procedure
13379 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13381 if not Is_Remote_Call_Interface (Nm) then
13383 ("pragma% cannot be applied on non-remote procedure",
13387 L := Parameter_Specifications (Parent (Nm));
13388 Process_Async_Pragma;
13391 elsif Ekind (Nm) = E_Function then
13393 ("pragma% cannot be applied to function", Arg1);
13395 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13396 if Is_Record_Type (Nm) then
13398 -- A record type that is the Equivalent_Type for a remote
13399 -- access-to-subprogram type.
13401 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13404 -- A non-expanded RAS type (distribution is not enabled)
13406 Decl := Declaration_Node (Nm);
13409 if Nkind (Decl) = N_Full_Type_Declaration
13410 and then Nkind (Type_Definition (Decl)) =
13411 N_Access_Procedure_Definition
13413 L := Parameter_Specifications (Type_Definition (Decl));
13414 Process_Async_Pragma;
13416 if Is_Asynchronous (Nm)
13417 and then Expander_Active
13418 and then Get_PCS_Name /= Name_No_DSA
13420 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13425 ("pragma% cannot reference access-to-function type",
13429 -- Only other possibility is Access-to-class-wide type
13431 elsif Is_Access_Type (Nm)
13432 and then Is_Class_Wide_Type (Designated_Type (Nm))
13434 Check_First_Subtype (Arg1);
13435 Set_Is_Asynchronous (Nm);
13436 if Expander_Active then
13437 RACW_Type_Is_Asynchronous (Nm);
13441 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13449 -- pragma Atomic (LOCAL_NAME);
13451 when Pragma_Atomic =>
13452 Process_Atomic_Independent_Shared_Volatile;
13454 -----------------------
13455 -- Atomic_Components --
13456 -----------------------
13458 -- pragma Atomic_Components (array_LOCAL_NAME);
13460 -- This processing is shared by Volatile_Components
13462 when Pragma_Atomic_Components
13463 | Pragma_Volatile_Components
13465 Atomic_Components : declare
13471 Check_Ada_83_Warning;
13472 Check_No_Identifiers;
13473 Check_Arg_Count (1);
13474 Check_Arg_Is_Local_Name (Arg1);
13475 E_Id := Get_Pragma_Arg (Arg1);
13477 if Etype (E_Id) = Any_Type then
13481 E := Entity (E_Id);
13483 -- A pragma that applies to a Ghost entity becomes Ghost for the
13484 -- purposes of legality checks and removal of ignored Ghost code.
13486 Mark_Ghost_Pragma (N, E);
13487 Check_Duplicate_Pragma (E);
13489 if Rep_Item_Too_Early (E, N)
13491 Rep_Item_Too_Late (E, N)
13496 D := Declaration_Node (E);
13498 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13500 (Nkind (D) = N_Object_Declaration
13501 and then Ekind (E) in E_Constant | E_Variable
13502 and then Nkind (Object_Definition (D)) =
13503 N_Constrained_Array_Definition)
13505 (Ada_Version >= Ada_2020
13506 and then Nkind (D) = N_Formal_Type_Declaration)
13508 -- The flag is set on the base type, or on the object
13510 if Nkind (D) = N_Full_Type_Declaration then
13511 E := Base_Type (E);
13514 -- Atomic implies both Independent and Volatile
13516 if Prag_Id = Pragma_Atomic_Components then
13517 Set_Has_Atomic_Components (E);
13518 Set_Has_Independent_Components (E);
13521 Set_Has_Volatile_Components (E);
13524 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13526 end Atomic_Components;
13528 --------------------
13529 -- Attach_Handler --
13530 --------------------
13532 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13534 when Pragma_Attach_Handler =>
13535 Check_Ada_83_Warning;
13536 Check_No_Identifiers;
13537 Check_Arg_Count (2);
13539 if No_Run_Time_Mode then
13540 Error_Msg_CRT ("Attach_Handler pragma", N);
13542 Check_Interrupt_Or_Attach_Handler;
13544 -- The expression that designates the attribute may depend on a
13545 -- discriminant, and is therefore a per-object expression, to
13546 -- be expanded in the init proc. If expansion is enabled, then
13547 -- perform semantic checks on a copy only.
13552 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13555 -- In Relaxed_RM_Semantics mode, we allow any static
13556 -- integer value, for compatibility with other compilers.
13558 if Relaxed_RM_Semantics
13559 and then Nkind (Parg2) = N_Integer_Literal
13561 Typ := Standard_Integer;
13563 Typ := RTE (RE_Interrupt_ID);
13566 if Expander_Active then
13567 Temp := New_Copy_Tree (Parg2);
13568 Set_Parent (Temp, N);
13569 Preanalyze_And_Resolve (Temp, Typ);
13572 Resolve (Parg2, Typ);
13576 Process_Interrupt_Or_Attach_Handler;
13579 --------------------
13580 -- C_Pass_By_Copy --
13581 --------------------
13583 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13585 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13591 Check_Valid_Configuration_Pragma;
13592 Check_Arg_Count (1);
13593 Check_Optional_Identifier (Arg1, "max_size");
13595 Arg := Get_Pragma_Arg (Arg1);
13596 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13598 Val := Expr_Value (Arg);
13602 ("maximum size for pragma% must be positive", Arg1);
13604 elsif UI_Is_In_Int_Range (Val) then
13605 Default_C_Record_Mechanism := UI_To_Int (Val);
13607 -- If a giant value is given, Int'Last will do well enough.
13608 -- If sometime someone complains that a record larger than
13609 -- two gigabytes is not copied, we will worry about it then.
13612 Default_C_Record_Mechanism := Mechanism_Type'Last;
13614 end C_Pass_By_Copy;
13620 -- pragma Check ([Name =>] CHECK_KIND,
13621 -- [Check =>] Boolean_EXPRESSION
13622 -- [,[Message =>] String_EXPRESSION]);
13624 -- CHECK_KIND ::= IDENTIFIER |
13627 -- Invariant'Class |
13628 -- Type_Invariant'Class
13630 -- The identifiers Assertions and Statement_Assertions are not
13631 -- allowed, since they have special meaning for Check_Policy.
13633 -- WARNING: The code below manages Ghost regions. Return statements
13634 -- must be replaced by gotos which jump to the end of the code and
13635 -- restore the Ghost mode.
13637 when Pragma_Check => Check : declare
13638 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13639 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13640 -- Save the Ghost-related attributes to restore on exit
13646 pragma Warnings (Off, Str);
13649 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13650 -- the mode now to ensure that any nodes generated during analysis
13651 -- and expansion are marked as Ghost.
13653 Set_Ghost_Mode (N);
13656 Check_At_Least_N_Arguments (2);
13657 Check_At_Most_N_Arguments (3);
13658 Check_Optional_Identifier (Arg1, Name_Name);
13659 Check_Optional_Identifier (Arg2, Name_Check);
13661 if Arg_Count = 3 then
13662 Check_Optional_Identifier (Arg3, Name_Message);
13663 Str := Get_Pragma_Arg (Arg3);
13666 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13667 Check_Arg_Is_Identifier (Arg1);
13668 Cname := Chars (Get_Pragma_Arg (Arg1));
13670 -- Check forbidden name Assertions or Statement_Assertions
13673 when Name_Assertions =>
13675 ("""Assertions"" is not allowed as a check kind for "
13676 & "pragma%", Arg1);
13678 when Name_Statement_Assertions =>
13680 ("""Statement_Assertions"" is not allowed as a check kind "
13681 & "for pragma%", Arg1);
13687 -- Check applicable policy. We skip this if Checked/Ignored status
13688 -- is already set (e.g. in the case of a pragma from an aspect).
13690 if Is_Checked (N) or else Is_Ignored (N) then
13693 -- For a non-source pragma that is a rewriting of another pragma,
13694 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13696 elsif Is_Rewrite_Substitution (N)
13697 and then Nkind (Original_Node (N)) = N_Pragma
13699 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13700 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13702 -- Otherwise query the applicable policy at this point
13705 case Check_Kind (Cname) is
13706 when Name_Ignore =>
13707 Set_Is_Ignored (N, True);
13708 Set_Is_Checked (N, False);
13711 Set_Is_Ignored (N, False);
13712 Set_Is_Checked (N, True);
13714 -- For disable, rewrite pragma as null statement and skip
13715 -- rest of the analysis of the pragma.
13717 when Name_Disable =>
13718 Rewrite (N, Make_Null_Statement (Loc));
13722 -- No other possibilities
13725 raise Program_Error;
13729 -- If check kind was not Disable, then continue pragma analysis
13731 Expr := Get_Pragma_Arg (Arg2);
13733 -- Mark the pragma (or, if rewritten from an aspect, the original
13734 -- aspect) as enabled. Nothing to do for an internally generated
13735 -- check for a dynamic predicate.
13738 and then not Split_PPC (N)
13739 and then Cname /= Name_Dynamic_Predicate
13741 Set_SCO_Pragma_Enabled (Loc);
13744 -- Deal with analyzing the string argument. If checks are not
13745 -- on we don't want any expansion (since such expansion would
13746 -- not get properly deleted) but we do want to analyze (to get
13747 -- proper references). The Preanalyze_And_Resolve routine does
13748 -- just what we want. Ditto if pragma is active, because it will
13749 -- be rewritten as an if-statement whose analysis will complete
13750 -- analysis and expansion of the string message. This makes a
13751 -- difference in the unusual case where the expression for the
13752 -- string may have a side effect, such as raising an exception.
13753 -- This is mandated by RM 11.4.2, which specifies that the string
13754 -- expression is only evaluated if the check fails and
13755 -- Assertion_Error is to be raised.
13757 if Arg_Count = 3 then
13758 Preanalyze_And_Resolve (Str, Standard_String);
13761 -- Now you might think we could just do the same with the Boolean
13762 -- expression if checks are off (and expansion is on) and then
13763 -- rewrite the check as a null statement. This would work but we
13764 -- would lose the useful warnings about an assertion being bound
13765 -- to fail even if assertions are turned off.
13767 -- So instead we wrap the boolean expression in an if statement
13768 -- that looks like:
13770 -- if False and then condition then
13774 -- The reason we do this rewriting during semantic analysis rather
13775 -- than as part of normal expansion is that we cannot analyze and
13776 -- expand the code for the boolean expression directly, or it may
13777 -- cause insertion of actions that would escape the attempt to
13778 -- suppress the check code.
13780 -- Note that the Sloc for the if statement corresponds to the
13781 -- argument condition, not the pragma itself. The reason for
13782 -- this is that we may generate a warning if the condition is
13783 -- False at compile time, and we do not want to delete this
13784 -- warning when we delete the if statement.
13786 if Expander_Active and Is_Ignored (N) then
13787 Eloc := Sloc (Expr);
13790 Make_If_Statement (Eloc,
13792 Make_And_Then (Eloc,
13793 Left_Opnd => Make_Identifier (Eloc, Name_False),
13794 Right_Opnd => Expr),
13795 Then_Statements => New_List (
13796 Make_Null_Statement (Eloc))));
13798 -- Now go ahead and analyze the if statement
13800 In_Assertion_Expr := In_Assertion_Expr + 1;
13802 -- One rather special treatment. If we are now in Eliminated
13803 -- overflow mode, then suppress overflow checking since we do
13804 -- not want to drag in the bignum stuff if we are in Ignore
13805 -- mode anyway. This is particularly important if we are using
13806 -- a configurable run time that does not support bignum ops.
13808 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13810 Svo : constant Boolean :=
13811 Scope_Suppress.Suppress (Overflow_Check);
13813 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13814 Scope_Suppress.Suppress (Overflow_Check) := True;
13816 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13817 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13820 -- Not that special case
13826 -- All done with this check
13828 In_Assertion_Expr := In_Assertion_Expr - 1;
13830 -- Check is active or expansion not active. In these cases we can
13831 -- just go ahead and analyze the boolean with no worries.
13834 In_Assertion_Expr := In_Assertion_Expr + 1;
13835 Analyze_And_Resolve (Expr, Any_Boolean);
13836 In_Assertion_Expr := In_Assertion_Expr - 1;
13839 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13842 --------------------------
13843 -- Check_Float_Overflow --
13844 --------------------------
13846 -- pragma Check_Float_Overflow;
13848 when Pragma_Check_Float_Overflow =>
13850 Check_Valid_Configuration_Pragma;
13851 Check_Arg_Count (0);
13852 Check_Float_Overflow := not Machine_Overflows_On_Target;
13858 -- pragma Check_Name (check_IDENTIFIER);
13860 when Pragma_Check_Name =>
13862 Check_No_Identifiers;
13863 Check_Valid_Configuration_Pragma;
13864 Check_Arg_Count (1);
13865 Check_Arg_Is_Identifier (Arg1);
13868 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13871 for J in Check_Names.First .. Check_Names.Last loop
13872 if Check_Names.Table (J) = Nam then
13877 Check_Names.Append (Nam);
13884 -- This is the old style syntax, which is still allowed in all modes:
13886 -- pragma Check_Policy ([Name =>] CHECK_KIND
13887 -- [Policy =>] POLICY_IDENTIFIER);
13889 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13891 -- CHECK_KIND ::= IDENTIFIER |
13894 -- Type_Invariant'Class |
13897 -- This is the new style syntax, compatible with Assertion_Policy
13898 -- and also allowed in all modes.
13900 -- Pragma Check_Policy (
13901 -- CHECK_KIND => POLICY_IDENTIFIER
13902 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13904 -- Note: the identifiers Name and Policy are not allowed as
13905 -- Check_Kind values. This avoids ambiguities between the old and
13906 -- new form syntax.
13908 when Pragma_Check_Policy => Check_Policy : declare
13913 Check_At_Least_N_Arguments (1);
13915 -- A Check_Policy pragma can appear either as a configuration
13916 -- pragma, or in a declarative part or a package spec (see RM
13917 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13918 -- followed for Check_Policy).
13920 if not Is_Configuration_Pragma then
13921 Check_Is_In_Decl_Part_Or_Package_Spec;
13924 -- Figure out if we have the old or new syntax. We have the
13925 -- old syntax if the first argument has no identifier, or the
13926 -- identifier is Name.
13928 if Nkind (Arg1) /= N_Pragma_Argument_Association
13929 or else Chars (Arg1) in No_Name | Name_Name
13933 Check_Arg_Count (2);
13934 Check_Optional_Identifier (Arg1, Name_Name);
13935 Kind := Get_Pragma_Arg (Arg1);
13936 Rewrite_Assertion_Kind (Kind,
13937 From_Policy => Comes_From_Source (N));
13938 Check_Arg_Is_Identifier (Arg1);
13940 -- Check forbidden check kind
13942 if Chars (Kind) in Name_Name | Name_Policy then
13943 Error_Msg_Name_2 := Chars (Kind);
13945 ("pragma% does not allow% as check name", Arg1);
13950 Check_Optional_Identifier (Arg2, Name_Policy);
13951 Check_Arg_Is_One_Of
13953 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
13955 -- And chain pragma on the Check_Policy_List for search
13957 Set_Next_Pragma (N, Opt.Check_Policy_List);
13958 Opt.Check_Policy_List := N;
13960 -- For the new syntax, what we do is to convert each argument to
13961 -- an old syntax equivalent. We do that because we want to chain
13962 -- old style Check_Policy pragmas for the search (we don't want
13963 -- to have to deal with multiple arguments in the search).
13974 while Present (Arg) loop
13975 LocP := Sloc (Arg);
13976 Argx := Get_Pragma_Arg (Arg);
13978 -- Kind must be specified
13980 if Nkind (Arg) /= N_Pragma_Argument_Association
13981 or else Chars (Arg) = No_Name
13984 ("missing assertion kind for pragma%", Arg);
13987 -- Construct equivalent old form syntax Check_Policy
13988 -- pragma and insert it to get remaining checks.
13992 Chars => Name_Check_Policy,
13993 Pragma_Argument_Associations => New_List (
13994 Make_Pragma_Argument_Association (LocP,
13996 Make_Identifier (LocP, Chars (Arg))),
13997 Make_Pragma_Argument_Association (Sloc (Argx),
13998 Expression => Argx)));
14002 -- For a configuration pragma, insert old form in
14003 -- the corresponding file.
14005 if Is_Configuration_Pragma then
14006 Insert_After (N, New_P);
14010 Insert_Action (N, New_P);
14014 -- Rewrite original Check_Policy pragma to null, since we
14015 -- have converted it into a series of old syntax pragmas.
14017 Rewrite (N, Make_Null_Statement (Loc));
14027 -- pragma Comment (static_string_EXPRESSION)
14029 -- Processing for pragma Comment shares the circuitry for pragma
14030 -- Ident. The only differences are that Ident enforces a limit of 31
14031 -- characters on its argument, and also enforces limitations on
14032 -- placement for DEC compatibility. Pragma Comment shares neither of
14033 -- these restrictions.
14035 -------------------
14036 -- Common_Object --
14037 -------------------
14039 -- pragma Common_Object (
14040 -- [Internal =>] LOCAL_NAME
14041 -- [, [External =>] EXTERNAL_SYMBOL]
14042 -- [, [Size =>] EXTERNAL_SYMBOL]);
14044 -- Processing for this pragma is shared with Psect_Object
14046 ----------------------------------------------
14047 -- Compile_Time_Error, Compile_Time_Warning --
14048 ----------------------------------------------
14050 -- pragma Compile_Time_Error
14051 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14053 -- pragma Compile_Time_Warning
14054 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14056 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14058 Process_Compile_Time_Warning_Or_Error;
14060 ---------------------------
14061 -- Compiler_Unit_Warning --
14062 ---------------------------
14064 -- pragma Compiler_Unit_Warning;
14068 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14069 -- errors not warnings. This means that we had introduced a big extra
14070 -- inertia to compiler changes, since even if we implemented a new
14071 -- feature, and even if all versions to be used for bootstrapping
14072 -- implemented this new feature, we could not use it, since old
14073 -- compilers would give errors for using this feature in units
14074 -- having Compiler_Unit pragmas.
14076 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14077 -- problem. We no longer have any units mentioning Compiler_Unit,
14078 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14079 -- and thus generates a warning which can be ignored. So that deals
14080 -- with the problem of old compilers not implementing the newer form
14083 -- Newer compilers recognize the new pragma, but generate warning
14084 -- messages instead of errors, which again can be ignored in the
14085 -- case of an old compiler which implements a wanted new feature
14086 -- but at the time felt like warning about it for older compilers.
14088 -- We retain Compiler_Unit so that new compilers can be used to build
14089 -- older run-times that use this pragma. That's an unusual case, but
14090 -- it's easy enough to handle, so why not?
14092 when Pragma_Compiler_Unit
14093 | Pragma_Compiler_Unit_Warning
14096 Check_Arg_Count (0);
14098 -- Only recognized in main unit
14100 if Current_Sem_Unit = Main_Unit then
14101 Compiler_Unit := True;
14104 -----------------------------
14105 -- Complete_Representation --
14106 -----------------------------
14108 -- pragma Complete_Representation;
14110 when Pragma_Complete_Representation =>
14112 Check_Arg_Count (0);
14114 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14116 ("pragma & must appear within record representation clause");
14119 ----------------------------
14120 -- Complex_Representation --
14121 ----------------------------
14123 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14125 when Pragma_Complex_Representation => Complex_Representation : declare
14132 Check_Arg_Count (1);
14133 Check_Optional_Identifier (Arg1, Name_Entity);
14134 Check_Arg_Is_Local_Name (Arg1);
14135 E_Id := Get_Pragma_Arg (Arg1);
14137 if Etype (E_Id) = Any_Type then
14141 E := Entity (E_Id);
14143 if not Is_Record_Type (E) then
14145 ("argument for pragma% must be record type", Arg1);
14148 Ent := First_Entity (E);
14151 or else No (Next_Entity (Ent))
14152 or else Present (Next_Entity (Next_Entity (Ent)))
14153 or else not Is_Floating_Point_Type (Etype (Ent))
14154 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14157 ("record for pragma% must have two fields of the same "
14158 & "floating-point type", Arg1);
14161 Set_Has_Complex_Representation (Base_Type (E));
14163 -- We need to treat the type has having a non-standard
14164 -- representation, for back-end purposes, even though in
14165 -- general a complex will have the default representation
14166 -- of a record with two real components.
14168 Set_Has_Non_Standard_Rep (Base_Type (E));
14170 end Complex_Representation;
14172 -------------------------
14173 -- Component_Alignment --
14174 -------------------------
14176 -- pragma Component_Alignment (
14177 -- [Form =>] ALIGNMENT_CHOICE
14178 -- [, [Name =>] type_LOCAL_NAME]);
14180 -- ALIGNMENT_CHOICE ::=
14182 -- | Component_Size_4
14186 when Pragma_Component_Alignment => Component_AlignmentP : declare
14187 Args : Args_List (1 .. 2);
14188 Names : constant Name_List (1 .. 2) := (
14192 Form : Node_Id renames Args (1);
14193 Name : Node_Id renames Args (2);
14195 Atype : Component_Alignment_Kind;
14200 Gather_Associations (Names, Args);
14203 Error_Pragma ("missing Form argument for pragma%");
14206 Check_Arg_Is_Identifier (Form);
14208 -- Get proper alignment, note that Default = Component_Size on all
14209 -- machines we have so far, and we want to set this value rather
14210 -- than the default value to indicate that it has been explicitly
14211 -- set (and thus will not get overridden by the default component
14212 -- alignment for the current scope)
14214 if Chars (Form) = Name_Component_Size then
14215 Atype := Calign_Component_Size;
14217 elsif Chars (Form) = Name_Component_Size_4 then
14218 Atype := Calign_Component_Size_4;
14220 elsif Chars (Form) = Name_Default then
14221 Atype := Calign_Component_Size;
14223 elsif Chars (Form) = Name_Storage_Unit then
14224 Atype := Calign_Storage_Unit;
14228 ("invalid Form parameter for pragma%", Form);
14231 -- The pragma appears in a configuration file
14233 if No (Parent (N)) then
14234 Check_Valid_Configuration_Pragma;
14236 -- Capture the component alignment in a global variable when
14237 -- the pragma appears in a configuration file. Note that the
14238 -- scope stack is empty at this point and cannot be used to
14239 -- store the alignment value.
14241 Configuration_Component_Alignment := Atype;
14243 -- Case with no name, supplied, affects scope table entry
14245 elsif No (Name) then
14247 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14249 -- Case of name supplied
14252 Check_Arg_Is_Local_Name (Name);
14254 Typ := Entity (Name);
14257 or else Rep_Item_Too_Early (Typ, N)
14261 Typ := Underlying_Type (Typ);
14264 if not Is_Record_Type (Typ)
14265 and then not Is_Array_Type (Typ)
14268 ("Name parameter of pragma% must identify record or "
14269 & "array type", Name);
14272 -- An explicit Component_Alignment pragma overrides an
14273 -- implicit pragma Pack, but not an explicit one.
14275 if not Has_Pragma_Pack (Base_Type (Typ)) then
14276 Set_Is_Packed (Base_Type (Typ), False);
14277 Set_Component_Alignment (Base_Type (Typ), Atype);
14280 end Component_AlignmentP;
14282 --------------------------------
14283 -- Constant_After_Elaboration --
14284 --------------------------------
14286 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14288 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14290 Obj_Decl : Node_Id;
14291 Obj_Id : Entity_Id;
14295 Check_No_Identifiers;
14296 Check_At_Most_N_Arguments (1);
14298 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14300 if Nkind (Obj_Decl) /= N_Object_Declaration then
14305 Obj_Id := Defining_Entity (Obj_Decl);
14307 -- The object declaration must be a library-level variable which
14308 -- is either explicitly initialized or obtains a value during the
14309 -- elaboration of a package body (SPARK RM 3.3.1).
14311 if Ekind (Obj_Id) = E_Variable then
14312 if not Is_Library_Level_Entity (Obj_Id) then
14314 ("pragma % must apply to a library level variable");
14318 -- Otherwise the pragma applies to a constant, which is illegal
14321 Error_Pragma ("pragma % must apply to a variable declaration");
14325 -- A pragma that applies to a Ghost entity becomes Ghost for the
14326 -- purposes of legality checks and removal of ignored Ghost code.
14328 Mark_Ghost_Pragma (N, Obj_Id);
14330 -- Chain the pragma on the contract for completeness
14332 Add_Contract_Item (N, Obj_Id);
14334 -- Analyze the Boolean expression (if any)
14336 if Present (Arg1) then
14337 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14339 end Constant_After_Elaboration;
14341 --------------------
14342 -- Contract_Cases --
14343 --------------------
14345 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14347 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14349 -- CASE_GUARD ::= boolean_EXPRESSION | others
14351 -- CONSEQUENCE ::= boolean_EXPRESSION
14353 -- Characteristics:
14355 -- * Analysis - The annotation undergoes initial checks to verify
14356 -- the legal placement and context. Secondary checks preanalyze the
14359 -- Analyze_Contract_Cases_In_Decl_Part
14361 -- * Expansion - The annotation is expanded during the expansion of
14362 -- the related subprogram [body] contract as performed in:
14364 -- Expand_Subprogram_Contract
14366 -- * Template - The annotation utilizes the generic template of the
14367 -- related subprogram [body] when it is:
14369 -- aspect on subprogram declaration
14370 -- aspect on stand-alone subprogram body
14371 -- pragma on stand-alone subprogram body
14373 -- The annotation must prepare its own template when it is:
14375 -- pragma on subprogram declaration
14377 -- * Globals - Capture of global references must occur after full
14380 -- * Instance - The annotation is instantiated automatically when
14381 -- the related generic subprogram [body] is instantiated except for
14382 -- the "pragma on subprogram declaration" case. In that scenario
14383 -- the annotation must instantiate itself.
14385 when Pragma_Contract_Cases => Contract_Cases : declare
14386 Spec_Id : Entity_Id;
14387 Subp_Decl : Node_Id;
14388 Subp_Spec : Node_Id;
14392 Check_No_Identifiers;
14393 Check_Arg_Count (1);
14395 -- Ensure the proper placement of the pragma. Contract_Cases must
14396 -- be associated with a subprogram declaration or a body that acts
14400 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14404 if Nkind (Subp_Decl) = N_Entry_Declaration then
14407 -- Generic subprogram
14409 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14412 -- Body acts as spec
14414 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14415 and then No (Corresponding_Spec (Subp_Decl))
14419 -- Body stub acts as spec
14421 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14422 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14428 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14429 Subp_Spec := Specification (Subp_Decl);
14431 -- Pragma Contract_Cases is forbidden on null procedures, as
14432 -- this may lead to potential ambiguities in behavior when
14433 -- interface null procedures are involved.
14435 if Nkind (Subp_Spec) = N_Procedure_Specification
14436 and then Null_Present (Subp_Spec)
14438 Error_Msg_N (Fix_Error
14439 ("pragma % cannot apply to null procedure"), N);
14448 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14450 -- A pragma that applies to a Ghost entity becomes Ghost for the
14451 -- purposes of legality checks and removal of ignored Ghost code.
14453 Mark_Ghost_Pragma (N, Spec_Id);
14454 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14456 -- Chain the pragma on the contract for further processing by
14457 -- Analyze_Contract_Cases_In_Decl_Part.
14459 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14461 -- Fully analyze the pragma when it appears inside an entry
14462 -- or subprogram body because it cannot benefit from forward
14465 if Nkind (Subp_Decl) in N_Entry_Body
14466 | N_Subprogram_Body
14467 | N_Subprogram_Body_Stub
14469 -- The legality checks of pragma Contract_Cases are affected by
14470 -- the SPARK mode in effect and the volatility of the context.
14471 -- Analyze all pragmas in a specific order.
14473 Analyze_If_Present (Pragma_SPARK_Mode);
14474 Analyze_If_Present (Pragma_Volatile_Function);
14475 Analyze_Contract_Cases_In_Decl_Part (N);
14477 end Contract_Cases;
14483 -- pragma Controlled (first_subtype_LOCAL_NAME);
14485 when Pragma_Controlled => Controlled : declare
14489 Check_No_Identifiers;
14490 Check_Arg_Count (1);
14491 Check_Arg_Is_Local_Name (Arg1);
14492 Arg := Get_Pragma_Arg (Arg1);
14494 if not Is_Entity_Name (Arg)
14495 or else not Is_Access_Type (Entity (Arg))
14497 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14499 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14507 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14508 -- [Entity =>] LOCAL_NAME);
14510 when Pragma_Convention => Convention : declare
14513 pragma Warnings (Off, C);
14514 pragma Warnings (Off, E);
14517 Check_Arg_Order ((Name_Convention, Name_Entity));
14518 Check_Ada_83_Warning;
14519 Check_Arg_Count (2);
14520 Process_Convention (C, E);
14522 -- A pragma that applies to a Ghost entity becomes Ghost for the
14523 -- purposes of legality checks and removal of ignored Ghost code.
14525 Mark_Ghost_Pragma (N, E);
14528 ---------------------------
14529 -- Convention_Identifier --
14530 ---------------------------
14532 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14533 -- [Convention =>] convention_IDENTIFIER);
14535 when Pragma_Convention_Identifier => Convention_Identifier : declare
14541 Check_Arg_Order ((Name_Name, Name_Convention));
14542 Check_Arg_Count (2);
14543 Check_Optional_Identifier (Arg1, Name_Name);
14544 Check_Optional_Identifier (Arg2, Name_Convention);
14545 Check_Arg_Is_Identifier (Arg1);
14546 Check_Arg_Is_Identifier (Arg2);
14547 Idnam := Chars (Get_Pragma_Arg (Arg1));
14548 Cname := Chars (Get_Pragma_Arg (Arg2));
14550 if Is_Convention_Name (Cname) then
14551 Record_Convention_Identifier
14552 (Idnam, Get_Convention_Id (Cname));
14555 ("second arg for % pragma must be convention", Arg2);
14557 end Convention_Identifier;
14563 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14565 when Pragma_CPP_Class =>
14568 if Warn_On_Obsolescent_Feature then
14570 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14571 & "effect; replace it by pragma import?j?", N);
14574 Check_Arg_Count (1);
14578 Chars => Name_Import,
14579 Pragma_Argument_Associations => New_List (
14580 Make_Pragma_Argument_Association (Loc,
14581 Expression => Make_Identifier (Loc, Name_CPP)),
14582 New_Copy (First (Pragma_Argument_Associations (N))))));
14585 ---------------------
14586 -- CPP_Constructor --
14587 ---------------------
14589 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14590 -- [, [External_Name =>] static_string_EXPRESSION ]
14591 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14593 when Pragma_CPP_Constructor => CPP_Constructor : declare
14596 Def_Id : Entity_Id;
14597 Tag_Typ : Entity_Id;
14601 Check_At_Least_N_Arguments (1);
14602 Check_At_Most_N_Arguments (3);
14603 Check_Optional_Identifier (Arg1, Name_Entity);
14604 Check_Arg_Is_Local_Name (Arg1);
14606 Id := Get_Pragma_Arg (Arg1);
14607 Find_Program_Unit_Name (Id);
14609 -- If we did not find the name, we are done
14611 if Etype (Id) = Any_Type then
14615 Def_Id := Entity (Id);
14617 -- Check if already defined as constructor
14619 if Is_Constructor (Def_Id) then
14621 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14625 if Ekind (Def_Id) = E_Function
14626 and then (Is_CPP_Class (Etype (Def_Id))
14627 or else (Is_Class_Wide_Type (Etype (Def_Id))
14629 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14631 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14633 ("'C'P'P constructor must be defined in the scope of "
14634 & "its returned type", Arg1);
14637 if Arg_Count >= 2 then
14638 Set_Imported (Def_Id);
14639 Set_Is_Public (Def_Id);
14640 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14643 Set_Has_Completion (Def_Id);
14644 Set_Is_Constructor (Def_Id);
14645 Set_Convention (Def_Id, Convention_CPP);
14647 -- Imported C++ constructors are not dispatching primitives
14648 -- because in C++ they don't have a dispatch table slot.
14649 -- However, in Ada the constructor has the profile of a
14650 -- function that returns a tagged type and therefore it has
14651 -- been treated as a primitive operation during semantic
14652 -- analysis. We now remove it from the list of primitive
14653 -- operations of the type.
14655 if Is_Tagged_Type (Etype (Def_Id))
14656 and then not Is_Class_Wide_Type (Etype (Def_Id))
14657 and then Is_Dispatching_Operation (Def_Id)
14659 Tag_Typ := Etype (Def_Id);
14661 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14662 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14666 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14667 Set_Is_Dispatching_Operation (Def_Id, False);
14670 -- For backward compatibility, if the constructor returns a
14671 -- class wide type, and we internally change the return type to
14672 -- the corresponding root type.
14674 if Is_Class_Wide_Type (Etype (Def_Id)) then
14675 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14679 ("pragma% requires function returning a 'C'P'P_Class type",
14682 end CPP_Constructor;
14688 when Pragma_CPP_Virtual =>
14691 if Warn_On_Obsolescent_Feature then
14693 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14697 --------------------
14699 --------------------
14701 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
14705 -- [, EXPRESSION]]);
14707 when Pragma_CUDA_Execute => CUDA_Execute : declare
14709 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
14710 -- Returns True if N is an acceptable argument for CUDA_Execute,
14711 -- False otherwise.
14713 ------------------------
14714 -- Is_Acceptable_Dim3 --
14715 ------------------------
14717 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
14720 if Is_RTE (Etype (N), RE_Dim3)
14721 or else Is_Integer_Type (Etype (N))
14726 if Nkind (N) = N_Aggregate
14727 and then List_Length (Expressions (N)) = 3
14729 Expr := First (Expressions (N));
14730 while Present (Expr) loop
14731 Analyze_And_Resolve (Expr, Any_Integer);
14738 end Is_Acceptable_Dim3;
14742 Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
14743 Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
14744 Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
14745 Shared_Memory : Node_Id;
14748 -- Start of processing for CUDA_Execute
14752 Check_At_Least_N_Arguments (3);
14753 Check_At_Most_N_Arguments (5);
14755 Analyze_And_Resolve (Kernel_Call);
14756 if Nkind (Kernel_Call) /= N_Function_Call
14757 or else Etype (Kernel_Call) /= Standard_Void_Type
14759 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
14760 -- GNAT sees Kernel_Call as an N_Function_Call since
14761 -- Kernel_Call "looks" like an expression. However, only
14762 -- procedures can be kernels, so to make things easier for the
14763 -- user the error message complains about Kernel_Call not being
14764 -- a procedure call.
14766 Error_Msg_N ("first argument of & must be a procedure call", N);
14769 Analyze (Grid_Dimensions);
14770 if not Is_Acceptable_Dim3 (Grid_Dimensions) then
14772 ("second argument of & must be an Integer, Dim3 or aggregate "
14773 & "containing 3 Integers", N);
14776 Analyze (Block_Dimensions);
14777 if not Is_Acceptable_Dim3 (Block_Dimensions) then
14779 ("third argument of & must be an Integer, Dim3 or aggregate "
14780 & "containing 3 Integers", N);
14783 if Present (Arg4) then
14784 Shared_Memory := Get_Pragma_Arg (Arg4);
14785 Analyze_And_Resolve (Shared_Memory, Any_Integer);
14787 if Present (Arg5) then
14788 Stream := Get_Pragma_Arg (Arg5);
14789 Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
14798 -- pragma CUDA_Global (IDENTIFIER);
14800 when Pragma_CUDA_Global => CUDA_Global : declare
14801 Arg_Node : Node_Id;
14802 Kernel_Proc : Entity_Id;
14803 Pack_Id : Entity_Id;
14806 Check_At_Least_N_Arguments (1);
14807 Check_At_Most_N_Arguments (1);
14808 Check_Optional_Identifier (Arg1, Name_Entity);
14809 Check_Arg_Is_Local_Name (Arg1);
14811 Arg_Node := Get_Pragma_Arg (Arg1);
14812 Analyze (Arg_Node);
14814 Kernel_Proc := Entity (Arg_Node);
14815 Pack_Id := Scope (Kernel_Proc);
14817 if Ekind (Kernel_Proc) /= E_Procedure then
14818 Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
14820 elsif Ekind (Pack_Id) /= E_Package
14821 or else not Is_Library_Level_Entity (Pack_Id)
14824 ("& must reside in a library-level package", N, Kernel_Proc);
14827 Set_Is_CUDA_Kernel (Kernel_Proc);
14828 Add_CUDA_Kernel (Pack_Id, Kernel_Proc);
14836 when Pragma_CPP_Vtable =>
14839 if Warn_On_Obsolescent_Feature then
14841 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14849 -- pragma CPU (EXPRESSION);
14851 when Pragma_CPU => CPU : declare
14852 P : constant Node_Id := Parent (N);
14858 Check_No_Identifiers;
14859 Check_Arg_Count (1);
14860 Arg := Get_Pragma_Arg (Arg1);
14864 if Nkind (P) = N_Subprogram_Body then
14865 Check_In_Main_Program;
14867 Analyze_And_Resolve (Arg, Any_Integer);
14869 Ent := Defining_Unit_Name (Specification (P));
14871 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14872 Ent := Defining_Identifier (Ent);
14877 if not Is_OK_Static_Expression (Arg) then
14878 Flag_Non_Static_Expr
14879 ("main subprogram affinity is not static!", Arg);
14882 -- If constraint error, then we already signalled an error
14884 elsif Raises_Constraint_Error (Arg) then
14887 -- Otherwise check in range
14891 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14892 -- This is the entity System.Multiprocessors.CPU_Range;
14894 Val : constant Uint := Expr_Value (Arg);
14897 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14899 Val > Expr_Value (Type_High_Bound (CPU_Id))
14902 ("main subprogram CPU is out of range", Arg1);
14908 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14912 elsif Nkind (P) = N_Task_Definition then
14913 Ent := Defining_Identifier (Parent (P));
14915 -- The expression must be analyzed in the special manner
14916 -- described in "Handling of Default and Per-Object
14917 -- Expressions" in sem.ads.
14919 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14921 -- See comment in Sem_Ch13 about the following restrictions
14923 if Is_OK_Static_Expression (Arg) then
14924 if Expr_Value (Arg) = Uint_0 then
14925 Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
14928 Check_Restriction (No_Dynamic_CPU_Assignment, N);
14931 -- Anything else is incorrect
14937 -- Check duplicate pragma before we chain the pragma in the Rep
14938 -- Item chain of Ent.
14940 Check_Duplicate_Pragma (Ent);
14941 Record_Rep_Item (Ent, N);
14944 --------------------
14945 -- Deadline_Floor --
14946 --------------------
14948 -- pragma Deadline_Floor (time_span_EXPRESSION);
14950 when Pragma_Deadline_Floor => Deadline_Floor : declare
14951 P : constant Node_Id := Parent (N);
14957 Check_No_Identifiers;
14958 Check_Arg_Count (1);
14960 Arg := Get_Pragma_Arg (Arg1);
14962 -- The expression must be analyzed in the special manner described
14963 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14965 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
14967 -- Only protected types allowed
14969 if Nkind (P) /= N_Protected_Definition then
14973 Ent := Defining_Identifier (Parent (P));
14975 -- Check duplicate pragma before we chain the pragma in the Rep
14976 -- Item chain of Ent.
14978 Check_Duplicate_Pragma (Ent);
14979 Record_Rep_Item (Ent, N);
14981 end Deadline_Floor;
14987 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14989 when Pragma_Debug => Debug : declare
14996 -- The condition for executing the call is that the expander
14997 -- is active and that we are not ignoring this debug pragma.
15002 (Expander_Active and then not Is_Ignored (N)),
15005 if not Is_Ignored (N) then
15006 Set_SCO_Pragma_Enabled (Loc);
15009 if Arg_Count = 2 then
15011 Make_And_Then (Loc,
15012 Left_Opnd => Relocate_Node (Cond),
15013 Right_Opnd => Get_Pragma_Arg (Arg1));
15014 Call := Get_Pragma_Arg (Arg2);
15016 Call := Get_Pragma_Arg (Arg1);
15019 if Nkind (Call) in N_Expanded_Name
15022 | N_Indexed_Component
15023 | N_Selected_Component
15025 -- If this pragma Debug comes from source, its argument was
15026 -- parsed as a name form (which is syntactically identical).
15027 -- In a generic context a parameterless call will be left as
15028 -- an expanded name (if global) or selected_component if local.
15029 -- Change it to a procedure call statement now.
15031 Change_Name_To_Procedure_Call_Statement (Call);
15033 elsif Nkind (Call) = N_Procedure_Call_Statement then
15035 -- Already in the form of a procedure call statement: nothing
15036 -- to do (could happen in case of an internally generated
15042 -- All other cases: diagnose error
15045 ("argument of pragma ""Debug"" is not procedure call",
15050 -- Rewrite into a conditional with an appropriate condition. We
15051 -- wrap the procedure call in a block so that overhead from e.g.
15052 -- use of the secondary stack does not generate execution overhead
15053 -- for suppressed conditions.
15055 -- Normally the analysis that follows will freeze the subprogram
15056 -- being called. However, if the call is to a null procedure,
15057 -- we want to freeze it before creating the block, because the
15058 -- analysis that follows may be done with expansion disabled, in
15059 -- which case the body will not be generated, leading to spurious
15062 if Nkind (Call) = N_Procedure_Call_Statement
15063 and then Is_Entity_Name (Name (Call))
15065 Analyze (Name (Call));
15066 Freeze_Before (N, Entity (Name (Call)));
15070 Make_Implicit_If_Statement (N,
15072 Then_Statements => New_List (
15073 Make_Block_Statement (Loc,
15074 Handled_Statement_Sequence =>
15075 Make_Handled_Sequence_Of_Statements (Loc,
15076 Statements => New_List (Relocate_Node (Call)))))));
15079 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15080 -- after analysis of the normally rewritten node, to capture all
15081 -- references to entities, which avoids issuing wrong warnings
15082 -- about unused entities.
15084 if GNATprove_Mode then
15085 Rewrite (N, Make_Null_Statement (Loc));
15093 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15095 when Pragma_Debug_Policy =>
15097 Check_Arg_Count (1);
15098 Check_No_Identifiers;
15099 Check_Arg_Is_Identifier (Arg1);
15101 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15102 -- rewrite it that way, and let the rest of the checking come
15103 -- from analyzing the rewritten pragma.
15107 Chars => Name_Check_Policy,
15108 Pragma_Argument_Associations => New_List (
15109 Make_Pragma_Argument_Association (Loc,
15110 Expression => Make_Identifier (Loc, Name_Debug)),
15112 Make_Pragma_Argument_Association (Loc,
15113 Expression => Get_Pragma_Arg (Arg1)))));
15116 -------------------------------
15117 -- Default_Initial_Condition --
15118 -------------------------------
15120 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15122 when Pragma_Default_Initial_Condition => DIC : declare
15129 Check_No_Identifiers;
15130 Check_At_Most_N_Arguments (2); -- Accounts for implicit type arg
15134 while Present (Stmt) loop
15136 -- Skip prior pragmas, but check for duplicates
15138 if Nkind (Stmt) = N_Pragma then
15139 if Pragma_Name (Stmt) = Pname then
15146 -- Skip internally generated code. Note that derived type
15147 -- declarations of untagged types with discriminants are
15148 -- rewritten as private type declarations.
15150 elsif not Comes_From_Source (Stmt)
15151 and then Nkind (Stmt) /= N_Private_Type_Declaration
15155 -- The associated private type [extension] has been found, stop
15158 elsif Nkind (Stmt) in N_Private_Extension_Declaration
15159 | N_Private_Type_Declaration
15161 Typ := Defining_Entity (Stmt);
15164 -- The pragma does not apply to a legal construct, issue an
15165 -- error and stop the analysis.
15172 Stmt := Prev (Stmt);
15175 -- The pragma does not apply to a legal construct, issue an error
15176 -- and stop the analysis.
15183 -- A pragma that applies to a Ghost entity becomes Ghost for the
15184 -- purposes of legality checks and removal of ignored Ghost code.
15186 Mark_Ghost_Pragma (N, Typ);
15188 -- The pragma signals that the type defines its own DIC assertion
15191 Set_Has_Own_DIC (Typ);
15193 -- A type entity argument is appended to facilitate inheriting the
15194 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
15195 -- though that extra argument isn't documented for the pragma.
15197 if not Present (Arg2) then
15198 -- When the pragma has no arguments, create an argument with
15199 -- the value Empty, so the type name argument can be appended
15200 -- following it (since it's expected as the second argument).
15202 if not Present (Arg1) then
15203 Set_Pragma_Argument_Associations (N, New_List (
15204 Make_Pragma_Argument_Association (Sloc (Typ),
15205 Expression => Empty)));
15209 (Pragma_Argument_Associations (N),
15210 Make_Pragma_Argument_Association (Sloc (Typ),
15211 Expression => New_Occurrence_Of (Typ, Sloc (Typ))));
15214 -- Chain the pragma on the rep item chain for further processing
15216 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15218 -- Create the declaration of the procedure which verifies the
15219 -- assertion expression of pragma DIC at runtime.
15221 Build_DIC_Procedure_Declaration (Typ);
15224 ----------------------------------
15225 -- Default_Scalar_Storage_Order --
15226 ----------------------------------
15228 -- pragma Default_Scalar_Storage_Order
15229 -- (High_Order_First | Low_Order_First);
15231 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15232 Default : Character;
15236 Check_Arg_Count (1);
15238 -- Default_Scalar_Storage_Order can appear as a configuration
15239 -- pragma, or in a declarative part of a package spec.
15241 if not Is_Configuration_Pragma then
15242 Check_Is_In_Decl_Part_Or_Package_Spec;
15245 Check_No_Identifiers;
15246 Check_Arg_Is_One_Of
15247 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15248 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15249 Default := Fold_Upper (Name_Buffer (1));
15251 if not Support_Nondefault_SSO_On_Target
15252 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15254 if Warn_On_Unrecognized_Pragma then
15256 ("non-default Scalar_Storage_Order not supported "
15257 & "on target?g?", N);
15259 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15262 -- Here set the specified default
15265 Opt.Default_SSO := Default;
15269 --------------------------
15270 -- Default_Storage_Pool --
15271 --------------------------
15273 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15275 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15280 Check_Arg_Count (1);
15282 -- Default_Storage_Pool can appear as a configuration pragma, or
15283 -- in a declarative part of a package spec.
15285 if not Is_Configuration_Pragma then
15286 Check_Is_In_Decl_Part_Or_Package_Spec;
15289 if From_Aspect_Specification (N) then
15291 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15293 if not In_Open_Scopes (E) then
15295 ("aspect must apply to package or subprogram", N);
15300 if Present (Arg1) then
15301 Pool := Get_Pragma_Arg (Arg1);
15303 -- Case of Default_Storage_Pool (null);
15305 if Nkind (Pool) = N_Null then
15308 -- This is an odd case, this is not really an expression,
15309 -- so we don't have a type for it. So just set the type to
15312 Set_Etype (Pool, Empty);
15314 -- Case of Default_Storage_Pool (Standard);
15316 elsif Nkind (Pool) = N_Identifier
15317 and then Chars (Pool) = Name_Standard
15321 if Entity (Pool) /= Standard_Standard then
15323 ("package Standard is not directly visible", Arg1);
15326 -- Case of Default_Storage_Pool (storage_pool_NAME);
15329 -- If it's a configuration pragma, then the only allowed
15330 -- argument is "null".
15332 if Is_Configuration_Pragma then
15333 Error_Pragma_Arg ("NULL or Standard expected", Arg1);
15336 -- The expected type for a non-"null" argument is
15337 -- Root_Storage_Pool'Class, and the pool must be a variable.
15339 Analyze_And_Resolve
15340 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15342 if Is_Variable (Pool) then
15344 -- A pragma that applies to a Ghost entity becomes Ghost
15345 -- for the purposes of legality checks and removal of
15346 -- ignored Ghost code.
15348 Mark_Ghost_Pragma (N, Entity (Pool));
15352 ("default storage pool must be a variable", Arg1);
15356 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15357 -- access type will use this information to set the appropriate
15358 -- attributes of the access type. If the pragma appears in a
15359 -- generic unit it is ignored, given that it may refer to a
15362 if not Inside_A_Generic then
15363 Default_Pool := Pool;
15366 end Default_Storage_Pool;
15372 -- pragma Depends (DEPENDENCY_RELATION);
15374 -- DEPENDENCY_RELATION ::=
15376 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15378 -- DEPENDENCY_CLAUSE ::=
15379 -- OUTPUT_LIST =>[+] INPUT_LIST
15380 -- | NULL_DEPENDENCY_CLAUSE
15382 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15384 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15386 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15388 -- OUTPUT ::= NAME | FUNCTION_RESULT
15391 -- where FUNCTION_RESULT is a function Result attribute_reference
15393 -- Characteristics:
15395 -- * Analysis - The annotation undergoes initial checks to verify
15396 -- the legal placement and context. Secondary checks fully analyze
15397 -- the dependency clauses in:
15399 -- Analyze_Depends_In_Decl_Part
15401 -- * Expansion - None.
15403 -- * Template - The annotation utilizes the generic template of the
15404 -- related subprogram [body] when it is:
15406 -- aspect on subprogram declaration
15407 -- aspect on stand-alone subprogram body
15408 -- pragma on stand-alone subprogram body
15410 -- The annotation must prepare its own template when it is:
15412 -- pragma on subprogram declaration
15414 -- * Globals - Capture of global references must occur after full
15417 -- * Instance - The annotation is instantiated automatically when
15418 -- the related generic subprogram [body] is instantiated except for
15419 -- the "pragma on subprogram declaration" case. In that scenario
15420 -- the annotation must instantiate itself.
15422 when Pragma_Depends => Depends : declare
15424 Spec_Id : Entity_Id;
15425 Subp_Decl : Node_Id;
15428 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15432 -- Chain the pragma on the contract for further processing by
15433 -- Analyze_Depends_In_Decl_Part.
15435 Add_Contract_Item (N, Spec_Id);
15437 -- Fully analyze the pragma when it appears inside an entry
15438 -- or subprogram body because it cannot benefit from forward
15441 if Nkind (Subp_Decl) in N_Entry_Body
15442 | N_Subprogram_Body
15443 | N_Subprogram_Body_Stub
15445 -- The legality checks of pragmas Depends and Global are
15446 -- affected by the SPARK mode in effect and the volatility
15447 -- of the context. In addition these two pragmas are subject
15448 -- to an inherent order:
15453 -- Analyze all these pragmas in the order outlined above
15455 Analyze_If_Present (Pragma_SPARK_Mode);
15456 Analyze_If_Present (Pragma_Volatile_Function);
15457 Analyze_If_Present (Pragma_Global);
15458 Analyze_Depends_In_Decl_Part (N);
15463 ---------------------
15464 -- Detect_Blocking --
15465 ---------------------
15467 -- pragma Detect_Blocking;
15469 when Pragma_Detect_Blocking =>
15471 Check_Arg_Count (0);
15472 Check_Valid_Configuration_Pragma;
15473 Detect_Blocking := True;
15475 ------------------------------------
15476 -- Disable_Atomic_Synchronization --
15477 ------------------------------------
15479 -- pragma Disable_Atomic_Synchronization [(Entity)];
15481 when Pragma_Disable_Atomic_Synchronization =>
15483 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15485 -------------------
15486 -- Discard_Names --
15487 -------------------
15489 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15491 when Pragma_Discard_Names => Discard_Names : declare
15496 Check_Ada_83_Warning;
15498 -- Deal with configuration pragma case
15500 if Arg_Count = 0 and then Is_Configuration_Pragma then
15501 Global_Discard_Names := True;
15504 -- Otherwise, check correct appropriate context
15507 Check_Is_In_Decl_Part_Or_Package_Spec;
15509 if Arg_Count = 0 then
15511 -- If there is no parameter, then from now on this pragma
15512 -- applies to any enumeration, exception or tagged type
15513 -- defined in the current declarative part, and recursively
15514 -- to any nested scope.
15516 Set_Discard_Names (Current_Scope);
15520 Check_Arg_Count (1);
15521 Check_Optional_Identifier (Arg1, Name_On);
15522 Check_Arg_Is_Local_Name (Arg1);
15524 E_Id := Get_Pragma_Arg (Arg1);
15526 if Etype (E_Id) = Any_Type then
15530 E := Entity (E_Id);
15532 -- A pragma that applies to a Ghost entity becomes Ghost for
15533 -- the purposes of legality checks and removal of ignored
15536 Mark_Ghost_Pragma (N, E);
15538 if (Is_First_Subtype (E)
15540 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15541 or else Ekind (E) = E_Exception
15543 Set_Discard_Names (E);
15544 Record_Rep_Item (E, N);
15548 ("inappropriate entity for pragma%", Arg1);
15554 ------------------------
15555 -- Dispatching_Domain --
15556 ------------------------
15558 -- pragma Dispatching_Domain (EXPRESSION);
15560 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15561 P : constant Node_Id := Parent (N);
15567 Check_No_Identifiers;
15568 Check_Arg_Count (1);
15570 -- This pragma is born obsolete, but not the aspect
15572 if not From_Aspect_Specification (N) then
15574 (No_Obsolescent_Features, Pragma_Identifier (N));
15577 if Nkind (P) = N_Task_Definition then
15578 Arg := Get_Pragma_Arg (Arg1);
15579 Ent := Defining_Identifier (Parent (P));
15581 -- A pragma that applies to a Ghost entity becomes Ghost for
15582 -- the purposes of legality checks and removal of ignored Ghost
15585 Mark_Ghost_Pragma (N, Ent);
15587 -- The expression must be analyzed in the special manner
15588 -- described in "Handling of Default and Per-Object
15589 -- Expressions" in sem.ads.
15591 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15593 -- Check duplicate pragma before we chain the pragma in the Rep
15594 -- Item chain of Ent.
15596 Check_Duplicate_Pragma (Ent);
15597 Record_Rep_Item (Ent, N);
15599 -- Anything else is incorrect
15604 end Dispatching_Domain;
15610 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15612 when Pragma_Elaborate => Elaborate : declare
15617 -- Pragma must be in context items list of a compilation unit
15619 if not Is_In_Context_Clause then
15623 -- Must be at least one argument
15625 if Arg_Count = 0 then
15626 Error_Pragma ("pragma% requires at least one argument");
15629 -- In Ada 83 mode, there can be no items following it in the
15630 -- context list except other pragmas and implicit with clauses
15631 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15632 -- placement rule does not apply.
15634 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15636 while Present (Citem) loop
15637 if Nkind (Citem) = N_Pragma
15638 or else (Nkind (Citem) = N_With_Clause
15639 and then Implicit_With (Citem))
15644 ("(Ada 83) pragma% must be at end of context clause");
15651 -- Finally, the arguments must all be units mentioned in a with
15652 -- clause in the same context clause. Note we already checked (in
15653 -- Par.Prag) that the arguments are all identifiers or selected
15657 Outer : while Present (Arg) loop
15658 Citem := First (List_Containing (N));
15659 Inner : while Citem /= N loop
15660 if Nkind (Citem) = N_With_Clause
15661 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15663 Set_Elaborate_Present (Citem, True);
15664 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15666 -- With the pragma present, elaboration calls on
15667 -- subprograms from the named unit need no further
15668 -- checks, as long as the pragma appears in the current
15669 -- compilation unit. If the pragma appears in some unit
15670 -- in the context, there might still be a need for an
15671 -- Elaborate_All_Desirable from the current compilation
15672 -- to the named unit, so we keep the check enabled. This
15673 -- does not apply in SPARK mode, where we allow pragma
15674 -- Elaborate, but we don't trust it to be right so we
15675 -- will still insist on the Elaborate_All.
15677 if Legacy_Elaboration_Checks
15678 and then In_Extended_Main_Source_Unit (N)
15679 and then SPARK_Mode /= On
15681 Set_Suppress_Elaboration_Warnings
15682 (Entity (Name (Citem)));
15693 ("argument of pragma% is not withed unit", Arg);
15700 -------------------
15701 -- Elaborate_All --
15702 -------------------
15704 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15706 when Pragma_Elaborate_All => Elaborate_All : declare
15711 Check_Ada_83_Warning;
15713 -- Pragma must be in context items list of a compilation unit
15715 if not Is_In_Context_Clause then
15719 -- Must be at least one argument
15721 if Arg_Count = 0 then
15722 Error_Pragma ("pragma% requires at least one argument");
15725 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15726 -- have to appear at the end of the context clause, but may
15727 -- appear mixed in with other items, even in Ada 83 mode.
15729 -- Final check: the arguments must all be units mentioned in
15730 -- a with clause in the same context clause. Note that we
15731 -- already checked (in Par.Prag) that all the arguments are
15732 -- either identifiers or selected components.
15735 Outr : while Present (Arg) loop
15736 Citem := First (List_Containing (N));
15737 Innr : while Citem /= N loop
15738 if Nkind (Citem) = N_With_Clause
15739 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15741 Set_Elaborate_All_Present (Citem, True);
15742 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15744 -- Suppress warnings and elaboration checks on the named
15745 -- unit if the pragma is in the current compilation, as
15746 -- for pragma Elaborate.
15748 if Legacy_Elaboration_Checks
15749 and then In_Extended_Main_Source_Unit (N)
15751 Set_Suppress_Elaboration_Warnings
15752 (Entity (Name (Citem)));
15762 Set_Error_Posted (N);
15764 ("argument of pragma% is not withed unit", Arg);
15771 --------------------
15772 -- Elaborate_Body --
15773 --------------------
15775 -- pragma Elaborate_Body [( library_unit_NAME )];
15777 when Pragma_Elaborate_Body => Elaborate_Body : declare
15778 Cunit_Node : Node_Id;
15779 Cunit_Ent : Entity_Id;
15782 Check_Ada_83_Warning;
15783 Check_Valid_Library_Unit_Pragma;
15785 Cunit_Node := Cunit (Current_Sem_Unit);
15786 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15788 -- A pragma that applies to a Ghost entity becomes Ghost for the
15789 -- purposes of legality checks and removal of ignored Ghost code.
15791 Mark_Ghost_Pragma (N, Cunit_Ent);
15793 if Nkind (Unit (Cunit_Node)) in
15794 N_Package_Body | N_Subprogram_Body
15796 Error_Pragma ("pragma% must refer to a spec, not a body");
15798 Set_Body_Required (Cunit_Node);
15799 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15801 -- If we are in dynamic elaboration mode, then we suppress
15802 -- elaboration warnings for the unit, since it is definitely
15803 -- fine NOT to do dynamic checks at the first level (and such
15804 -- checks will be suppressed because no elaboration boolean
15805 -- is created for Elaborate_Body packages).
15807 -- But in the static model of elaboration, Elaborate_Body is
15808 -- definitely NOT good enough to ensure elaboration safety on
15809 -- its own, since the body may WITH other units that are not
15810 -- safe from an elaboration point of view, so a client must
15811 -- still do an Elaborate_All on such units.
15813 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15814 -- Elaborate_Body always suppressed elab warnings.
15816 if Legacy_Elaboration_Checks
15817 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15819 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15822 end Elaborate_Body;
15824 ------------------------
15825 -- Elaboration_Checks --
15826 ------------------------
15828 -- pragma Elaboration_Checks (Static | Dynamic);
15830 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15831 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15832 -- Emit an error if the current context list already contains
15833 -- a previous Elaboration_Checks pragma. This routine raises
15834 -- Pragma_Exit if a duplicate is found.
15836 procedure Ignore_Elaboration_Checks_Pragma;
15837 -- Warn that the effects of the pragma are ignored. This routine
15838 -- raises Pragma_Exit.
15840 -----------------------------------------------
15841 -- Check_Duplicate_Elaboration_Checks_Pragma --
15842 -----------------------------------------------
15844 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15849 while Present (Item) loop
15850 if Nkind (Item) = N_Pragma
15851 and then Pragma_Name (Item) = Name_Elaboration_Checks
15861 end Check_Duplicate_Elaboration_Checks_Pragma;
15863 --------------------------------------
15864 -- Ignore_Elaboration_Checks_Pragma --
15865 --------------------------------------
15867 procedure Ignore_Elaboration_Checks_Pragma is
15869 Error_Msg_Name_1 := Pname;
15870 Error_Msg_N ("??effects of pragma % are ignored", N);
15872 ("\place pragma on initial declaration of library unit", N);
15875 end Ignore_Elaboration_Checks_Pragma;
15879 Context : constant Node_Id := Parent (N);
15882 -- Start of processing for Elaboration_Checks
15886 Check_Arg_Count (1);
15887 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15889 -- The pragma appears in a configuration file
15891 if No (Context) then
15892 Check_Valid_Configuration_Pragma;
15893 Check_Duplicate_Elaboration_Checks_Pragma;
15895 -- The pragma acts as a configuration pragma in a compilation unit
15897 -- pragma Elaboration_Checks (...);
15898 -- package Pack is ...;
15900 elsif Nkind (Context) = N_Compilation_Unit
15901 and then List_Containing (N) = Context_Items (Context)
15903 Check_Valid_Configuration_Pragma;
15904 Check_Duplicate_Elaboration_Checks_Pragma;
15906 Unt := Unit (Context);
15908 -- The pragma must appear on the initial declaration of a unit.
15909 -- If this is not the case, warn that the effects of the pragma
15912 if Nkind (Unt) = N_Package_Body then
15913 Ignore_Elaboration_Checks_Pragma;
15915 -- Check the Acts_As_Spec flag of the compilation units itself
15916 -- to determine whether the subprogram body completes since it
15917 -- has not been analyzed yet. This is safe because compilation
15918 -- units are not overloadable.
15920 elsif Nkind (Unt) = N_Subprogram_Body
15921 and then not Acts_As_Spec (Context)
15923 Ignore_Elaboration_Checks_Pragma;
15925 elsif Nkind (Unt) = N_Subunit then
15926 Ignore_Elaboration_Checks_Pragma;
15929 -- Otherwise the pragma does not appear at the configuration level
15936 -- At this point the pragma is not a duplicate, and appears in the
15937 -- proper context. Set the elaboration model in effect.
15939 Dynamic_Elaboration_Checks :=
15940 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15941 end Elaboration_Checks;
15947 -- pragma Eliminate (
15948 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15949 -- [Entity =>] IDENTIFIER |
15950 -- SELECTED_COMPONENT |
15952 -- [, Source_Location => SOURCE_TRACE]);
15954 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15955 -- SOURCE_TRACE ::= STRING_LITERAL
15957 when Pragma_Eliminate => Eliminate : declare
15958 Args : Args_List (1 .. 5);
15959 Names : constant Name_List (1 .. 5) := (
15962 Name_Parameter_Types,
15964 Name_Source_Location);
15966 -- Note : Parameter_Types and Result_Type are leftovers from
15967 -- prior implementations of the pragma. They are not generated
15968 -- by the gnatelim tool, and play no role in selecting which
15969 -- of a set of overloaded names is chosen for elimination.
15971 Unit_Name : Node_Id renames Args (1);
15972 Entity : Node_Id renames Args (2);
15973 Parameter_Types : Node_Id renames Args (3);
15974 Result_Type : Node_Id renames Args (4);
15975 Source_Location : Node_Id renames Args (5);
15979 Check_Valid_Configuration_Pragma;
15980 Gather_Associations (Names, Args);
15982 if No (Unit_Name) then
15983 Error_Pragma ("missing Unit_Name argument for pragma%");
15987 and then (Present (Parameter_Types)
15989 Present (Result_Type)
15991 Present (Source_Location))
15993 Error_Pragma ("missing Entity argument for pragma%");
15996 if (Present (Parameter_Types)
15998 Present (Result_Type))
16000 Present (Source_Location)
16003 ("parameter profile and source location cannot be used "
16004 & "together in pragma%");
16007 Process_Eliminate_Pragma
16016 -----------------------------------
16017 -- Enable_Atomic_Synchronization --
16018 -----------------------------------
16020 -- pragma Enable_Atomic_Synchronization [(Entity)];
16022 when Pragma_Enable_Atomic_Synchronization =>
16024 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16031 -- [ Convention =>] convention_IDENTIFIER,
16032 -- [ Entity =>] LOCAL_NAME
16033 -- [, [External_Name =>] static_string_EXPRESSION ]
16034 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16036 when Pragma_Export => Export : declare
16038 Def_Id : Entity_Id;
16040 pragma Warnings (Off, C);
16043 Check_Ada_83_Warning;
16047 Name_External_Name,
16050 Check_At_Least_N_Arguments (2);
16051 Check_At_Most_N_Arguments (4);
16053 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16054 -- pragma Export (Entity, "external name");
16056 if Relaxed_RM_Semantics
16057 and then Arg_Count = 2
16058 and then Nkind (Expression (Arg2)) = N_String_Literal
16061 Def_Id := Get_Pragma_Arg (Arg1);
16064 if not Is_Entity_Name (Def_Id) then
16065 Error_Pragma_Arg ("entity name required", Arg1);
16068 Def_Id := Entity (Def_Id);
16069 Set_Exported (Def_Id, Arg1);
16072 Process_Convention (C, Def_Id);
16074 -- A pragma that applies to a Ghost entity becomes Ghost for
16075 -- the purposes of legality checks and removal of ignored Ghost
16078 Mark_Ghost_Pragma (N, Def_Id);
16080 if Ekind (Def_Id) /= E_Constant then
16081 Note_Possible_Modification
16082 (Get_Pragma_Arg (Arg2), Sure => False);
16085 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16086 Set_Exported (Def_Id, Arg2);
16089 -- If the entity is a deferred constant, propagate the information
16090 -- to the full view, because gigi elaborates the full view only.
16092 if Ekind (Def_Id) = E_Constant
16093 and then Present (Full_View (Def_Id))
16096 Id2 : constant Entity_Id := Full_View (Def_Id);
16098 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16099 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16100 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16105 ---------------------
16106 -- Export_Function --
16107 ---------------------
16109 -- pragma Export_Function (
16110 -- [Internal =>] LOCAL_NAME
16111 -- [, [External =>] EXTERNAL_SYMBOL]
16112 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16113 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16114 -- [, [Mechanism =>] MECHANISM]
16115 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16117 -- EXTERNAL_SYMBOL ::=
16119 -- | static_string_EXPRESSION
16121 -- PARAMETER_TYPES ::=
16123 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16125 -- TYPE_DESIGNATOR ::=
16127 -- | subtype_Name ' Access
16131 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16133 -- MECHANISM_ASSOCIATION ::=
16134 -- [formal_parameter_NAME =>] MECHANISM_NAME
16136 -- MECHANISM_NAME ::=
16140 when Pragma_Export_Function => Export_Function : declare
16141 Args : Args_List (1 .. 6);
16142 Names : constant Name_List (1 .. 6) := (
16145 Name_Parameter_Types,
16148 Name_Result_Mechanism);
16150 Internal : Node_Id renames Args (1);
16151 External : Node_Id renames Args (2);
16152 Parameter_Types : Node_Id renames Args (3);
16153 Result_Type : Node_Id renames Args (4);
16154 Mechanism : Node_Id renames Args (5);
16155 Result_Mechanism : Node_Id renames Args (6);
16159 Gather_Associations (Names, Args);
16160 Process_Extended_Import_Export_Subprogram_Pragma (
16161 Arg_Internal => Internal,
16162 Arg_External => External,
16163 Arg_Parameter_Types => Parameter_Types,
16164 Arg_Result_Type => Result_Type,
16165 Arg_Mechanism => Mechanism,
16166 Arg_Result_Mechanism => Result_Mechanism);
16167 end Export_Function;
16169 -------------------
16170 -- Export_Object --
16171 -------------------
16173 -- pragma Export_Object (
16174 -- [Internal =>] LOCAL_NAME
16175 -- [, [External =>] EXTERNAL_SYMBOL]
16176 -- [, [Size =>] EXTERNAL_SYMBOL]);
16178 -- EXTERNAL_SYMBOL ::=
16180 -- | static_string_EXPRESSION
16182 -- PARAMETER_TYPES ::=
16184 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16186 -- TYPE_DESIGNATOR ::=
16188 -- | subtype_Name ' Access
16192 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16194 -- MECHANISM_ASSOCIATION ::=
16195 -- [formal_parameter_NAME =>] MECHANISM_NAME
16197 -- MECHANISM_NAME ::=
16201 when Pragma_Export_Object => Export_Object : declare
16202 Args : Args_List (1 .. 3);
16203 Names : constant Name_List (1 .. 3) := (
16208 Internal : Node_Id renames Args (1);
16209 External : Node_Id renames Args (2);
16210 Size : Node_Id renames Args (3);
16214 Gather_Associations (Names, Args);
16215 Process_Extended_Import_Export_Object_Pragma (
16216 Arg_Internal => Internal,
16217 Arg_External => External,
16221 ----------------------
16222 -- Export_Procedure --
16223 ----------------------
16225 -- pragma Export_Procedure (
16226 -- [Internal =>] LOCAL_NAME
16227 -- [, [External =>] EXTERNAL_SYMBOL]
16228 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16229 -- [, [Mechanism =>] MECHANISM]);
16231 -- EXTERNAL_SYMBOL ::=
16233 -- | static_string_EXPRESSION
16235 -- PARAMETER_TYPES ::=
16237 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16239 -- TYPE_DESIGNATOR ::=
16241 -- | subtype_Name ' Access
16245 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16247 -- MECHANISM_ASSOCIATION ::=
16248 -- [formal_parameter_NAME =>] MECHANISM_NAME
16250 -- MECHANISM_NAME ::=
16254 when Pragma_Export_Procedure => Export_Procedure : declare
16255 Args : Args_List (1 .. 4);
16256 Names : constant Name_List (1 .. 4) := (
16259 Name_Parameter_Types,
16262 Internal : Node_Id renames Args (1);
16263 External : Node_Id renames Args (2);
16264 Parameter_Types : Node_Id renames Args (3);
16265 Mechanism : Node_Id renames Args (4);
16269 Gather_Associations (Names, Args);
16270 Process_Extended_Import_Export_Subprogram_Pragma (
16271 Arg_Internal => Internal,
16272 Arg_External => External,
16273 Arg_Parameter_Types => Parameter_Types,
16274 Arg_Mechanism => Mechanism);
16275 end Export_Procedure;
16281 -- pragma Export_Value (
16282 -- [Value =>] static_integer_EXPRESSION,
16283 -- [Link_Name =>] static_string_EXPRESSION);
16285 when Pragma_Export_Value =>
16287 Check_Arg_Order ((Name_Value, Name_Link_Name));
16288 Check_Arg_Count (2);
16290 Check_Optional_Identifier (Arg1, Name_Value);
16291 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16293 Check_Optional_Identifier (Arg2, Name_Link_Name);
16294 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16296 -----------------------------
16297 -- Export_Valued_Procedure --
16298 -----------------------------
16300 -- pragma Export_Valued_Procedure (
16301 -- [Internal =>] LOCAL_NAME
16302 -- [, [External =>] EXTERNAL_SYMBOL,]
16303 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16304 -- [, [Mechanism =>] MECHANISM]);
16306 -- EXTERNAL_SYMBOL ::=
16308 -- | static_string_EXPRESSION
16310 -- PARAMETER_TYPES ::=
16312 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16314 -- TYPE_DESIGNATOR ::=
16316 -- | subtype_Name ' Access
16320 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16322 -- MECHANISM_ASSOCIATION ::=
16323 -- [formal_parameter_NAME =>] MECHANISM_NAME
16325 -- MECHANISM_NAME ::=
16329 when Pragma_Export_Valued_Procedure =>
16330 Export_Valued_Procedure : declare
16331 Args : Args_List (1 .. 4);
16332 Names : constant Name_List (1 .. 4) := (
16335 Name_Parameter_Types,
16338 Internal : Node_Id renames Args (1);
16339 External : Node_Id renames Args (2);
16340 Parameter_Types : Node_Id renames Args (3);
16341 Mechanism : Node_Id renames Args (4);
16345 Gather_Associations (Names, Args);
16346 Process_Extended_Import_Export_Subprogram_Pragma (
16347 Arg_Internal => Internal,
16348 Arg_External => External,
16349 Arg_Parameter_Types => Parameter_Types,
16350 Arg_Mechanism => Mechanism);
16351 end Export_Valued_Procedure;
16353 -------------------
16354 -- Extend_System --
16355 -------------------
16357 -- pragma Extend_System ([Name =>] Identifier);
16359 when Pragma_Extend_System =>
16361 Check_Valid_Configuration_Pragma;
16362 Check_Arg_Count (1);
16363 Check_Optional_Identifier (Arg1, Name_Name);
16364 Check_Arg_Is_Identifier (Arg1);
16366 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16369 and then Name_Buffer (1 .. 4) = "aux_"
16371 if Present (System_Extend_Pragma_Arg) then
16372 if Chars (Get_Pragma_Arg (Arg1)) =
16373 Chars (Expression (System_Extend_Pragma_Arg))
16377 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16378 Error_Pragma ("pragma% conflicts with that #");
16382 System_Extend_Pragma_Arg := Arg1;
16384 if not GNAT_Mode then
16385 System_Extend_Unit := Arg1;
16389 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16392 ------------------------
16393 -- Extensions_Allowed --
16394 ------------------------
16396 -- pragma Extensions_Allowed (ON | OFF);
16398 when Pragma_Extensions_Allowed =>
16400 Check_Arg_Count (1);
16401 Check_No_Identifiers;
16402 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16404 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16405 Extensions_Allowed := True;
16406 Ada_Version := Ada_Version_Type'Last;
16409 Extensions_Allowed := False;
16410 Ada_Version := Ada_Version_Explicit;
16411 Ada_Version_Pragma := Empty;
16414 ------------------------
16415 -- Extensions_Visible --
16416 ------------------------
16418 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16420 -- Characteristics:
16422 -- * Analysis - The annotation is fully analyzed immediately upon
16423 -- elaboration as its expression must be static.
16425 -- * Expansion - None.
16427 -- * Template - The annotation utilizes the generic template of the
16428 -- related subprogram [body] when it is:
16430 -- aspect on subprogram declaration
16431 -- aspect on stand-alone subprogram body
16432 -- pragma on stand-alone subprogram body
16434 -- The annotation must prepare its own template when it is:
16436 -- pragma on subprogram declaration
16438 -- * Globals - Capture of global references must occur after full
16441 -- * Instance - The annotation is instantiated automatically when
16442 -- the related generic subprogram [body] is instantiated except for
16443 -- the "pragma on subprogram declaration" case. In that scenario
16444 -- the annotation must instantiate itself.
16446 when Pragma_Extensions_Visible => Extensions_Visible : declare
16447 Formal : Entity_Id;
16448 Has_OK_Formal : Boolean := False;
16449 Spec_Id : Entity_Id;
16450 Subp_Decl : Node_Id;
16454 Check_No_Identifiers;
16455 Check_At_Most_N_Arguments (1);
16458 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16460 -- Abstract subprogram declaration
16462 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16465 -- Generic subprogram declaration
16467 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16470 -- Body acts as spec
16472 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16473 and then No (Corresponding_Spec (Subp_Decl))
16477 -- Body stub acts as spec
16479 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16480 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16484 -- Subprogram declaration
16486 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16489 -- Otherwise the pragma is associated with an illegal construct
16492 Error_Pragma ("pragma % must apply to a subprogram");
16496 -- Mark the pragma as Ghost if the related subprogram is also
16497 -- Ghost. This also ensures that any expansion performed further
16498 -- below will produce Ghost nodes.
16500 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16501 Mark_Ghost_Pragma (N, Spec_Id);
16503 -- Chain the pragma on the contract for completeness
16505 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16507 -- The legality checks of pragma Extension_Visible are affected
16508 -- by the SPARK mode in effect. Analyze all pragmas in specific
16511 Analyze_If_Present (Pragma_SPARK_Mode);
16513 -- Examine the formals of the related subprogram
16515 Formal := First_Formal (Spec_Id);
16516 while Present (Formal) loop
16518 -- At least one of the formals is of a specific tagged type,
16519 -- the pragma is legal.
16521 if Is_Specific_Tagged_Type (Etype (Formal)) then
16522 Has_OK_Formal := True;
16525 -- A generic subprogram with at least one formal of a private
16526 -- type ensures the legality of the pragma because the actual
16527 -- may be specifically tagged. Note that this is verified by
16528 -- the check above at instantiation time.
16530 elsif Is_Private_Type (Etype (Formal))
16531 and then Is_Generic_Type (Etype (Formal))
16533 Has_OK_Formal := True;
16537 Next_Formal (Formal);
16540 if not Has_OK_Formal then
16541 Error_Msg_Name_1 := Pname;
16542 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16544 ("\subprogram & lacks parameter of specific tagged or "
16545 & "generic private type", N, Spec_Id);
16550 -- Analyze the Boolean expression (if any)
16552 if Present (Arg1) then
16553 Check_Static_Boolean_Expression
16554 (Expression (Get_Argument (N, Spec_Id)));
16556 end Extensions_Visible;
16562 -- pragma External (
16563 -- [ Convention =>] convention_IDENTIFIER,
16564 -- [ Entity =>] LOCAL_NAME
16565 -- [, [External_Name =>] static_string_EXPRESSION ]
16566 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16568 when Pragma_External => External : declare
16571 pragma Warnings (Off, C);
16578 Name_External_Name,
16580 Check_At_Least_N_Arguments (2);
16581 Check_At_Most_N_Arguments (4);
16582 Process_Convention (C, E);
16584 -- A pragma that applies to a Ghost entity becomes Ghost for the
16585 -- purposes of legality checks and removal of ignored Ghost code.
16587 Mark_Ghost_Pragma (N, E);
16589 Note_Possible_Modification
16590 (Get_Pragma_Arg (Arg2), Sure => False);
16591 Process_Interface_Name (E, Arg3, Arg4, N);
16592 Set_Exported (E, Arg2);
16595 --------------------------
16596 -- External_Name_Casing --
16597 --------------------------
16599 -- pragma External_Name_Casing (
16600 -- UPPERCASE | LOWERCASE
16601 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16603 when Pragma_External_Name_Casing =>
16605 Check_No_Identifiers;
16607 if Arg_Count = 2 then
16608 Check_Arg_Is_One_Of
16609 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16611 case Chars (Get_Pragma_Arg (Arg2)) is
16613 Opt.External_Name_Exp_Casing := As_Is;
16615 when Name_Uppercase =>
16616 Opt.External_Name_Exp_Casing := Uppercase;
16618 when Name_Lowercase =>
16619 Opt.External_Name_Exp_Casing := Lowercase;
16626 Check_Arg_Count (1);
16629 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16631 case Chars (Get_Pragma_Arg (Arg1)) is
16632 when Name_Uppercase =>
16633 Opt.External_Name_Imp_Casing := Uppercase;
16635 when Name_Lowercase =>
16636 Opt.External_Name_Imp_Casing := Lowercase;
16646 -- pragma Fast_Math;
16648 when Pragma_Fast_Math =>
16650 Check_No_Identifiers;
16651 Check_Valid_Configuration_Pragma;
16654 --------------------------
16655 -- Favor_Top_Level --
16656 --------------------------
16658 -- pragma Favor_Top_Level (type_NAME);
16660 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16665 Check_No_Identifiers;
16666 Check_Arg_Count (1);
16667 Check_Arg_Is_Local_Name (Arg1);
16668 Typ := Entity (Get_Pragma_Arg (Arg1));
16670 -- A pragma that applies to a Ghost entity becomes Ghost for the
16671 -- purposes of legality checks and removal of ignored Ghost code.
16673 Mark_Ghost_Pragma (N, Typ);
16675 -- If it's an access-to-subprogram type (in particular, not a
16676 -- subtype), set the flag on that type.
16678 if Is_Access_Subprogram_Type (Typ) then
16679 Set_Can_Use_Internal_Rep (Typ, False);
16681 -- Otherwise it's an error (name denotes the wrong sort of entity)
16685 ("access-to-subprogram type expected",
16686 Get_Pragma_Arg (Arg1));
16688 end Favor_Top_Level;
16690 ---------------------------
16691 -- Finalize_Storage_Only --
16692 ---------------------------
16694 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16696 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16697 Assoc : constant Node_Id := Arg1;
16698 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16703 Check_No_Identifiers;
16704 Check_Arg_Count (1);
16705 Check_Arg_Is_Local_Name (Arg1);
16707 Find_Type (Type_Id);
16708 Typ := Entity (Type_Id);
16711 or else Rep_Item_Too_Early (Typ, N)
16715 Typ := Underlying_Type (Typ);
16718 if not Is_Controlled (Typ) then
16719 Error_Pragma ("pragma% must specify controlled type");
16722 Check_First_Subtype (Arg1);
16724 if Finalize_Storage_Only (Typ) then
16725 Error_Pragma ("duplicate pragma%, only one allowed");
16727 elsif not Rep_Item_Too_Late (Typ, N) then
16728 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16730 end Finalize_Storage;
16736 -- pragma Ghost [ (boolean_EXPRESSION) ];
16738 when Pragma_Ghost => Ghost : declare
16742 Orig_Stmt : Node_Id;
16743 Prev_Id : Entity_Id;
16748 Check_No_Identifiers;
16749 Check_At_Most_N_Arguments (1);
16753 while Present (Stmt) loop
16755 -- Skip prior pragmas, but check for duplicates
16757 if Nkind (Stmt) = N_Pragma then
16758 if Pragma_Name (Stmt) = Pname then
16765 -- Task unit declared without a definition cannot be subject to
16766 -- pragma Ghost (SPARK RM 6.9(19)).
16768 elsif Nkind (Stmt) in
16769 N_Single_Task_Declaration | N_Task_Type_Declaration
16771 Error_Pragma ("pragma % cannot apply to a task type");
16774 -- Skip internally generated code
16776 elsif not Comes_From_Source (Stmt) then
16777 Orig_Stmt := Original_Node (Stmt);
16779 -- When pragma Ghost applies to an untagged derivation, the
16780 -- derivation is transformed into a [sub]type declaration.
16783 N_Full_Type_Declaration | N_Subtype_Declaration
16784 and then Comes_From_Source (Orig_Stmt)
16785 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16786 and then Nkind (Type_Definition (Orig_Stmt)) =
16787 N_Derived_Type_Definition
16789 Id := Defining_Entity (Stmt);
16792 -- When pragma Ghost applies to an object declaration which
16793 -- is initialized by means of a function call that returns
16794 -- on the secondary stack, the object declaration becomes a
16797 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16798 and then Comes_From_Source (Orig_Stmt)
16799 and then Nkind (Orig_Stmt) = N_Object_Declaration
16801 Id := Defining_Entity (Stmt);
16804 -- When pragma Ghost applies to an expression function, the
16805 -- expression function is transformed into a subprogram.
16807 elsif Nkind (Stmt) = N_Subprogram_Declaration
16808 and then Comes_From_Source (Orig_Stmt)
16809 and then Nkind (Orig_Stmt) = N_Expression_Function
16811 Id := Defining_Entity (Stmt);
16815 -- The pragma applies to a legal construct, stop the traversal
16817 elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
16818 | N_Full_Type_Declaration
16819 | N_Generic_Subprogram_Declaration
16820 | N_Object_Declaration
16821 | N_Private_Extension_Declaration
16822 | N_Private_Type_Declaration
16823 | N_Subprogram_Declaration
16824 | N_Subtype_Declaration
16826 Id := Defining_Entity (Stmt);
16829 -- The pragma does not apply to a legal construct, issue an
16830 -- error and stop the analysis.
16834 ("pragma % must apply to an object, package, subprogram "
16839 Stmt := Prev (Stmt);
16842 Context := Parent (N);
16844 -- Handle compilation units
16846 if Nkind (Context) = N_Compilation_Unit_Aux then
16847 Context := Unit (Parent (Context));
16850 -- Protected and task types cannot be subject to pragma Ghost
16851 -- (SPARK RM 6.9(19)).
16853 if Nkind (Context) in N_Protected_Body | N_Protected_Definition
16855 Error_Pragma ("pragma % cannot apply to a protected type");
16858 elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
16859 Error_Pragma ("pragma % cannot apply to a task type");
16865 -- When pragma Ghost is associated with a [generic] package, it
16866 -- appears in the visible declarations.
16868 if Nkind (Context) = N_Package_Specification
16869 and then Present (Visible_Declarations (Context))
16870 and then List_Containing (N) = Visible_Declarations (Context)
16872 Id := Defining_Entity (Context);
16874 -- Pragma Ghost applies to a stand-alone subprogram body
16876 elsif Nkind (Context) = N_Subprogram_Body
16877 and then No (Corresponding_Spec (Context))
16879 Id := Defining_Entity (Context);
16881 -- Pragma Ghost applies to a subprogram declaration that acts
16882 -- as a compilation unit.
16884 elsif Nkind (Context) = N_Subprogram_Declaration then
16885 Id := Defining_Entity (Context);
16887 -- Pragma Ghost applies to a generic subprogram
16889 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16890 Id := Defining_Entity (Specification (Context));
16896 ("pragma % must apply to an object, package, subprogram or "
16901 -- Handle completions of types and constants that are subject to
16904 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16905 Prev_Id := Incomplete_Or_Partial_View (Id);
16907 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16908 Error_Msg_Name_1 := Pname;
16910 -- The full declaration of a deferred constant cannot be
16911 -- subject to pragma Ghost unless the deferred declaration
16912 -- is also Ghost (SPARK RM 6.9(9)).
16914 if Ekind (Prev_Id) = E_Constant then
16915 Error_Msg_Name_1 := Pname;
16916 Error_Msg_NE (Fix_Error
16917 ("pragma % must apply to declaration of deferred "
16918 & "constant &"), N, Id);
16921 -- Pragma Ghost may appear on the full view of an incomplete
16922 -- type because the incomplete declaration lacks aspects and
16923 -- cannot be subject to pragma Ghost.
16925 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16928 -- The full declaration of a type cannot be subject to
16929 -- pragma Ghost unless the partial view is also Ghost
16930 -- (SPARK RM 6.9(9)).
16933 Error_Msg_NE (Fix_Error
16934 ("pragma % must apply to partial view of type &"),
16940 -- A synchronized object cannot be subject to pragma Ghost
16941 -- (SPARK RM 6.9(19)).
16943 elsif Ekind (Id) = E_Variable then
16944 if Is_Protected_Type (Etype (Id)) then
16945 Error_Pragma ("pragma % cannot apply to a protected object");
16948 elsif Is_Task_Type (Etype (Id)) then
16949 Error_Pragma ("pragma % cannot apply to a task object");
16954 -- Analyze the Boolean expression (if any)
16956 if Present (Arg1) then
16957 Expr := Get_Pragma_Arg (Arg1);
16959 Analyze_And_Resolve (Expr, Standard_Boolean);
16961 if Is_OK_Static_Expression (Expr) then
16963 -- "Ghostness" cannot be turned off once enabled within a
16964 -- region (SPARK RM 6.9(6)).
16966 if Is_False (Expr_Value (Expr))
16967 and then Ghost_Mode > None
16970 ("pragma % with value False cannot appear in enabled "
16975 -- Otherwise the expression is not static
16979 ("expression of pragma % must be static", Expr);
16984 Set_Is_Ghost_Entity (Id);
16991 -- pragma Global (GLOBAL_SPECIFICATION);
16993 -- GLOBAL_SPECIFICATION ::=
16996 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16998 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17000 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17001 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17002 -- GLOBAL_ITEM ::= NAME
17004 -- Characteristics:
17006 -- * Analysis - The annotation undergoes initial checks to verify
17007 -- the legal placement and context. Secondary checks fully analyze
17008 -- the dependency clauses in:
17010 -- Analyze_Global_In_Decl_Part
17012 -- * Expansion - None.
17014 -- * Template - The annotation utilizes the generic template of the
17015 -- related subprogram [body] when it is:
17017 -- aspect on subprogram declaration
17018 -- aspect on stand-alone subprogram body
17019 -- pragma on stand-alone subprogram body
17021 -- The annotation must prepare its own template when it is:
17023 -- pragma on subprogram declaration
17025 -- * Globals - Capture of global references must occur after full
17028 -- * Instance - The annotation is instantiated automatically when
17029 -- the related generic subprogram [body] is instantiated except for
17030 -- the "pragma on subprogram declaration" case. In that scenario
17031 -- the annotation must instantiate itself.
17033 when Pragma_Global => Global : declare
17035 Spec_Id : Entity_Id;
17036 Subp_Decl : Node_Id;
17039 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17043 -- Chain the pragma on the contract for further processing by
17044 -- Analyze_Global_In_Decl_Part.
17046 Add_Contract_Item (N, Spec_Id);
17048 -- Fully analyze the pragma when it appears inside an entry
17049 -- or subprogram body because it cannot benefit from forward
17052 if Nkind (Subp_Decl) in N_Entry_Body
17053 | N_Subprogram_Body
17054 | N_Subprogram_Body_Stub
17056 -- The legality checks of pragmas Depends and Global are
17057 -- affected by the SPARK mode in effect and the volatility
17058 -- of the context. In addition these two pragmas are subject
17059 -- to an inherent order:
17064 -- Analyze all these pragmas in the order outlined above
17066 Analyze_If_Present (Pragma_SPARK_Mode);
17067 Analyze_If_Present (Pragma_Volatile_Function);
17068 Analyze_Global_In_Decl_Part (N);
17069 Analyze_If_Present (Pragma_Depends);
17078 -- pragma Ident (static_string_EXPRESSION)
17080 -- Note: pragma Comment shares this processing. Pragma Ident is
17081 -- identical in effect to pragma Commment.
17083 when Pragma_Comment
17091 Check_Arg_Count (1);
17092 Check_No_Identifiers;
17093 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17096 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17103 GP := Parent (Parent (N));
17106 N_Package_Declaration | N_Generic_Package_Declaration
17111 -- If we have a compilation unit, then record the ident value,
17112 -- checking for improper duplication.
17114 if Nkind (GP) = N_Compilation_Unit then
17115 CS := Ident_String (Current_Sem_Unit);
17117 if Present (CS) then
17119 -- If we have multiple instances, concatenate them.
17121 Start_String (Strval (CS));
17122 Store_String_Char (' ');
17123 Store_String_Chars (Strval (Str));
17124 Set_Strval (CS, End_String);
17127 Set_Ident_String (Current_Sem_Unit, Str);
17130 -- For subunits, we just ignore the Ident, since in GNAT these
17131 -- are not separate object files, and hence not separate units
17132 -- in the unit table.
17134 elsif Nkind (GP) = N_Subunit then
17140 -------------------
17141 -- Ignore_Pragma --
17142 -------------------
17144 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17146 -- Entirely handled in the parser, nothing to do here
17148 when Pragma_Ignore_Pragma =>
17151 ----------------------------
17152 -- Implementation_Defined --
17153 ----------------------------
17155 -- pragma Implementation_Defined (LOCAL_NAME);
17157 -- Marks previously declared entity as implementation defined. For
17158 -- an overloaded entity, applies to the most recent homonym.
17160 -- pragma Implementation_Defined;
17162 -- The form with no arguments appears anywhere within a scope, most
17163 -- typically a package spec, and indicates that all entities that are
17164 -- defined within the package spec are Implementation_Defined.
17166 when Pragma_Implementation_Defined => Implementation_Defined : declare
17171 Check_No_Identifiers;
17173 -- Form with no arguments
17175 if Arg_Count = 0 then
17176 Set_Is_Implementation_Defined (Current_Scope);
17178 -- Form with one argument
17181 Check_Arg_Count (1);
17182 Check_Arg_Is_Local_Name (Arg1);
17183 Ent := Entity (Get_Pragma_Arg (Arg1));
17184 Set_Is_Implementation_Defined (Ent);
17186 end Implementation_Defined;
17192 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17194 -- IMPLEMENTATION_KIND ::=
17195 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17197 -- "By_Any" and "Optional" are treated as synonyms in order to
17198 -- support Ada 2012 aspect Synchronization.
17200 when Pragma_Implemented => Implemented : declare
17201 Proc_Id : Entity_Id;
17206 Check_Arg_Count (2);
17207 Check_No_Identifiers;
17208 Check_Arg_Is_Identifier (Arg1);
17209 Check_Arg_Is_Local_Name (Arg1);
17210 Check_Arg_Is_One_Of (Arg2,
17213 Name_By_Protected_Procedure,
17216 -- Extract the name of the local procedure
17218 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17220 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17221 -- primitive procedure of a synchronized tagged type.
17223 if Ekind (Proc_Id) = E_Procedure
17224 and then Is_Primitive (Proc_Id)
17225 and then Present (First_Formal (Proc_Id))
17227 Typ := Etype (First_Formal (Proc_Id));
17229 if Is_Tagged_Type (Typ)
17232 -- Check for a protected, a synchronized or a task interface
17234 ((Is_Interface (Typ)
17235 and then Is_Synchronized_Interface (Typ))
17237 -- Check for a protected type or a task type that implements
17241 (Is_Concurrent_Record_Type (Typ)
17242 and then Present (Interfaces (Typ)))
17244 -- In analysis-only mode, examine original protected type
17247 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17248 and then Present (Interface_List (Parent (Typ))))
17250 -- Check for a private record extension with keyword
17254 (Ekind (Typ) in E_Record_Type_With_Private
17255 | E_Record_Subtype_With_Private
17256 and then Synchronized_Present (Parent (Typ))))
17261 ("controlling formal must be of synchronized tagged type",
17266 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17267 -- By_Protected_Procedure to the primitive procedure of a task
17270 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17271 and then Is_Interface (Typ)
17272 and then Is_Task_Interface (Typ)
17275 ("implementation kind By_Protected_Procedure cannot be "
17276 & "applied to a task interface primitive", Arg2);
17280 -- Procedures declared inside a protected type must be accepted
17282 elsif Ekind (Proc_Id) = E_Procedure
17283 and then Is_Protected_Type (Scope (Proc_Id))
17287 -- The first argument is not a primitive procedure
17291 ("pragma % must be applied to a primitive procedure", Arg1);
17295 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17296 -- By_Protected_Procedure to a procedure that has aspect Yield
17298 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17299 and then Has_Yield_Aspect (Proc_Id)
17302 ("implementation kind By_Protected_Procedure cannot be "
17303 & "applied to entities with aspect 'Yield", Arg2);
17307 Record_Rep_Item (Proc_Id, N);
17310 ----------------------
17311 -- Implicit_Packing --
17312 ----------------------
17314 -- pragma Implicit_Packing;
17316 when Pragma_Implicit_Packing =>
17318 Check_Arg_Count (0);
17319 Implicit_Packing := True;
17326 -- [Convention =>] convention_IDENTIFIER,
17327 -- [Entity =>] LOCAL_NAME
17328 -- [, [External_Name =>] static_string_EXPRESSION ]
17329 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17331 when Pragma_Import =>
17332 Check_Ada_83_Warning;
17336 Name_External_Name,
17339 Check_At_Least_N_Arguments (2);
17340 Check_At_Most_N_Arguments (4);
17341 Process_Import_Or_Interface;
17343 ---------------------
17344 -- Import_Function --
17345 ---------------------
17347 -- pragma Import_Function (
17348 -- [Internal =>] LOCAL_NAME,
17349 -- [, [External =>] EXTERNAL_SYMBOL]
17350 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17351 -- [, [Result_Type =>] SUBTYPE_MARK]
17352 -- [, [Mechanism =>] MECHANISM]
17353 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17355 -- EXTERNAL_SYMBOL ::=
17357 -- | static_string_EXPRESSION
17359 -- PARAMETER_TYPES ::=
17361 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17363 -- TYPE_DESIGNATOR ::=
17365 -- | subtype_Name ' Access
17369 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17371 -- MECHANISM_ASSOCIATION ::=
17372 -- [formal_parameter_NAME =>] MECHANISM_NAME
17374 -- MECHANISM_NAME ::=
17378 when Pragma_Import_Function => Import_Function : declare
17379 Args : Args_List (1 .. 6);
17380 Names : constant Name_List (1 .. 6) := (
17383 Name_Parameter_Types,
17386 Name_Result_Mechanism);
17388 Internal : Node_Id renames Args (1);
17389 External : Node_Id renames Args (2);
17390 Parameter_Types : Node_Id renames Args (3);
17391 Result_Type : Node_Id renames Args (4);
17392 Mechanism : Node_Id renames Args (5);
17393 Result_Mechanism : Node_Id renames Args (6);
17397 Gather_Associations (Names, Args);
17398 Process_Extended_Import_Export_Subprogram_Pragma (
17399 Arg_Internal => Internal,
17400 Arg_External => External,
17401 Arg_Parameter_Types => Parameter_Types,
17402 Arg_Result_Type => Result_Type,
17403 Arg_Mechanism => Mechanism,
17404 Arg_Result_Mechanism => Result_Mechanism);
17405 end Import_Function;
17407 -------------------
17408 -- Import_Object --
17409 -------------------
17411 -- pragma Import_Object (
17412 -- [Internal =>] LOCAL_NAME
17413 -- [, [External =>] EXTERNAL_SYMBOL]
17414 -- [, [Size =>] EXTERNAL_SYMBOL]);
17416 -- EXTERNAL_SYMBOL ::=
17418 -- | static_string_EXPRESSION
17420 when Pragma_Import_Object => Import_Object : declare
17421 Args : Args_List (1 .. 3);
17422 Names : constant Name_List (1 .. 3) := (
17427 Internal : Node_Id renames Args (1);
17428 External : Node_Id renames Args (2);
17429 Size : Node_Id renames Args (3);
17433 Gather_Associations (Names, Args);
17434 Process_Extended_Import_Export_Object_Pragma (
17435 Arg_Internal => Internal,
17436 Arg_External => External,
17440 ----------------------
17441 -- Import_Procedure --
17442 ----------------------
17444 -- pragma Import_Procedure (
17445 -- [Internal =>] LOCAL_NAME
17446 -- [, [External =>] EXTERNAL_SYMBOL]
17447 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17448 -- [, [Mechanism =>] MECHANISM]);
17450 -- EXTERNAL_SYMBOL ::=
17452 -- | static_string_EXPRESSION
17454 -- PARAMETER_TYPES ::=
17456 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17458 -- TYPE_DESIGNATOR ::=
17460 -- | subtype_Name ' Access
17464 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17466 -- MECHANISM_ASSOCIATION ::=
17467 -- [formal_parameter_NAME =>] MECHANISM_NAME
17469 -- MECHANISM_NAME ::=
17473 when Pragma_Import_Procedure => Import_Procedure : declare
17474 Args : Args_List (1 .. 4);
17475 Names : constant Name_List (1 .. 4) := (
17478 Name_Parameter_Types,
17481 Internal : Node_Id renames Args (1);
17482 External : Node_Id renames Args (2);
17483 Parameter_Types : Node_Id renames Args (3);
17484 Mechanism : Node_Id renames Args (4);
17488 Gather_Associations (Names, Args);
17489 Process_Extended_Import_Export_Subprogram_Pragma (
17490 Arg_Internal => Internal,
17491 Arg_External => External,
17492 Arg_Parameter_Types => Parameter_Types,
17493 Arg_Mechanism => Mechanism);
17494 end Import_Procedure;
17496 -----------------------------
17497 -- Import_Valued_Procedure --
17498 -----------------------------
17500 -- pragma Import_Valued_Procedure (
17501 -- [Internal =>] LOCAL_NAME
17502 -- [, [External =>] EXTERNAL_SYMBOL]
17503 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17504 -- [, [Mechanism =>] MECHANISM]);
17506 -- EXTERNAL_SYMBOL ::=
17508 -- | static_string_EXPRESSION
17510 -- PARAMETER_TYPES ::=
17512 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17514 -- TYPE_DESIGNATOR ::=
17516 -- | subtype_Name ' Access
17520 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17522 -- MECHANISM_ASSOCIATION ::=
17523 -- [formal_parameter_NAME =>] MECHANISM_NAME
17525 -- MECHANISM_NAME ::=
17529 when Pragma_Import_Valued_Procedure =>
17530 Import_Valued_Procedure : declare
17531 Args : Args_List (1 .. 4);
17532 Names : constant Name_List (1 .. 4) := (
17535 Name_Parameter_Types,
17538 Internal : Node_Id renames Args (1);
17539 External : Node_Id renames Args (2);
17540 Parameter_Types : Node_Id renames Args (3);
17541 Mechanism : Node_Id renames Args (4);
17545 Gather_Associations (Names, Args);
17546 Process_Extended_Import_Export_Subprogram_Pragma (
17547 Arg_Internal => Internal,
17548 Arg_External => External,
17549 Arg_Parameter_Types => Parameter_Types,
17550 Arg_Mechanism => Mechanism);
17551 end Import_Valued_Procedure;
17557 -- pragma Independent (LOCAL_NAME);
17559 when Pragma_Independent =>
17560 Process_Atomic_Independent_Shared_Volatile;
17562 ----------------------------
17563 -- Independent_Components --
17564 ----------------------------
17566 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17568 when Pragma_Independent_Components => Independent_Components : declare
17575 Check_Ada_83_Warning;
17577 Check_No_Identifiers;
17578 Check_Arg_Count (1);
17579 Check_Arg_Is_Local_Name (Arg1);
17580 E_Id := Get_Pragma_Arg (Arg1);
17582 if Etype (E_Id) = Any_Type then
17586 E := Entity (E_Id);
17588 -- A record type with a self-referential component of anonymous
17589 -- access type is given an incomplete view in order to handle the
17592 -- type Rec is record
17593 -- Self : access Rec;
17599 -- type Ptr is access Rec;
17600 -- type Rec is record
17604 -- Since the incomplete view is now the initial view of the type,
17605 -- the argument of the pragma will reference the incomplete view,
17606 -- but this view is illegal according to the semantics of the
17609 -- Obtain the full view of an internally-generated incomplete type
17610 -- only. This way an attempt to associate the pragma with a source
17611 -- incomplete type is still caught.
17613 if Ekind (E) = E_Incomplete_Type
17614 and then not Comes_From_Source (E)
17615 and then Present (Full_View (E))
17617 E := Full_View (E);
17620 -- A pragma that applies to a Ghost entity becomes Ghost for the
17621 -- purposes of legality checks and removal of ignored Ghost code.
17623 Mark_Ghost_Pragma (N, E);
17625 -- Check duplicate before we chain ourselves
17627 Check_Duplicate_Pragma (E);
17629 -- Check appropriate entity
17631 if Rep_Item_Too_Early (E, N)
17633 Rep_Item_Too_Late (E, N)
17638 D := Declaration_Node (E);
17640 -- The flag is set on the base type, or on the object
17642 if Nkind (D) = N_Full_Type_Declaration
17643 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17645 Set_Has_Independent_Components (Base_Type (E));
17646 Record_Independence_Check (N, Base_Type (E));
17648 -- For record type, set all components independent
17650 if Is_Record_Type (E) then
17651 C := First_Component (E);
17652 while Present (C) loop
17653 Set_Is_Independent (C);
17654 Next_Component (C);
17658 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17659 and then Nkind (D) = N_Object_Declaration
17660 and then Nkind (Object_Definition (D)) =
17661 N_Constrained_Array_Definition
17663 Set_Has_Independent_Components (E);
17664 Record_Independence_Check (N, E);
17667 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17669 end Independent_Components;
17671 -----------------------
17672 -- Initial_Condition --
17673 -----------------------
17675 -- pragma Initial_Condition (boolean_EXPRESSION);
17677 -- Characteristics:
17679 -- * Analysis - The annotation undergoes initial checks to verify
17680 -- the legal placement and context. Secondary checks preanalyze the
17683 -- Analyze_Initial_Condition_In_Decl_Part
17685 -- * Expansion - The annotation is expanded during the expansion of
17686 -- the package body whose declaration is subject to the annotation
17689 -- Expand_Pragma_Initial_Condition
17691 -- * Template - The annotation utilizes the generic template of the
17692 -- related package declaration.
17694 -- * Globals - Capture of global references must occur after full
17697 -- * Instance - The annotation is instantiated automatically when
17698 -- the related generic package is instantiated.
17700 when Pragma_Initial_Condition => Initial_Condition : declare
17701 Pack_Decl : Node_Id;
17702 Pack_Id : Entity_Id;
17706 Check_No_Identifiers;
17707 Check_Arg_Count (1);
17709 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17711 if Nkind (Pack_Decl) not in
17712 N_Generic_Package_Declaration | N_Package_Declaration
17718 Pack_Id := Defining_Entity (Pack_Decl);
17720 -- A pragma that applies to a Ghost entity becomes Ghost for the
17721 -- purposes of legality checks and removal of ignored Ghost code.
17723 Mark_Ghost_Pragma (N, Pack_Id);
17725 -- Chain the pragma on the contract for further processing by
17726 -- Analyze_Initial_Condition_In_Decl_Part.
17728 Add_Contract_Item (N, Pack_Id);
17730 -- The legality checks of pragmas Abstract_State, Initializes, and
17731 -- Initial_Condition are affected by the SPARK mode in effect. In
17732 -- addition, these three pragmas are subject to an inherent order:
17734 -- 1) Abstract_State
17736 -- 3) Initial_Condition
17738 -- Analyze all these pragmas in the order outlined above
17740 Analyze_If_Present (Pragma_SPARK_Mode);
17741 Analyze_If_Present (Pragma_Abstract_State);
17742 Analyze_If_Present (Pragma_Initializes);
17743 end Initial_Condition;
17745 ------------------------
17746 -- Initialize_Scalars --
17747 ------------------------
17749 -- pragma Initialize_Scalars
17750 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17752 -- TYPE_VALUE_PAIR ::=
17753 -- SCALAR_TYPE => static_EXPRESSION
17759 -- | Long_Long_Float
17771 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17772 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17773 -- This collection holds the individual pairs which specify the
17774 -- invalid values of their respective scalar types.
17776 procedure Analyze_Float_Value
17777 (Scal_Typ : Float_Scalar_Id;
17778 Val_Expr : Node_Id);
17779 -- Analyze a type value pair associated with float type Scal_Typ
17780 -- and expression Val_Expr.
17782 procedure Analyze_Integer_Value
17783 (Scal_Typ : Integer_Scalar_Id;
17784 Val_Expr : Node_Id);
17785 -- Analyze a type value pair associated with integer type Scal_Typ
17786 -- and expression Val_Expr.
17788 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17789 -- Analyze type value pair Pair
17791 -------------------------
17792 -- Analyze_Float_Value --
17793 -------------------------
17795 procedure Analyze_Float_Value
17796 (Scal_Typ : Float_Scalar_Id;
17797 Val_Expr : Node_Id)
17800 Analyze_And_Resolve (Val_Expr, Any_Real);
17802 if Is_OK_Static_Expression (Val_Expr) then
17803 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17806 Error_Msg_Name_1 := Scal_Typ;
17807 Error_Msg_N ("value for type % must be static", Val_Expr);
17809 end Analyze_Float_Value;
17811 ---------------------------
17812 -- Analyze_Integer_Value --
17813 ---------------------------
17815 procedure Analyze_Integer_Value
17816 (Scal_Typ : Integer_Scalar_Id;
17817 Val_Expr : Node_Id)
17820 Analyze_And_Resolve (Val_Expr, Any_Integer);
17822 if (Scal_Typ = Name_Signed_128
17823 or else Scal_Typ = Name_Unsigned_128)
17824 and then Ttypes.System_Max_Integer_Size < 128
17826 Error_Msg_Name_1 := Scal_Typ;
17827 Error_Msg_N ("value cannot be set for type %", Val_Expr);
17829 elsif Is_OK_Static_Expression (Val_Expr) then
17830 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17833 Error_Msg_Name_1 := Scal_Typ;
17834 Error_Msg_N ("value for type % must be static", Val_Expr);
17836 end Analyze_Integer_Value;
17838 -----------------------------
17839 -- Analyze_Type_Value_Pair --
17840 -----------------------------
17842 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17843 Scal_Typ : constant Name_Id := Chars (Pair);
17844 Val_Expr : constant Node_Id := Expression (Pair);
17845 Prev_Pair : Node_Id;
17848 if Scal_Typ in Scalar_Id then
17849 Prev_Pair := Seen (Scal_Typ);
17851 -- Prevent multiple attempts to set a value for a scalar
17854 if Present (Prev_Pair) then
17855 Error_Msg_Name_1 := Scal_Typ;
17857 ("cannot specify multiple invalid values for type %",
17860 Error_Msg_Sloc := Sloc (Prev_Pair);
17861 Error_Msg_N ("previous value set #", Pair);
17863 -- Ignore the effects of the pair, but do not halt the
17864 -- analysis of the pragma altogether.
17868 -- Otherwise capture the first pair for this scalar type
17871 Seen (Scal_Typ) := Pair;
17874 if Scal_Typ in Float_Scalar_Id then
17875 Analyze_Float_Value (Scal_Typ, Val_Expr);
17877 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17878 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17881 -- Otherwise the scalar family is illegal
17884 Error_Msg_Name_1 := Pname;
17886 ("argument of pragma % must denote valid scalar family",
17889 end Analyze_Type_Value_Pair;
17893 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17896 -- Start of processing for Do_Initialize_Scalars
17900 Check_Valid_Configuration_Pragma;
17901 Check_Restriction (No_Initialize_Scalars, N);
17903 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17906 if Restriction_Active (No_Initialize_Scalars) then
17909 -- Initialize_Scalars creates false positives in CodePeer, and
17910 -- incorrect negative results in GNATprove mode, so ignore this
17911 -- pragma in these modes.
17913 elsif CodePeer_Mode or GNATprove_Mode then
17916 -- Otherwise analyze the pragma
17919 if Present (Pairs) then
17921 -- Install Standard in order to provide access to primitive
17922 -- types in case the expressions contain attributes such as
17925 Push_Scope (Standard_Standard);
17927 Pair := First (Pairs);
17928 while Present (Pair) loop
17929 Analyze_Type_Value_Pair (Pair);
17938 Init_Or_Norm_Scalars := True;
17939 Initialize_Scalars := True;
17941 end Do_Initialize_Scalars;
17947 -- pragma Initializes (INITIALIZATION_LIST);
17949 -- INITIALIZATION_LIST ::=
17951 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17953 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17958 -- | (INPUT {, INPUT})
17962 -- Characteristics:
17964 -- * Analysis - The annotation undergoes initial checks to verify
17965 -- the legal placement and context. Secondary checks preanalyze the
17968 -- Analyze_Initializes_In_Decl_Part
17970 -- * Expansion - None.
17972 -- * Template - The annotation utilizes the generic template of the
17973 -- related package declaration.
17975 -- * Globals - Capture of global references must occur after full
17978 -- * Instance - The annotation is instantiated automatically when
17979 -- the related generic package is instantiated.
17981 when Pragma_Initializes => Initializes : declare
17982 Pack_Decl : Node_Id;
17983 Pack_Id : Entity_Id;
17987 Check_No_Identifiers;
17988 Check_Arg_Count (1);
17990 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17992 if Nkind (Pack_Decl) not in
17993 N_Generic_Package_Declaration | N_Package_Declaration
17999 Pack_Id := Defining_Entity (Pack_Decl);
18001 -- A pragma that applies to a Ghost entity becomes Ghost for the
18002 -- purposes of legality checks and removal of ignored Ghost code.
18004 Mark_Ghost_Pragma (N, Pack_Id);
18005 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18007 -- Chain the pragma on the contract for further processing by
18008 -- Analyze_Initializes_In_Decl_Part.
18010 Add_Contract_Item (N, Pack_Id);
18012 -- The legality checks of pragmas Abstract_State, Initializes, and
18013 -- Initial_Condition are affected by the SPARK mode in effect. In
18014 -- addition, these three pragmas are subject to an inherent order:
18016 -- 1) Abstract_State
18018 -- 3) Initial_Condition
18020 -- Analyze all these pragmas in the order outlined above
18022 Analyze_If_Present (Pragma_SPARK_Mode);
18023 Analyze_If_Present (Pragma_Abstract_State);
18024 Analyze_If_Present (Pragma_Initial_Condition);
18031 -- pragma Inline ( NAME {, NAME} );
18033 when Pragma_Inline =>
18035 -- Pragma always active unless in GNATprove mode. It is disabled
18036 -- in GNATprove mode because frontend inlining is applied
18037 -- independently of pragmas Inline and Inline_Always for
18038 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18041 if not GNATprove_Mode then
18043 -- Inline status is Enabled if option -gnatn is specified.
18044 -- However this status determines only the value of the
18045 -- Is_Inlined flag on the subprogram and does not prevent
18046 -- the pragma itself from being recorded for later use,
18047 -- in particular for a later modification of Is_Inlined
18048 -- independently of the -gnatn option.
18050 -- In other words, if -gnatn is specified for a unit, then
18051 -- all Inline pragmas processed for the compilation of this
18052 -- unit, including those in the spec of other units, are
18053 -- activated, so subprograms will be inlined across units.
18055 -- If -gnatn is not specified, no Inline pragma is activated
18056 -- here, which means that subprograms will not be inlined
18057 -- across units. The Is_Inlined flag will nevertheless be
18058 -- set later when bodies are analyzed, so subprograms will
18059 -- be inlined within the unit.
18061 if Inline_Active then
18062 Process_Inline (Enabled);
18064 Process_Inline (Disabled);
18068 -------------------
18069 -- Inline_Always --
18070 -------------------
18072 -- pragma Inline_Always ( NAME {, NAME} );
18074 when Pragma_Inline_Always =>
18077 -- Pragma always active unless in CodePeer mode or GNATprove
18078 -- mode. It is disabled in CodePeer mode because inlining is
18079 -- not helpful, and enabling it caused walk order issues. It
18080 -- is disabled in GNATprove mode because frontend inlining is
18081 -- applied independently of pragmas Inline and Inline_Always for
18082 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18085 if not CodePeer_Mode and not GNATprove_Mode then
18086 Process_Inline (Enabled);
18089 --------------------
18090 -- Inline_Generic --
18091 --------------------
18093 -- pragma Inline_Generic (NAME {, NAME});
18095 when Pragma_Inline_Generic =>
18097 Process_Generic_List;
18099 ----------------------
18100 -- Inspection_Point --
18101 ----------------------
18103 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18105 when Pragma_Inspection_Point => Inspection_Point : declare
18112 if Arg_Count > 0 then
18115 Exp := Get_Pragma_Arg (Arg);
18118 if not Is_Entity_Name (Exp)
18119 or else not Is_Object (Entity (Exp))
18121 Error_Pragma_Arg ("object name required", Arg);
18125 exit when No (Arg);
18128 end Inspection_Point;
18134 -- pragma Interface (
18135 -- [ Convention =>] convention_IDENTIFIER,
18136 -- [ Entity =>] LOCAL_NAME
18137 -- [, [External_Name =>] static_string_EXPRESSION ]
18138 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18140 when Pragma_Interface =>
18145 Name_External_Name,
18147 Check_At_Least_N_Arguments (2);
18148 Check_At_Most_N_Arguments (4);
18149 Process_Import_Or_Interface;
18151 -- In Ada 2005, the permission to use Interface (a reserved word)
18152 -- as a pragma name is considered an obsolescent feature, and this
18153 -- pragma was already obsolescent in Ada 95.
18155 if Ada_Version >= Ada_95 then
18157 (No_Obsolescent_Features, Pragma_Identifier (N));
18159 if Warn_On_Obsolescent_Feature then
18161 ("pragma Interface is an obsolescent feature?j?", N);
18163 ("|use pragma Import instead?j?", N);
18167 --------------------
18168 -- Interface_Name --
18169 --------------------
18171 -- pragma Interface_Name (
18172 -- [ Entity =>] LOCAL_NAME
18173 -- [,[External_Name =>] static_string_EXPRESSION ]
18174 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18176 when Pragma_Interface_Name => Interface_Name : declare
18178 Def_Id : Entity_Id;
18179 Hom_Id : Entity_Id;
18185 ((Name_Entity, Name_External_Name, Name_Link_Name));
18186 Check_At_Least_N_Arguments (2);
18187 Check_At_Most_N_Arguments (3);
18188 Id := Get_Pragma_Arg (Arg1);
18191 -- This is obsolete from Ada 95 on, but it is an implementation
18192 -- defined pragma, so we do not consider that it violates the
18193 -- restriction (No_Obsolescent_Features).
18195 if Ada_Version >= Ada_95 then
18196 if Warn_On_Obsolescent_Feature then
18198 ("pragma Interface_Name is an obsolescent feature?j?", N);
18200 ("|use pragma Import instead?j?", N);
18204 if not Is_Entity_Name (Id) then
18206 ("first argument for pragma% must be entity name", Arg1);
18207 elsif Etype (Id) = Any_Type then
18210 Def_Id := Entity (Id);
18213 -- Special DEC-compatible processing for the object case, forces
18214 -- object to be imported.
18216 if Ekind (Def_Id) = E_Variable then
18217 Kill_Size_Check_Code (Def_Id);
18218 Note_Possible_Modification (Id, Sure => False);
18220 -- Initialization is not allowed for imported variable
18222 if Present (Expression (Parent (Def_Id)))
18223 and then Comes_From_Source (Expression (Parent (Def_Id)))
18225 Error_Msg_Sloc := Sloc (Def_Id);
18227 ("no initialization allowed for declaration of& #",
18231 -- For compatibility, support VADS usage of providing both
18232 -- pragmas Interface and Interface_Name to obtain the effect
18233 -- of a single Import pragma.
18235 if Is_Imported (Def_Id)
18236 and then Present (First_Rep_Item (Def_Id))
18237 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18238 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18243 Set_Imported (Def_Id);
18246 Set_Is_Public (Def_Id);
18247 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18250 -- Otherwise must be subprogram
18252 elsif not Is_Subprogram (Def_Id) then
18254 ("argument of pragma% is not subprogram", Arg1);
18257 Check_At_Most_N_Arguments (3);
18261 -- Loop through homonyms
18264 Def_Id := Get_Base_Subprogram (Hom_Id);
18266 if Is_Imported (Def_Id) then
18267 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18271 exit when From_Aspect_Specification (N);
18272 Hom_Id := Homonym (Hom_Id);
18274 exit when No (Hom_Id)
18275 or else Scope (Hom_Id) /= Current_Scope;
18280 ("argument of pragma% is not imported subprogram",
18284 end Interface_Name;
18286 -----------------------
18287 -- Interrupt_Handler --
18288 -----------------------
18290 -- pragma Interrupt_Handler (handler_NAME);
18292 when Pragma_Interrupt_Handler =>
18293 Check_Ada_83_Warning;
18294 Check_Arg_Count (1);
18295 Check_No_Identifiers;
18297 if No_Run_Time_Mode then
18298 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18300 Check_Interrupt_Or_Attach_Handler;
18301 Process_Interrupt_Or_Attach_Handler;
18304 ------------------------
18305 -- Interrupt_Priority --
18306 ------------------------
18308 -- pragma Interrupt_Priority [(EXPRESSION)];
18310 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18311 P : constant Node_Id := Parent (N);
18316 Check_Ada_83_Warning;
18318 if Arg_Count /= 0 then
18319 Arg := Get_Pragma_Arg (Arg1);
18320 Check_Arg_Count (1);
18321 Check_No_Identifiers;
18323 -- The expression must be analyzed in the special manner
18324 -- described in "Handling of Default and Per-Object
18325 -- Expressions" in sem.ads.
18327 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18330 if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
18335 Ent := Defining_Identifier (Parent (P));
18337 -- Check duplicate pragma before we chain the pragma in the Rep
18338 -- Item chain of Ent.
18340 Check_Duplicate_Pragma (Ent);
18341 Record_Rep_Item (Ent, N);
18343 -- Check the No_Task_At_Interrupt_Priority restriction
18345 if Nkind (P) = N_Task_Definition then
18346 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18349 end Interrupt_Priority;
18351 ---------------------
18352 -- Interrupt_State --
18353 ---------------------
18355 -- pragma Interrupt_State (
18356 -- [Name =>] INTERRUPT_ID,
18357 -- [State =>] INTERRUPT_STATE);
18359 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18360 -- INTERRUPT_STATE => System | Runtime | User
18362 -- Note: if the interrupt id is given as an identifier, then it must
18363 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18364 -- given as a static integer expression which must be in the range of
18365 -- Ada.Interrupts.Interrupt_ID.
18367 when Pragma_Interrupt_State => Interrupt_State : declare
18368 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18369 -- This is the entity Ada.Interrupts.Interrupt_ID;
18371 State_Type : Character;
18372 -- Set to 's'/'r'/'u' for System/Runtime/User
18375 -- Index to entry in Interrupt_States table
18378 -- Value of interrupt
18380 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18381 -- The first argument to the pragma
18383 Int_Ent : Entity_Id;
18384 -- Interrupt entity in Ada.Interrupts.Names
18388 Check_Arg_Order ((Name_Name, Name_State));
18389 Check_Arg_Count (2);
18391 Check_Optional_Identifier (Arg1, Name_Name);
18392 Check_Optional_Identifier (Arg2, Name_State);
18393 Check_Arg_Is_Identifier (Arg2);
18395 -- First argument is identifier
18397 if Nkind (Arg1X) = N_Identifier then
18399 -- Search list of names in Ada.Interrupts.Names
18401 Int_Ent := First_Entity (RTE (RE_Names));
18403 if No (Int_Ent) then
18404 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18406 elsif Chars (Int_Ent) = Chars (Arg1X) then
18407 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18411 Next_Entity (Int_Ent);
18414 -- First argument is not an identifier, so it must be a static
18415 -- expression of type Ada.Interrupts.Interrupt_ID.
18418 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18419 Int_Val := Expr_Value (Arg1X);
18421 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18423 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18426 ("value not in range of type "
18427 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18433 case Chars (Get_Pragma_Arg (Arg2)) is
18434 when Name_Runtime => State_Type := 'r';
18435 when Name_System => State_Type := 's';
18436 when Name_User => State_Type := 'u';
18439 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18442 -- Check if entry is already stored
18444 IST_Num := Interrupt_States.First;
18446 -- If entry not found, add it
18448 if IST_Num > Interrupt_States.Last then
18449 Interrupt_States.Append
18450 ((Interrupt_Number => UI_To_Int (Int_Val),
18451 Interrupt_State => State_Type,
18452 Pragma_Loc => Loc));
18455 -- Case of entry for the same entry
18457 elsif Int_Val = Interrupt_States.Table (IST_Num).
18460 -- If state matches, done, no need to make redundant entry
18463 State_Type = Interrupt_States.Table (IST_Num).
18466 -- Otherwise if state does not match, error
18469 Interrupt_States.Table (IST_Num).Pragma_Loc;
18471 ("state conflicts with that given #", Arg2);
18475 IST_Num := IST_Num + 1;
18477 end Interrupt_State;
18483 -- pragma Invariant
18484 -- ([Entity =>] type_LOCAL_NAME,
18485 -- [Check =>] EXPRESSION
18486 -- [,[Message =>] String_Expression]);
18488 when Pragma_Invariant => Invariant : declare
18495 Check_At_Least_N_Arguments (2);
18496 Check_At_Most_N_Arguments (3);
18497 Check_Optional_Identifier (Arg1, Name_Entity);
18498 Check_Optional_Identifier (Arg2, Name_Check);
18500 if Arg_Count = 3 then
18501 Check_Optional_Identifier (Arg3, Name_Message);
18502 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18505 Check_Arg_Is_Local_Name (Arg1);
18507 Typ_Arg := Get_Pragma_Arg (Arg1);
18508 Find_Type (Typ_Arg);
18509 Typ := Entity (Typ_Arg);
18511 -- Nothing to do of the related type is erroneous in some way
18513 if Typ = Any_Type then
18516 -- AI12-0041: Invariants are allowed in interface types
18518 elsif Is_Interface (Typ) then
18521 -- An invariant must apply to a private type, or appear in the
18522 -- private part of a package spec and apply to a completion.
18523 -- a class-wide invariant can only appear on a private declaration
18524 -- or private extension, not a completion.
18526 -- A [class-wide] invariant may be associated a [limited] private
18527 -- type or a private extension.
18529 elsif Ekind (Typ) in E_Limited_Private_Type
18531 | E_Record_Type_With_Private
18535 -- A non-class-wide invariant may be associated with the full view
18536 -- of a [limited] private type or a private extension.
18538 elsif Has_Private_Declaration (Typ)
18539 and then not Class_Present (N)
18543 -- A class-wide invariant may appear on the partial view only
18545 elsif Class_Present (N) then
18547 ("pragma % only allowed for private type", Arg1);
18550 -- A regular invariant may appear on both views
18554 ("pragma % only allowed for private type or corresponding "
18555 & "full view", Arg1);
18559 -- An invariant associated with an abstract type (this includes
18560 -- interfaces) must be class-wide.
18562 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18564 ("pragma % not allowed for abstract type", Arg1);
18568 -- A pragma that applies to a Ghost entity becomes Ghost for the
18569 -- purposes of legality checks and removal of ignored Ghost code.
18571 Mark_Ghost_Pragma (N, Typ);
18573 -- The pragma defines a type-specific invariant, the type is said
18574 -- to have invariants of its "own".
18576 Set_Has_Own_Invariants (Base_Type (Typ));
18578 -- If the invariant is class-wide, then it can be inherited by
18579 -- derived or interface implementing types. The type is said to
18580 -- have "inheritable" invariants.
18582 if Class_Present (N) then
18583 Set_Has_Inheritable_Invariants (Typ);
18586 -- Chain the pragma on to the rep item chain, for processing when
18587 -- the type is frozen.
18589 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18591 -- Create the declaration of the invariant procedure that will
18592 -- verify the invariant at run time. Interfaces are treated as the
18593 -- partial view of a private type in order to achieve uniformity
18594 -- with the general case. As a result, an interface receives only
18595 -- a "partial" invariant procedure, which is never called.
18597 Build_Invariant_Procedure_Declaration
18599 Partial_Invariant => Is_Interface (Typ));
18606 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18608 when Pragma_Keep_Names => Keep_Names : declare
18613 Check_Arg_Count (1);
18614 Check_Optional_Identifier (Arg1, Name_On);
18615 Check_Arg_Is_Local_Name (Arg1);
18617 Arg := Get_Pragma_Arg (Arg1);
18620 if Etype (Arg) = Any_Type then
18624 if not Is_Entity_Name (Arg)
18625 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18628 ("pragma% requires a local enumeration type", Arg1);
18631 Set_Discard_Names (Entity (Arg), False);
18638 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18640 when Pragma_License =>
18643 -- Do not analyze pragma any further in CodePeer mode, to avoid
18644 -- extraneous errors in this implementation-dependent pragma,
18645 -- which has a different profile on other compilers.
18647 if CodePeer_Mode then
18651 Check_Arg_Count (1);
18652 Check_No_Identifiers;
18653 Check_Valid_Configuration_Pragma;
18654 Check_Arg_Is_Identifier (Arg1);
18657 Sind : constant Source_File_Index :=
18658 Source_Index (Current_Sem_Unit);
18661 case Chars (Get_Pragma_Arg (Arg1)) is
18663 Set_License (Sind, GPL);
18665 when Name_Modified_GPL =>
18666 Set_License (Sind, Modified_GPL);
18668 when Name_Restricted =>
18669 Set_License (Sind, Restricted);
18671 when Name_Unrestricted =>
18672 Set_License (Sind, Unrestricted);
18675 Error_Pragma_Arg ("invalid license name", Arg1);
18683 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18685 when Pragma_Link_With => Link_With : declare
18691 if Operating_Mode = Generate_Code
18692 and then In_Extended_Main_Source_Unit (N)
18694 Check_At_Least_N_Arguments (1);
18695 Check_No_Identifiers;
18696 Check_Is_In_Decl_Part_Or_Package_Spec;
18697 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18701 while Present (Arg) loop
18702 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18704 -- Store argument, converting sequences of spaces to a
18705 -- single null character (this is one of the differences
18706 -- in processing between Link_With and Linker_Options).
18708 Arg_Store : declare
18709 C : constant Char_Code := Get_Char_Code (' ');
18710 S : constant String_Id :=
18711 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18712 L : constant Nat := String_Length (S);
18715 procedure Skip_Spaces;
18716 -- Advance F past any spaces
18722 procedure Skip_Spaces is
18724 while F <= L and then Get_String_Char (S, F) = C loop
18729 -- Start of processing for Arg_Store
18732 Skip_Spaces; -- skip leading spaces
18734 -- Loop through characters, changing any embedded
18735 -- sequence of spaces to a single null character (this
18736 -- is how Link_With/Linker_Options differ)
18739 if Get_String_Char (S, F) = C then
18742 Store_String_Char (ASCII.NUL);
18745 Store_String_Char (Get_String_Char (S, F));
18753 if Present (Arg) then
18754 Store_String_Char (ASCII.NUL);
18758 Store_Linker_Option_String (End_String);
18766 -- pragma Linker_Alias (
18767 -- [Entity =>] LOCAL_NAME
18768 -- [Target =>] static_string_EXPRESSION);
18770 when Pragma_Linker_Alias =>
18772 Check_Arg_Order ((Name_Entity, Name_Target));
18773 Check_Arg_Count (2);
18774 Check_Optional_Identifier (Arg1, Name_Entity);
18775 Check_Optional_Identifier (Arg2, Name_Target);
18776 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18777 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18779 -- The only processing required is to link this item on to the
18780 -- list of rep items for the given entity. This is accomplished
18781 -- by the call to Rep_Item_Too_Late (when no error is detected
18782 -- and False is returned).
18784 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18787 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18790 ------------------------
18791 -- Linker_Constructor --
18792 ------------------------
18794 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18796 -- Code is shared with Linker_Destructor
18798 -----------------------
18799 -- Linker_Destructor --
18800 -----------------------
18802 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18804 when Pragma_Linker_Constructor
18805 | Pragma_Linker_Destructor
18807 Linker_Constructor : declare
18813 Check_Arg_Count (1);
18814 Check_No_Identifiers;
18815 Check_Arg_Is_Local_Name (Arg1);
18816 Arg1_X := Get_Pragma_Arg (Arg1);
18818 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18820 if not Is_Library_Level_Entity (Proc) then
18822 ("argument for pragma% must be library level entity", Arg1);
18825 -- The only processing required is to link this item on to the
18826 -- list of rep items for the given entity. This is accomplished
18827 -- by the call to Rep_Item_Too_Late (when no error is detected
18828 -- and False is returned).
18830 if Rep_Item_Too_Late (Proc, N) then
18833 Set_Has_Gigi_Rep_Item (Proc);
18835 end Linker_Constructor;
18837 --------------------
18838 -- Linker_Options --
18839 --------------------
18841 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18843 when Pragma_Linker_Options => Linker_Options : declare
18847 Check_Ada_83_Warning;
18848 Check_No_Identifiers;
18849 Check_Arg_Count (1);
18850 Check_Is_In_Decl_Part_Or_Package_Spec;
18851 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18852 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18855 while Present (Arg) loop
18856 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18857 Store_String_Char (ASCII.NUL);
18859 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18863 if Operating_Mode = Generate_Code
18864 and then In_Extended_Main_Source_Unit (N)
18866 Store_Linker_Option_String (End_String);
18868 end Linker_Options;
18870 --------------------
18871 -- Linker_Section --
18872 --------------------
18874 -- pragma Linker_Section (
18875 -- [Entity =>] LOCAL_NAME
18876 -- [Section =>] static_string_EXPRESSION);
18878 when Pragma_Linker_Section => Linker_Section : declare
18883 Ghost_Error_Posted : Boolean := False;
18884 -- Flag set when an error concerning the illegal mix of Ghost and
18885 -- non-Ghost subprograms is emitted.
18887 Ghost_Id : Entity_Id := Empty;
18888 -- The entity of the first Ghost subprogram encountered while
18889 -- processing the arguments of the pragma.
18893 Check_Arg_Order ((Name_Entity, Name_Section));
18894 Check_Arg_Count (2);
18895 Check_Optional_Identifier (Arg1, Name_Entity);
18896 Check_Optional_Identifier (Arg2, Name_Section);
18897 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18898 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18900 -- Check kind of entity
18902 Arg := Get_Pragma_Arg (Arg1);
18903 Ent := Entity (Arg);
18905 case Ekind (Ent) is
18907 -- Objects (constants and variables) and types. For these cases
18908 -- all we need to do is to set the Linker_Section_pragma field,
18909 -- checking that we do not have a duplicate.
18915 LPE := Linker_Section_Pragma (Ent);
18917 if Present (LPE) then
18918 Error_Msg_Sloc := Sloc (LPE);
18920 ("Linker_Section already specified for &#", Arg1, Ent);
18923 Set_Linker_Section_Pragma (Ent, N);
18925 -- A pragma that applies to a Ghost entity becomes Ghost for
18926 -- the purposes of legality checks and removal of ignored
18929 Mark_Ghost_Pragma (N, Ent);
18933 when Subprogram_Kind =>
18935 -- Aspect case, entity already set
18937 if From_Aspect_Specification (N) then
18938 Set_Linker_Section_Pragma
18939 (Entity (Corresponding_Aspect (N)), N);
18941 -- Propagate it to its ultimate aliased entity to
18942 -- facilitate the backend processing this attribute
18943 -- in instantiations of generic subprograms.
18945 if Present (Alias (Entity (Corresponding_Aspect (N))))
18947 Set_Linker_Section_Pragma
18949 (Entity (Corresponding_Aspect (N))), N);
18952 -- Pragma case, we must climb the homonym chain, but skip
18953 -- any for which the linker section is already set.
18957 if No (Linker_Section_Pragma (Ent)) then
18958 Set_Linker_Section_Pragma (Ent, N);
18960 -- Propagate it to its ultimate aliased entity to
18961 -- facilitate the backend processing this attribute
18962 -- in instantiations of generic subprograms.
18964 if Present (Alias (Ent)) then
18965 Set_Linker_Section_Pragma
18966 (Ultimate_Alias (Ent), N);
18969 -- A pragma that applies to a Ghost entity becomes
18970 -- Ghost for the purposes of legality checks and
18971 -- removal of ignored Ghost code.
18973 Mark_Ghost_Pragma (N, Ent);
18975 -- Capture the entity of the first Ghost subprogram
18976 -- being processed for error detection purposes.
18978 if Is_Ghost_Entity (Ent) then
18979 if No (Ghost_Id) then
18983 -- Otherwise the subprogram is non-Ghost. It is
18984 -- illegal to mix references to Ghost and non-Ghost
18985 -- entities (SPARK RM 6.9).
18987 elsif Present (Ghost_Id)
18988 and then not Ghost_Error_Posted
18990 Ghost_Error_Posted := True;
18992 Error_Msg_Name_1 := Pname;
18994 ("pragma % cannot mention ghost and "
18995 & "non-ghost subprograms", N);
18997 Error_Msg_Sloc := Sloc (Ghost_Id);
18999 ("\& # declared as ghost", N, Ghost_Id);
19001 Error_Msg_Sloc := Sloc (Ent);
19003 ("\& # declared as non-ghost", N, Ent);
19007 Ent := Homonym (Ent);
19009 or else Scope (Ent) /= Current_Scope;
19013 -- All other cases are illegal
19017 ("pragma% applies only to objects, subprograms, and types",
19020 end Linker_Section;
19026 -- pragma List (On | Off)
19028 -- There is nothing to do here, since we did all the processing for
19029 -- this pragma in Par.Prag (so that it works properly even in syntax
19032 when Pragma_List =>
19039 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19041 when Pragma_Lock_Free => Lock_Free : declare
19042 P : constant Node_Id := Parent (N);
19048 Check_No_Identifiers;
19049 Check_At_Most_N_Arguments (1);
19051 -- Protected definition case
19053 if Nkind (P) = N_Protected_Definition then
19054 Ent := Defining_Identifier (Parent (P));
19058 if Arg_Count = 1 then
19059 Arg := Get_Pragma_Arg (Arg1);
19060 Val := Is_True (Static_Boolean (Arg));
19062 -- No arguments (expression is considered to be True)
19068 -- Check duplicate pragma before we chain the pragma in the Rep
19069 -- Item chain of Ent.
19071 Check_Duplicate_Pragma (Ent);
19072 Record_Rep_Item (Ent, N);
19073 Set_Uses_Lock_Free (Ent, Val);
19075 -- Anything else is incorrect placement
19082 --------------------
19083 -- Locking_Policy --
19084 --------------------
19086 -- pragma Locking_Policy (policy_IDENTIFIER);
19088 when Pragma_Locking_Policy => declare
19089 subtype LP_Range is Name_Id
19090 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19095 Check_Ada_83_Warning;
19096 Check_Arg_Count (1);
19097 Check_No_Identifiers;
19098 Check_Arg_Is_Locking_Policy (Arg1);
19099 Check_Valid_Configuration_Pragma;
19100 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19103 when Name_Ceiling_Locking => LP := 'C';
19104 when Name_Concurrent_Readers_Locking => LP := 'R';
19105 when Name_Inheritance_Locking => LP := 'I';
19108 if Locking_Policy /= ' '
19109 and then Locking_Policy /= LP
19111 Error_Msg_Sloc := Locking_Policy_Sloc;
19112 Error_Pragma ("locking policy incompatible with policy#");
19114 -- Set new policy, but always preserve System_Location since we
19115 -- like the error message with the run time name.
19118 Locking_Policy := LP;
19120 if Locking_Policy_Sloc /= System_Location then
19121 Locking_Policy_Sloc := Loc;
19126 -------------------
19127 -- Loop_Optimize --
19128 -------------------
19130 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19132 -- OPTIMIZATION_HINT ::=
19133 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19135 when Pragma_Loop_Optimize => Loop_Optimize : declare
19140 Check_At_Least_N_Arguments (1);
19141 Check_No_Identifiers;
19143 Hint := First (Pragma_Argument_Associations (N));
19144 while Present (Hint) loop
19145 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19153 Check_Loop_Pragma_Placement;
19160 -- pragma Loop_Variant
19161 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19163 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19165 -- CHANGE_DIRECTION ::= Increases | Decreases
19167 when Pragma_Loop_Variant => Loop_Variant : declare
19172 Check_At_Least_N_Arguments (1);
19173 Check_Loop_Pragma_Placement;
19175 -- Process all increasing / decreasing expressions
19177 Variant := First (Pragma_Argument_Associations (N));
19178 while Present (Variant) loop
19179 if Chars (Variant) = No_Name then
19180 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19182 elsif Chars (Variant) not in Name_Decreases | Name_Increases
19185 Name : String := Get_Name_String (Chars (Variant));
19188 -- It is a common mistake to write "Increasing" for
19189 -- "Increases" or "Decreasing" for "Decreases". Recognize
19190 -- specially names starting with "incr" or "decr" to
19191 -- suggest the corresponding name.
19193 System.Case_Util.To_Lower (Name);
19195 if Name'Length >= 4
19196 and then Name (1 .. 4) = "incr"
19198 Error_Pragma_Arg_Ident
19199 ("expect name `Increases`", Variant);
19201 elsif Name'Length >= 4
19202 and then Name (1 .. 4) = "decr"
19204 Error_Pragma_Arg_Ident
19205 ("expect name `Decreases`", Variant);
19208 Error_Pragma_Arg_Ident
19209 ("expect name `Increases` or `Decreases`", Variant);
19214 Preanalyze_Assert_Expression
19215 (Expression (Variant), Any_Discrete);
19221 -----------------------
19222 -- Machine_Attribute --
19223 -----------------------
19225 -- pragma Machine_Attribute (
19226 -- [Entity =>] LOCAL_NAME,
19227 -- [Attribute_Name =>] static_string_EXPRESSION
19228 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19230 when Pragma_Machine_Attribute => Machine_Attribute : declare
19232 Def_Id : Entity_Id;
19236 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19238 if Arg_Count >= 3 then
19239 Check_Optional_Identifier (Arg3, Name_Info);
19241 while Present (Arg) loop
19242 Check_Arg_Is_OK_Static_Expression (Arg);
19246 Check_Arg_Count (2);
19249 Check_Optional_Identifier (Arg1, Name_Entity);
19250 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19251 Check_Arg_Is_Local_Name (Arg1);
19252 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19253 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19255 if Is_Access_Type (Def_Id) then
19256 Def_Id := Designated_Type (Def_Id);
19259 if Rep_Item_Too_Early (Def_Id, N) then
19263 Def_Id := Underlying_Type (Def_Id);
19265 -- The only processing required is to link this item on to the
19266 -- list of rep items for the given entity. This is accomplished
19267 -- by the call to Rep_Item_Too_Late (when no error is detected
19268 -- and False is returned).
19270 if Rep_Item_Too_Late (Def_Id, N) then
19273 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19275 end Machine_Attribute;
19282 -- (MAIN_OPTION [, MAIN_OPTION]);
19285 -- [STACK_SIZE =>] static_integer_EXPRESSION
19286 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19287 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19289 when Pragma_Main => Main : declare
19290 Args : Args_List (1 .. 3);
19291 Names : constant Name_List (1 .. 3) := (
19293 Name_Task_Stack_Size_Default,
19294 Name_Time_Slicing_Enabled);
19300 Gather_Associations (Names, Args);
19302 for J in 1 .. 2 loop
19303 if Present (Args (J)) then
19304 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19308 if Present (Args (3)) then
19309 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19313 while Present (Nod) loop
19314 if Nkind (Nod) = N_Pragma
19315 and then Pragma_Name (Nod) = Name_Main
19317 Error_Msg_Name_1 := Pname;
19318 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19329 -- pragma Main_Storage
19330 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19332 -- MAIN_STORAGE_OPTION ::=
19333 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19334 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19336 when Pragma_Main_Storage => Main_Storage : declare
19337 Args : Args_List (1 .. 2);
19338 Names : constant Name_List (1 .. 2) := (
19339 Name_Working_Storage,
19346 Gather_Associations (Names, Args);
19348 for J in 1 .. 2 loop
19349 if Present (Args (J)) then
19350 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19354 Check_In_Main_Program;
19357 while Present (Nod) loop
19358 if Nkind (Nod) = N_Pragma
19359 and then Pragma_Name (Nod) = Name_Main_Storage
19361 Error_Msg_Name_1 := Pname;
19362 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19369 ----------------------------
19370 -- Max_Entry_Queue_Length --
19371 ----------------------------
19373 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19375 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19376 -- Pragma_Max_Queue_Length.
19378 when Pragma_Max_Entry_Queue_Length
19379 | Pragma_Max_Entry_Queue_Depth
19380 | Pragma_Max_Queue_Length
19382 Max_Entry_Queue_Length : declare
19384 Entry_Decl : Node_Id;
19385 Entry_Id : Entity_Id;
19389 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19390 or else Prag_Id = Pragma_Max_Queue_Length
19395 Check_Arg_Count (1);
19398 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19400 -- Entry declaration
19402 if Nkind (Entry_Decl) = N_Entry_Declaration then
19404 -- Entry illegally within a task
19406 if Nkind (Parent (N)) = N_Task_Definition then
19407 Error_Pragma ("pragma % cannot apply to task entries");
19411 Entry_Id := Defining_Entity (Entry_Decl);
19413 -- Otherwise the pragma is associated with an illegal construct
19417 ("pragma % must apply to a protected entry declaration");
19421 -- Mark the pragma as Ghost if the related subprogram is also
19422 -- Ghost. This also ensures that any expansion performed further
19423 -- below will produce Ghost nodes.
19425 Mark_Ghost_Pragma (N, Entry_Id);
19427 -- Analyze the Integer expression
19429 Arg := Get_Pragma_Arg (Arg1);
19430 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19432 Val := Expr_Value (Arg);
19436 ("argument for pragma% cannot be less than -1", Arg1);
19438 elsif not UI_Is_In_Int_Range (Val) then
19440 ("argument for pragma% out of range of Integer", Arg1);
19444 Record_Rep_Item (Entry_Id, N);
19445 end Max_Entry_Queue_Length;
19451 -- pragma Memory_Size (NUMERIC_LITERAL)
19453 when Pragma_Memory_Size =>
19456 -- Memory size is simply ignored
19458 Check_No_Identifiers;
19459 Check_Arg_Count (1);
19460 Check_Arg_Is_Integer_Literal (Arg1);
19468 -- The only correct use of this pragma is on its own in a file, in
19469 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19470 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19471 -- check for a file containing nothing but a No_Body pragma). If we
19472 -- attempt to process it during normal semantics processing, it means
19473 -- it was misplaced.
19475 when Pragma_No_Body =>
19479 -----------------------------
19480 -- No_Elaboration_Code_All --
19481 -----------------------------
19483 -- pragma No_Elaboration_Code_All;
19485 when Pragma_No_Elaboration_Code_All =>
19487 Check_Valid_Library_Unit_Pragma;
19489 -- Must appear for a spec or generic spec
19491 if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
19492 N_Generic_Package_Declaration |
19493 N_Generic_Subprogram_Declaration |
19494 N_Package_Declaration |
19495 N_Subprogram_Declaration
19499 ("pragma% can only occur for package "
19500 & "or subprogram spec"));
19503 -- Set flag in unit table
19505 Set_No_Elab_Code_All (Current_Sem_Unit);
19507 -- Set restriction No_Elaboration_Code if this is the main unit
19509 if Current_Sem_Unit = Main_Unit then
19510 Set_Restriction (No_Elaboration_Code, N);
19513 -- If we are in the main unit or in an extended main source unit,
19514 -- then we also add it to the configuration restrictions so that
19515 -- it will apply to all units in the extended main source.
19517 if Current_Sem_Unit = Main_Unit
19518 or else In_Extended_Main_Source_Unit (N)
19520 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19523 -- If in main extended unit, activate transitive with test
19525 if In_Extended_Main_Source_Unit (N) then
19526 Opt.No_Elab_Code_All_Pragma := N;
19529 -----------------------------
19530 -- No_Component_Reordering --
19531 -----------------------------
19533 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19535 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19541 Check_At_Most_N_Arguments (1);
19543 if Arg_Count = 0 then
19544 Check_Valid_Configuration_Pragma;
19545 Opt.No_Component_Reordering := True;
19548 Check_Optional_Identifier (Arg2, Name_Entity);
19549 Check_Arg_Is_Local_Name (Arg1);
19550 E_Id := Get_Pragma_Arg (Arg1);
19552 if Etype (E_Id) = Any_Type then
19556 E := Entity (E_Id);
19558 if not Is_Record_Type (E) then
19559 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19562 Set_No_Reordering (Base_Type (E));
19564 end No_Comp_Reordering;
19566 --------------------------
19567 -- No_Heap_Finalization --
19568 --------------------------
19570 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19572 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19573 Context : constant Node_Id := Parent (N);
19574 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19580 Check_No_Identifiers;
19582 -- The pragma appears in a configuration file
19584 if No (Context) then
19585 Check_Arg_Count (0);
19586 Check_Valid_Configuration_Pragma;
19588 -- Detect a duplicate pragma
19590 if Present (No_Heap_Finalization_Pragma) then
19593 Prev => No_Heap_Finalization_Pragma);
19597 No_Heap_Finalization_Pragma := N;
19599 -- Otherwise the pragma should be associated with a library-level
19600 -- named access-to-object type.
19603 Check_Arg_Count (1);
19604 Check_Arg_Is_Local_Name (Arg1);
19606 Find_Type (Typ_Arg);
19607 Typ := Entity (Typ_Arg);
19609 -- The type being subjected to the pragma is erroneous
19611 if Typ = Any_Type then
19612 Error_Pragma ("cannot find type referenced by pragma %");
19614 -- The pragma is applied to an incomplete or generic formal
19615 -- type way too early.
19617 elsif Rep_Item_Too_Early (Typ, N) then
19621 Typ := Underlying_Type (Typ);
19624 -- The pragma must apply to an access-to-object type
19626 if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
19629 -- Give a detailed error message on all other access type kinds
19631 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19633 ("pragma % cannot apply to access protected subprogram "
19636 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19638 ("pragma % cannot apply to access subprogram type");
19640 elsif Is_Anonymous_Access_Type (Typ) then
19642 ("pragma % cannot apply to anonymous access type");
19644 -- Give a general error message in case the pragma applies to a
19645 -- non-access type.
19649 ("pragma % must apply to library level access type");
19652 -- At this point the argument denotes an access-to-object type.
19653 -- Ensure that the type is declared at the library level.
19655 if Is_Library_Level_Entity (Typ) then
19658 -- Quietly ignore an access-to-object type originally declared
19659 -- at the library level within a generic, but instantiated at
19660 -- a non-library level. As a result the access-to-object type
19661 -- "loses" its No_Heap_Finalization property.
19663 elsif In_Instance then
19668 ("pragma % must apply to library level access type");
19671 -- Detect a duplicate pragma
19673 if Present (No_Heap_Finalization_Pragma) then
19676 Prev => No_Heap_Finalization_Pragma);
19680 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19682 if Present (Prev) then
19690 Record_Rep_Item (Typ, N);
19692 end No_Heap_Finalization;
19698 -- pragma No_Inline ( NAME {, NAME} );
19700 when Pragma_No_Inline =>
19702 Process_Inline (Suppressed);
19708 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19710 when Pragma_No_Return => Prag_No_Return : declare
19712 function Check_No_Return
19714 N : Node_Id) return Boolean;
19715 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
19716 -- emit an error message and return False, otherwise return True.
19717 -- 6.5.1 Nonreturning procedures:
19718 -- 4/3 "Aspect No_Return shall not be specified for a null
19719 -- procedure nor an instance of a generic unit."
19721 ---------------------
19722 -- Check_No_Return --
19723 ---------------------
19725 function Check_No_Return
19727 N : Node_Id) return Boolean
19730 if Ekind (E) = E_Procedure then
19732 -- If E is a generic instance, marking it with No_Return
19733 -- is forbidden, but having it inherit the No_Return of
19734 -- the generic is allowed. We check if E is inheriting its
19735 -- No_Return flag from the generic by checking if No_Return
19738 if Is_Generic_Instance (E) and then not No_Return (E) then
19740 ("generic instance & is marked as No_Return", N, E);
19742 ("\generic procedure & must be marked No_Return",
19744 Generic_Parent (Parent (E)));
19747 elsif Null_Present (Subprogram_Specification (E)) then
19749 ("null procedure & cannot be marked No_Return", N, E);
19755 end Check_No_Return;
19762 Ghost_Error_Posted : Boolean := False;
19763 -- Flag set when an error concerning the illegal mix of Ghost and
19764 -- non-Ghost subprograms is emitted.
19766 Ghost_Id : Entity_Id := Empty;
19767 -- The entity of the first Ghost procedure encountered while
19768 -- processing the arguments of the pragma.
19772 Check_At_Least_N_Arguments (1);
19774 -- Loop through arguments of pragma
19777 while Present (Arg) loop
19778 Check_Arg_Is_Local_Name (Arg);
19779 Id := Get_Pragma_Arg (Arg);
19782 if not Is_Entity_Name (Id) then
19783 Error_Pragma_Arg ("entity name required", Arg);
19786 if Etype (Id) = Any_Type then
19790 -- Loop to find matching procedures or functions (Ada 2020)
19796 and then Scope (E) = Current_Scope
19798 -- Ada 2020 (AI12-0269): A function can be No_Return
19800 if Ekind (E) in E_Generic_Procedure | E_Procedure
19801 or else (Ada_Version >= Ada_2020
19803 Ekind (E) in E_Generic_Function | E_Function)
19805 -- Check that the pragma is not applied to a body.
19806 -- First check the specless body case, to give a
19807 -- different error message. These checks do not apply
19808 -- if Relaxed_RM_Semantics, to accommodate other Ada
19809 -- compilers. Disable these checks under -gnatd.J.
19811 if not Debug_Flag_Dot_JJ then
19812 if Nkind (Parent (Declaration_Node (E))) =
19814 and then not Relaxed_RM_Semantics
19817 ("pragma% requires separate spec and must come "
19821 -- Now the "specful" body case
19823 if Rep_Item_Too_Late (E, N) then
19828 if Check_No_Return (E, N) then
19832 -- A pragma that applies to a Ghost entity becomes Ghost
19833 -- for the purposes of legality checks and removal of
19834 -- ignored Ghost code.
19836 Mark_Ghost_Pragma (N, E);
19838 -- Capture the entity of the first Ghost procedure being
19839 -- processed for error detection purposes.
19841 if Is_Ghost_Entity (E) then
19842 if No (Ghost_Id) then
19846 -- Otherwise the subprogram is non-Ghost. It is illegal
19847 -- to mix references to Ghost and non-Ghost entities
19850 elsif Present (Ghost_Id)
19851 and then not Ghost_Error_Posted
19853 Ghost_Error_Posted := True;
19855 Error_Msg_Name_1 := Pname;
19857 ("pragma % cannot mention ghost and non-ghost "
19858 & "procedures", N);
19860 Error_Msg_Sloc := Sloc (Ghost_Id);
19861 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19863 Error_Msg_Sloc := Sloc (E);
19864 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19867 -- Set flag on any alias as well
19869 if Is_Overloadable (E)
19870 and then Present (Alias (E))
19871 and then Check_No_Return (Alias (E), N)
19873 Set_No_Return (Alias (E));
19879 exit when From_Aspect_Specification (N);
19883 -- If entity in not in current scope it may be the enclosing
19884 -- suprogram body to which the aspect applies.
19887 if Entity (Id) = Current_Scope
19888 and then From_Aspect_Specification (N)
19889 and then Check_No_Return (Entity (Id), N)
19891 Set_No_Return (Entity (Id));
19893 elsif Ada_Version >= Ada_2020 then
19895 ("no subprogram& found for pragma%", Arg);
19898 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19904 end Prag_No_Return;
19910 -- pragma No_Run_Time;
19912 -- Note: this pragma is retained for backwards compatibility. See
19913 -- body of Rtsfind for full details on its handling.
19915 when Pragma_No_Run_Time =>
19917 Check_Valid_Configuration_Pragma;
19918 Check_Arg_Count (0);
19920 -- Remove backward compatibility if Build_Type is FSF or GPL and
19921 -- generate a warning.
19924 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19927 Error_Pragma ("pragma% is ignored, has no effect??");
19929 No_Run_Time_Mode := True;
19930 Configurable_Run_Time_Mode := True;
19932 -- Set Duration to 32 bits if word size is 32
19934 if Ttypes.System_Word_Size = 32 then
19935 Duration_32_Bits_On_Target := True;
19938 -- Set appropriate restrictions
19940 Set_Restriction (No_Finalization, N);
19941 Set_Restriction (No_Exception_Handlers, N);
19942 Set_Restriction (Max_Tasks, N, 0);
19943 Set_Restriction (No_Tasking, N);
19947 -----------------------
19948 -- No_Tagged_Streams --
19949 -----------------------
19951 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19953 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19959 Check_At_Most_N_Arguments (1);
19961 -- One argument case
19963 if Arg_Count = 1 then
19964 Check_Optional_Identifier (Arg1, Name_Entity);
19965 Check_Arg_Is_Local_Name (Arg1);
19966 E_Id := Get_Pragma_Arg (Arg1);
19968 if Etype (E_Id) = Any_Type then
19972 E := Entity (E_Id);
19974 Check_Duplicate_Pragma (E);
19976 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19978 ("argument for pragma% must be root tagged type", Arg1);
19981 if Rep_Item_Too_Early (E, N)
19983 Rep_Item_Too_Late (E, N)
19987 Set_No_Tagged_Streams_Pragma (E, N);
19990 -- Zero argument case
19993 Check_Is_In_Decl_Part_Or_Package_Spec;
19994 No_Tagged_Streams := N;
19996 end No_Tagged_Strms;
19998 ------------------------
19999 -- No_Strict_Aliasing --
20000 ------------------------
20002 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20004 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20010 Check_At_Most_N_Arguments (1);
20012 if Arg_Count = 0 then
20013 Check_Valid_Configuration_Pragma;
20014 Opt.No_Strict_Aliasing := True;
20017 Check_Optional_Identifier (Arg2, Name_Entity);
20018 Check_Arg_Is_Local_Name (Arg1);
20019 E_Id := Get_Pragma_Arg (Arg1);
20021 if Etype (E_Id) = Any_Type then
20025 E := Entity (E_Id);
20027 if not Is_Access_Type (E) then
20028 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20031 Set_No_Strict_Aliasing (Base_Type (E));
20033 end No_Strict_Aliasing;
20035 -----------------------
20036 -- Normalize_Scalars --
20037 -----------------------
20039 -- pragma Normalize_Scalars;
20041 when Pragma_Normalize_Scalars =>
20042 Check_Ada_83_Warning;
20043 Check_Arg_Count (0);
20044 Check_Valid_Configuration_Pragma;
20046 -- Normalize_Scalars creates false positives in CodePeer, and
20047 -- incorrect negative results in GNATprove mode, so ignore this
20048 -- pragma in these modes.
20050 if not (CodePeer_Mode or GNATprove_Mode) then
20051 Normalize_Scalars := True;
20052 Init_Or_Norm_Scalars := True;
20059 -- pragma Obsolescent;
20061 -- pragma Obsolescent (
20062 -- [Message =>] static_string_EXPRESSION
20063 -- [,[Version =>] Ada_05]]);
20065 -- pragma Obsolescent (
20066 -- [Entity =>] NAME
20067 -- [,[Message =>] static_string_EXPRESSION
20068 -- [,[Version =>] Ada_05]] );
20070 when Pragma_Obsolescent => Obsolescent : declare
20074 procedure Set_Obsolescent (E : Entity_Id);
20075 -- Given an entity Ent, mark it as obsolescent if appropriate
20077 ---------------------
20078 -- Set_Obsolescent --
20079 ---------------------
20081 procedure Set_Obsolescent (E : Entity_Id) is
20090 -- A pragma that applies to a Ghost entity becomes Ghost for
20091 -- the purposes of legality checks and removal of ignored Ghost
20094 Mark_Ghost_Pragma (N, E);
20096 -- Entity name was given
20098 if Present (Ename) then
20100 -- If entity name matches, we are fine.
20102 if Chars (Ename) = Chars (Ent) then
20103 Set_Entity (Ename, Ent);
20104 Generate_Reference (Ent, Ename);
20106 -- If entity name does not match, only possibility is an
20107 -- enumeration literal from an enumeration type declaration.
20109 elsif Ekind (Ent) /= E_Enumeration_Type then
20111 ("pragma % entity name does not match declaration");
20114 Ent := First_Literal (E);
20118 ("pragma % entity name does not match any "
20119 & "enumeration literal");
20121 elsif Chars (Ent) = Chars (Ename) then
20122 Set_Entity (Ename, Ent);
20123 Generate_Reference (Ent, Ename);
20127 Next_Literal (Ent);
20133 -- Ent points to entity to be marked
20135 if Arg_Count >= 1 then
20137 -- Deal with static string argument
20139 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20140 S := Strval (Get_Pragma_Arg (Arg1));
20142 for J in 1 .. String_Length (S) loop
20143 if not In_Character_Range (Get_String_Char (S, J)) then
20145 ("pragma% argument does not allow wide characters",
20150 Obsolescent_Warnings.Append
20151 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20153 -- Check for Ada_05 parameter
20155 if Arg_Count /= 1 then
20156 Check_Arg_Count (2);
20159 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20162 Check_Arg_Is_Identifier (Argx);
20164 if Chars (Argx) /= Name_Ada_05 then
20165 Error_Msg_Name_2 := Name_Ada_05;
20167 ("only allowed argument for pragma% is %", Argx);
20170 if Ada_Version_Explicit < Ada_2005
20171 or else not Warn_On_Ada_2005_Compatibility
20179 -- Set flag if pragma active
20182 Set_Is_Obsolescent (Ent);
20186 end Set_Obsolescent;
20188 -- Start of processing for pragma Obsolescent
20193 Check_At_Most_N_Arguments (3);
20195 -- See if first argument specifies an entity name
20199 (Chars (Arg1) = Name_Entity
20201 Nkind (Get_Pragma_Arg (Arg1)) in
20202 N_Character_Literal | N_Identifier | N_Operator_Symbol)
20204 Ename := Get_Pragma_Arg (Arg1);
20206 -- Eliminate first argument, so we can share processing
20210 Arg_Count := Arg_Count - 1;
20212 -- No Entity name argument given
20218 if Arg_Count >= 1 then
20219 Check_Optional_Identifier (Arg1, Name_Message);
20221 if Arg_Count = 2 then
20222 Check_Optional_Identifier (Arg2, Name_Version);
20226 -- Get immediately preceding declaration
20229 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20233 -- Cases where we do not follow anything other than another pragma
20237 -- First case: library level compilation unit declaration with
20238 -- the pragma immediately following the declaration.
20240 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20242 (Defining_Entity (Unit (Parent (Parent (N)))));
20245 -- Case 2: library unit placement for package
20249 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20251 if Is_Package_Or_Generic_Package (Ent) then
20252 Set_Obsolescent (Ent);
20258 -- Cases where we must follow a declaration, including an
20259 -- abstract subprogram declaration, which is not in the
20260 -- other node subtypes.
20263 if Nkind (Decl) not in N_Declaration
20264 and then Nkind (Decl) not in N_Later_Decl_Item
20265 and then Nkind (Decl) not in N_Generic_Declaration
20266 and then Nkind (Decl) not in N_Renaming_Declaration
20267 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20270 ("pragma% misplaced, "
20271 & "must immediately follow a declaration");
20274 Set_Obsolescent (Defining_Entity (Decl));
20284 -- pragma Optimize (Time | Space | Off);
20286 -- The actual check for optimize is done in Gigi. Note that this
20287 -- pragma does not actually change the optimization setting, it
20288 -- simply checks that it is consistent with the pragma.
20290 when Pragma_Optimize =>
20291 Check_No_Identifiers;
20292 Check_Arg_Count (1);
20293 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20295 ------------------------
20296 -- Optimize_Alignment --
20297 ------------------------
20299 -- pragma Optimize_Alignment (Time | Space | Off);
20301 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20303 Check_No_Identifiers;
20304 Check_Arg_Count (1);
20305 Check_Valid_Configuration_Pragma;
20308 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20311 when Name_Off => Opt.Optimize_Alignment := 'O';
20312 when Name_Space => Opt.Optimize_Alignment := 'S';
20313 when Name_Time => Opt.Optimize_Alignment := 'T';
20316 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20320 -- Set indication that mode is set locally. If we are in fact in a
20321 -- configuration pragma file, this setting is harmless since the
20322 -- switch will get reset anyway at the start of each unit.
20324 Optimize_Alignment_Local := True;
20325 end Optimize_Alignment;
20331 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20333 when Pragma_Ordered => Ordered : declare
20334 Assoc : constant Node_Id := Arg1;
20340 Check_No_Identifiers;
20341 Check_Arg_Count (1);
20342 Check_Arg_Is_Local_Name (Arg1);
20344 Type_Id := Get_Pragma_Arg (Assoc);
20345 Find_Type (Type_Id);
20346 Typ := Entity (Type_Id);
20348 if Typ = Any_Type then
20351 Typ := Underlying_Type (Typ);
20354 if not Is_Enumeration_Type (Typ) then
20355 Error_Pragma ("pragma% must specify enumeration type");
20358 Check_First_Subtype (Arg1);
20359 Set_Has_Pragma_Ordered (Base_Type (Typ));
20362 -------------------
20363 -- Overflow_Mode --
20364 -------------------
20366 -- pragma Overflow_Mode
20367 -- ([General => ] MODE [, [Assertions => ] MODE]);
20369 -- MODE := STRICT | MINIMIZED | ELIMINATED
20371 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20372 -- since System.Bignums makes this assumption. This is true of nearly
20373 -- all (all?) targets.
20375 when Pragma_Overflow_Mode => Overflow_Mode : declare
20376 function Get_Overflow_Mode
20378 Arg : Node_Id) return Overflow_Mode_Type;
20379 -- Function to process one pragma argument, Arg. If an identifier
20380 -- is present, it must be Name. Mode type is returned if a valid
20381 -- argument exists, otherwise an error is signalled.
20383 -----------------------
20384 -- Get_Overflow_Mode --
20385 -----------------------
20387 function Get_Overflow_Mode
20389 Arg : Node_Id) return Overflow_Mode_Type
20391 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20394 Check_Optional_Identifier (Arg, Name);
20395 Check_Arg_Is_Identifier (Argx);
20397 if Chars (Argx) = Name_Strict then
20400 elsif Chars (Argx) = Name_Minimized then
20403 elsif Chars (Argx) = Name_Eliminated then
20404 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20406 ("Eliminated not implemented on this target", Argx);
20412 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20414 end Get_Overflow_Mode;
20416 -- Start of processing for Overflow_Mode
20420 Check_At_Least_N_Arguments (1);
20421 Check_At_Most_N_Arguments (2);
20423 -- Process first argument
20425 Scope_Suppress.Overflow_Mode_General :=
20426 Get_Overflow_Mode (Name_General, Arg1);
20428 -- Case of only one argument
20430 if Arg_Count = 1 then
20431 Scope_Suppress.Overflow_Mode_Assertions :=
20432 Scope_Suppress.Overflow_Mode_General;
20434 -- Case of two arguments present
20437 Scope_Suppress.Overflow_Mode_Assertions :=
20438 Get_Overflow_Mode (Name_Assertions, Arg2);
20442 --------------------------
20443 -- Overriding Renamings --
20444 --------------------------
20446 -- pragma Overriding_Renamings;
20448 when Pragma_Overriding_Renamings =>
20450 Check_Arg_Count (0);
20451 Check_Valid_Configuration_Pragma;
20452 Overriding_Renamings := True;
20458 -- pragma Pack (first_subtype_LOCAL_NAME);
20460 when Pragma_Pack => Pack : declare
20461 Assoc : constant Node_Id := Arg1;
20463 Ignore : Boolean := False;
20468 Check_No_Identifiers;
20469 Check_Arg_Count (1);
20470 Check_Arg_Is_Local_Name (Arg1);
20471 Type_Id := Get_Pragma_Arg (Assoc);
20473 if not Is_Entity_Name (Type_Id)
20474 or else not Is_Type (Entity (Type_Id))
20477 ("argument for pragma% must be type or subtype", Arg1);
20480 Find_Type (Type_Id);
20481 Typ := Entity (Type_Id);
20484 or else Rep_Item_Too_Early (Typ, N)
20488 Typ := Underlying_Type (Typ);
20491 -- A pragma that applies to a Ghost entity becomes Ghost for the
20492 -- purposes of legality checks and removal of ignored Ghost code.
20494 Mark_Ghost_Pragma (N, Typ);
20496 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20497 Error_Pragma ("pragma% must specify array or record type");
20500 Check_First_Subtype (Arg1);
20501 Check_Duplicate_Pragma (Typ);
20505 if Is_Array_Type (Typ) then
20506 Ctyp := Component_Type (Typ);
20508 -- Ignore pack that does nothing
20510 if Known_Static_Esize (Ctyp)
20511 and then Known_Static_RM_Size (Ctyp)
20512 and then Esize (Ctyp) = RM_Size (Ctyp)
20513 and then Addressable (Esize (Ctyp))
20518 -- Process OK pragma Pack. Note that if there is a separate
20519 -- component clause present, the Pack will be cancelled. This
20520 -- processing is in Freeze.
20522 if not Rep_Item_Too_Late (Typ, N) then
20524 -- In CodePeer mode, we do not need complex front-end
20525 -- expansions related to pragma Pack, so disable handling
20528 if CodePeer_Mode then
20531 -- Normal case where we do the pack action
20535 Set_Is_Packed (Base_Type (Typ));
20536 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20539 Set_Has_Pragma_Pack (Base_Type (Typ));
20543 -- For record types, the pack is always effective
20545 else pragma Assert (Is_Record_Type (Typ));
20546 if not Rep_Item_Too_Late (Typ, N) then
20547 Set_Is_Packed (Base_Type (Typ));
20548 Set_Has_Pragma_Pack (Base_Type (Typ));
20549 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20560 -- There is nothing to do here, since we did all the processing for
20561 -- this pragma in Par.Prag (so that it works properly even in syntax
20564 when Pragma_Page =>
20571 -- pragma Part_Of (ABSTRACT_STATE);
20573 -- ABSTRACT_STATE ::= NAME
20575 when Pragma_Part_Of => Part_Of : declare
20576 procedure Propagate_Part_Of
20577 (Pack_Id : Entity_Id;
20578 State_Id : Entity_Id;
20579 Instance : Node_Id);
20580 -- Propagate the Part_Of indicator to all abstract states and
20581 -- objects declared in the visible state space of a package
20582 -- denoted by Pack_Id. State_Id is the encapsulating state.
20583 -- Instance is the package instantiation node.
20585 -----------------------
20586 -- Propagate_Part_Of --
20587 -----------------------
20589 procedure Propagate_Part_Of
20590 (Pack_Id : Entity_Id;
20591 State_Id : Entity_Id;
20592 Instance : Node_Id)
20594 Has_Item : Boolean := False;
20595 -- Flag set when the visible state space contains at least one
20596 -- abstract state or variable.
20598 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20599 -- Propagate the Part_Of indicator to all abstract states and
20600 -- objects declared in the visible state space of a package
20601 -- denoted by Pack_Id.
20603 -----------------------
20604 -- Propagate_Part_Of --
20605 -----------------------
20607 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20608 Constits : Elist_Id;
20609 Item_Id : Entity_Id;
20612 -- Traverse the entity chain of the package and set relevant
20613 -- attributes of abstract states and objects declared in the
20614 -- visible state space of the package.
20616 Item_Id := First_Entity (Pack_Id);
20617 while Present (Item_Id)
20618 and then not In_Private_Part (Item_Id)
20620 -- Do not consider internally generated items
20622 if not Comes_From_Source (Item_Id) then
20625 -- Do not consider generic formals or their corresponding
20626 -- actuals because they are not part of a visible state.
20627 -- Note that both entities are marked as hidden.
20629 elsif Is_Hidden (Item_Id) then
20632 -- The Part_Of indicator turns an abstract state or an
20633 -- object into a constituent of the encapsulating state.
20634 -- Note that constants are considered here even though
20635 -- they may not depend on variable input. This check is
20636 -- left to the SPARK prover.
20638 elsif Ekind (Item_Id) in
20639 E_Abstract_State | E_Constant | E_Variable
20642 Constits := Part_Of_Constituents (State_Id);
20644 if No (Constits) then
20645 Constits := New_Elmt_List;
20646 Set_Part_Of_Constituents (State_Id, Constits);
20649 Append_Elmt (Item_Id, Constits);
20650 Set_Encapsulating_State (Item_Id, State_Id);
20652 -- Recursively handle nested packages and instantiations
20654 elsif Ekind (Item_Id) = E_Package then
20655 Propagate_Part_Of (Item_Id);
20658 Next_Entity (Item_Id);
20660 end Propagate_Part_Of;
20662 -- Start of processing for Propagate_Part_Of
20665 Propagate_Part_Of (Pack_Id);
20667 -- Detect a package instantiation that is subject to a Part_Of
20668 -- indicator, but has no visible state.
20670 if not Has_Item then
20672 ("package instantiation & has Part_Of indicator but "
20673 & "lacks visible state", Instance, Pack_Id);
20675 end Propagate_Part_Of;
20679 Constits : Elist_Id;
20681 Encap_Id : Entity_Id;
20682 Item_Id : Entity_Id;
20686 -- Start of processing for Part_Of
20690 Check_No_Identifiers;
20691 Check_Arg_Count (1);
20693 Stmt := Find_Related_Context (N, Do_Checks => True);
20695 -- Object declaration
20697 if Nkind (Stmt) = N_Object_Declaration then
20700 -- Package instantiation
20702 elsif Nkind (Stmt) = N_Package_Instantiation then
20705 -- Single concurrent type declaration
20707 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20710 -- Otherwise the pragma is associated with an illegal construct
20717 -- Extract the entity of the related object declaration or package
20718 -- instantiation. In the case of the instantiation, use the entity
20719 -- of the instance spec.
20721 if Nkind (Stmt) = N_Package_Instantiation then
20722 Stmt := Instance_Spec (Stmt);
20725 Item_Id := Defining_Entity (Stmt);
20727 -- A pragma that applies to a Ghost entity becomes Ghost for the
20728 -- purposes of legality checks and removal of ignored Ghost code.
20730 Mark_Ghost_Pragma (N, Item_Id);
20732 -- Chain the pragma on the contract for further processing by
20733 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20735 Add_Contract_Item (N, Item_Id);
20737 -- A variable may act as constituent of a single concurrent type
20738 -- which in turn could be declared after the variable. Due to this
20739 -- discrepancy, the full analysis of indicator Part_Of is delayed
20740 -- until the end of the enclosing declarative region (see routine
20741 -- Analyze_Part_Of_In_Decl_Part).
20743 if Ekind (Item_Id) = E_Variable then
20746 -- Otherwise indicator Part_Of applies to a constant or a package
20750 Encap := Get_Pragma_Arg (Arg1);
20752 -- Detect any discrepancies between the placement of the
20753 -- constant or package instantiation with respect to state
20754 -- space and the encapsulating state.
20758 Item_Id => Item_Id,
20760 Encap_Id => Encap_Id,
20764 pragma Assert (Present (Encap_Id));
20766 if Ekind (Item_Id) = E_Constant then
20767 Constits := Part_Of_Constituents (Encap_Id);
20769 if No (Constits) then
20770 Constits := New_Elmt_List;
20771 Set_Part_Of_Constituents (Encap_Id, Constits);
20774 Append_Elmt (Item_Id, Constits);
20775 Set_Encapsulating_State (Item_Id, Encap_Id);
20777 -- Propagate the Part_Of indicator to the visible state
20778 -- space of the package instantiation.
20782 (Pack_Id => Item_Id,
20783 State_Id => Encap_Id,
20790 ----------------------------------
20791 -- Partition_Elaboration_Policy --
20792 ----------------------------------
20794 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20796 when Pragma_Partition_Elaboration_Policy => PEP : declare
20797 subtype PEP_Range is Name_Id
20798 range First_Partition_Elaboration_Policy_Name
20799 .. Last_Partition_Elaboration_Policy_Name;
20800 PEP_Val : PEP_Range;
20805 Check_Arg_Count (1);
20806 Check_No_Identifiers;
20807 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20808 Check_Valid_Configuration_Pragma;
20809 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20812 when Name_Concurrent => PEP := 'C';
20813 when Name_Sequential => PEP := 'S';
20816 if Partition_Elaboration_Policy /= ' '
20817 and then Partition_Elaboration_Policy /= PEP
20819 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20821 ("partition elaboration policy incompatible with policy#");
20823 -- Set new policy, but always preserve System_Location since we
20824 -- like the error message with the run time name.
20827 Partition_Elaboration_Policy := PEP;
20829 if Partition_Elaboration_Policy_Sloc /= System_Location then
20830 Partition_Elaboration_Policy_Sloc := Loc;
20839 -- pragma Passive [(PASSIVE_FORM)];
20841 -- PASSIVE_FORM ::= Semaphore | No
20843 when Pragma_Passive =>
20846 if Nkind (Parent (N)) /= N_Task_Definition then
20847 Error_Pragma ("pragma% must be within task definition");
20850 if Arg_Count /= 0 then
20851 Check_Arg_Count (1);
20852 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20855 ----------------------------------
20856 -- Preelaborable_Initialization --
20857 ----------------------------------
20859 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20861 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20866 Check_Arg_Count (1);
20867 Check_No_Identifiers;
20868 Check_Arg_Is_Identifier (Arg1);
20869 Check_Arg_Is_Local_Name (Arg1);
20870 Check_First_Subtype (Arg1);
20871 Ent := Entity (Get_Pragma_Arg (Arg1));
20873 -- A pragma that applies to a Ghost entity becomes Ghost for the
20874 -- purposes of legality checks and removal of ignored Ghost code.
20876 Mark_Ghost_Pragma (N, Ent);
20878 -- The pragma may come from an aspect on a private declaration,
20879 -- even if the freeze point at which this is analyzed in the
20880 -- private part after the full view.
20882 if Has_Private_Declaration (Ent)
20883 and then From_Aspect_Specification (N)
20887 -- Check appropriate type argument
20889 elsif Is_Private_Type (Ent)
20890 or else Is_Protected_Type (Ent)
20891 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20893 -- AI05-0028: The pragma applies to all composite types. Note
20894 -- that we apply this binding interpretation to earlier versions
20895 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20896 -- choice since there are other compilers that do the same.
20898 or else Is_Composite_Type (Ent)
20904 ("pragma % can only be applied to private, formal derived, "
20905 & "protected, or composite type", Arg1);
20908 -- Give an error if the pragma is applied to a protected type that
20909 -- does not qualify (due to having entries, or due to components
20910 -- that do not qualify).
20912 if Is_Protected_Type (Ent)
20913 and then not Has_Preelaborable_Initialization (Ent)
20916 ("protected type & does not have preelaborable "
20917 & "initialization", Ent);
20919 -- Otherwise mark the type as definitely having preelaborable
20923 Set_Known_To_Have_Preelab_Init (Ent);
20926 if Has_Pragma_Preelab_Init (Ent)
20927 and then Warn_On_Redundant_Constructs
20929 Error_Pragma ("?r?duplicate pragma%!");
20931 Set_Has_Pragma_Preelab_Init (Ent);
20935 --------------------
20936 -- Persistent_BSS --
20937 --------------------
20939 -- pragma Persistent_BSS [(object_NAME)];
20941 when Pragma_Persistent_BSS => Persistent_BSS : declare
20948 Check_At_Most_N_Arguments (1);
20950 -- Case of application to specific object (one argument)
20952 if Arg_Count = 1 then
20953 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20955 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20957 Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
20958 E_Variable | E_Constant
20960 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20963 Ent := Entity (Get_Pragma_Arg (Arg1));
20965 -- A pragma that applies to a Ghost entity becomes Ghost for
20966 -- the purposes of legality checks and removal of ignored Ghost
20969 Mark_Ghost_Pragma (N, Ent);
20971 -- Check for duplication before inserting in list of
20972 -- representation items.
20974 Check_Duplicate_Pragma (Ent);
20976 if Rep_Item_Too_Late (Ent, N) then
20980 Decl := Parent (Ent);
20982 if Present (Expression (Decl)) then
20983 -- Variables in Persistent_BSS cannot be initialized, so
20984 -- turn off any initialization that might be caused by
20985 -- pragmas Initialize_Scalars or Normalize_Scalars.
20987 if Kill_Range_Check (Expression (Decl)) then
20990 Name_Suppress_Initialization,
20991 Pragma_Argument_Associations => New_List (
20992 Make_Pragma_Argument_Association (Loc,
20993 Expression => New_Occurrence_Of (Ent, Loc))));
20994 Insert_Before (N, Prag);
20999 ("object for pragma% cannot have initialization", Arg1);
21003 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
21005 ("object type for pragma% is not potentially persistent",
21010 Make_Linker_Section_Pragma
21011 (Ent, Loc, ".persistent.bss");
21012 Insert_After (N, Prag);
21015 -- Case of use as configuration pragma with no arguments
21018 Check_Valid_Configuration_Pragma;
21019 Persistent_BSS_Mode := True;
21021 end Persistent_BSS;
21023 --------------------
21024 -- Rename_Pragma --
21025 --------------------
21027 -- pragma Rename_Pragma (
21028 -- [New_Name =>] IDENTIFIER,
21029 -- [Renamed =>] pragma_IDENTIFIER);
21031 when Pragma_Rename_Pragma => Rename_Pragma : declare
21032 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21033 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21037 Check_Valid_Configuration_Pragma;
21038 Check_Arg_Count (2);
21039 Check_Optional_Identifier (Arg1, Name_New_Name);
21040 Check_Optional_Identifier (Arg2, Name_Renamed);
21042 if Nkind (New_Name) /= N_Identifier then
21043 Error_Pragma_Arg ("identifier expected", Arg1);
21046 if Nkind (Old_Name) /= N_Identifier then
21047 Error_Pragma_Arg ("identifier expected", Arg2);
21050 -- The New_Name arg should not be an existing pragma (but we allow
21051 -- it; it's just a warning). The Old_Name arg must be an existing
21054 if Is_Pragma_Name (Chars (New_Name)) then
21055 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21058 if not Is_Pragma_Name (Chars (Old_Name)) then
21059 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21062 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21065 -----------------------------------
21066 -- Post/Post_Class/Postcondition --
21067 -----------------------------------
21069 -- pragma Post (Boolean_EXPRESSION);
21070 -- pragma Post_Class (Boolean_EXPRESSION);
21071 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21072 -- [,[Message =>] String_EXPRESSION]);
21074 -- Characteristics:
21076 -- * Analysis - The annotation undergoes initial checks to verify
21077 -- the legal placement and context. Secondary checks preanalyze the
21080 -- Analyze_Pre_Post_Condition_In_Decl_Part
21082 -- * Expansion - The annotation is expanded during the expansion of
21083 -- the related subprogram [body] contract as performed in:
21085 -- Expand_Subprogram_Contract
21087 -- * Template - The annotation utilizes the generic template of the
21088 -- related subprogram [body] when it is:
21090 -- aspect on subprogram declaration
21091 -- aspect on stand-alone subprogram body
21092 -- pragma on stand-alone subprogram body
21094 -- The annotation must prepare its own template when it is:
21096 -- pragma on subprogram declaration
21098 -- * Globals - Capture of global references must occur after full
21101 -- * Instance - The annotation is instantiated automatically when
21102 -- the related generic subprogram [body] is instantiated except for
21103 -- the "pragma on subprogram declaration" case. In that scenario
21104 -- the annotation must instantiate itself.
21107 | Pragma_Post_Class
21108 | Pragma_Postcondition
21110 Analyze_Pre_Post_Condition;
21112 --------------------------------
21113 -- Pre/Pre_Class/Precondition --
21114 --------------------------------
21116 -- pragma Pre (Boolean_EXPRESSION);
21117 -- pragma Pre_Class (Boolean_EXPRESSION);
21118 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21119 -- [,[Message =>] String_EXPRESSION]);
21121 -- Characteristics:
21123 -- * Analysis - The annotation undergoes initial checks to verify
21124 -- the legal placement and context. Secondary checks preanalyze the
21127 -- Analyze_Pre_Post_Condition_In_Decl_Part
21129 -- * Expansion - The annotation is expanded during the expansion of
21130 -- the related subprogram [body] contract as performed in:
21132 -- Expand_Subprogram_Contract
21134 -- * Template - The annotation utilizes the generic template of the
21135 -- related subprogram [body] when it is:
21137 -- aspect on subprogram declaration
21138 -- aspect on stand-alone subprogram body
21139 -- pragma on stand-alone subprogram body
21141 -- The annotation must prepare its own template when it is:
21143 -- pragma on subprogram declaration
21145 -- * Globals - Capture of global references must occur after full
21148 -- * Instance - The annotation is instantiated automatically when
21149 -- the related generic subprogram [body] is instantiated except for
21150 -- the "pragma on subprogram declaration" case. In that scenario
21151 -- the annotation must instantiate itself.
21155 | Pragma_Precondition
21157 Analyze_Pre_Post_Condition;
21163 -- pragma Predicate
21164 -- ([Entity =>] type_LOCAL_NAME,
21165 -- [Check =>] boolean_EXPRESSION);
21167 when Pragma_Predicate => Predicate : declare
21174 Check_Arg_Count (2);
21175 Check_Optional_Identifier (Arg1, Name_Entity);
21176 Check_Optional_Identifier (Arg2, Name_Check);
21178 Check_Arg_Is_Local_Name (Arg1);
21180 Type_Id := Get_Pragma_Arg (Arg1);
21181 Find_Type (Type_Id);
21182 Typ := Entity (Type_Id);
21184 if Typ = Any_Type then
21188 -- A pragma that applies to a Ghost entity becomes Ghost for the
21189 -- purposes of legality checks and removal of ignored Ghost code.
21191 Mark_Ghost_Pragma (N, Typ);
21193 -- The remaining processing is simply to link the pragma on to
21194 -- the rep item chain, for processing when the type is frozen.
21195 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21196 -- mark the type as having predicates.
21198 -- If the current policy for predicate checking is Ignore mark the
21199 -- subtype accordingly. In the case of predicates we consider them
21200 -- enabled unless Ignore is specified (either directly or with a
21201 -- general Assertion_Policy pragma) to preserve existing warnings.
21203 Set_Has_Predicates (Typ);
21205 -- Indicate that the pragma must be processed at the point the
21206 -- type is frozen, as is done for the corresponding aspect.
21208 Set_Has_Delayed_Aspects (Typ);
21209 Set_Has_Delayed_Freeze (Typ);
21211 Set_Predicates_Ignored (Typ,
21212 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21213 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21216 -----------------------
21217 -- Predicate_Failure --
21218 -----------------------
21220 -- pragma Predicate_Failure
21221 -- ([Entity =>] type_LOCAL_NAME,
21222 -- [Message =>] string_EXPRESSION);
21224 when Pragma_Predicate_Failure => Predicate_Failure : declare
21231 Check_Arg_Count (2);
21232 Check_Optional_Identifier (Arg1, Name_Entity);
21233 Check_Optional_Identifier (Arg2, Name_Message);
21235 Check_Arg_Is_Local_Name (Arg1);
21237 Type_Id := Get_Pragma_Arg (Arg1);
21238 Find_Type (Type_Id);
21239 Typ := Entity (Type_Id);
21241 if Typ = Any_Type then
21245 -- A pragma that applies to a Ghost entity becomes Ghost for the
21246 -- purposes of legality checks and removal of ignored Ghost code.
21248 Mark_Ghost_Pragma (N, Typ);
21250 -- The remaining processing is simply to link the pragma on to
21251 -- the rep item chain, for processing when the type is frozen.
21252 -- This is accomplished by a call to Rep_Item_Too_Late.
21254 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21255 end Predicate_Failure;
21261 -- pragma Preelaborate [(library_unit_NAME)];
21263 -- Set the flag Is_Preelaborated of program unit name entity
21265 when Pragma_Preelaborate => Preelaborate : declare
21266 Pa : constant Node_Id := Parent (N);
21267 Pk : constant Node_Kind := Nkind (Pa);
21271 Check_Ada_83_Warning;
21272 Check_Valid_Library_Unit_Pragma;
21274 Ent := Find_Lib_Unit_Name;
21276 -- A pragma that applies to a Ghost entity becomes Ghost for the
21277 -- purposes of legality checks and removal of ignored Ghost code.
21279 Mark_Ghost_Pragma (N, Ent);
21280 Check_Duplicate_Pragma (Ent);
21282 -- This filters out pragmas inside generic parents that show up
21283 -- inside instantiations. Pragmas that come from aspects in the
21284 -- unit are not ignored.
21286 if Present (Ent) then
21287 if Pk = N_Package_Specification
21288 and then Present (Generic_Parent (Pa))
21289 and then not From_Aspect_Specification (N)
21294 if not Debug_Flag_U then
21295 Set_Is_Preelaborated (Ent);
21297 if Legacy_Elaboration_Checks then
21298 Set_Suppress_Elaboration_Warnings (Ent);
21305 -------------------------------
21306 -- Prefix_Exception_Messages --
21307 -------------------------------
21309 -- pragma Prefix_Exception_Messages;
21311 when Pragma_Prefix_Exception_Messages =>
21313 Check_Valid_Configuration_Pragma;
21314 Check_Arg_Count (0);
21315 Prefix_Exception_Messages := True;
21321 -- pragma Priority (EXPRESSION);
21323 when Pragma_Priority => Priority : declare
21324 P : constant Node_Id := Parent (N);
21329 Check_No_Identifiers;
21330 Check_Arg_Count (1);
21334 if Nkind (P) = N_Subprogram_Body then
21335 Check_In_Main_Program;
21337 Ent := Defining_Unit_Name (Specification (P));
21339 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21340 Ent := Defining_Identifier (Ent);
21343 Arg := Get_Pragma_Arg (Arg1);
21344 Analyze_And_Resolve (Arg, Standard_Integer);
21348 if not Is_OK_Static_Expression (Arg) then
21349 Flag_Non_Static_Expr
21350 ("main subprogram priority is not static!", Arg);
21353 -- If constraint error, then we already signalled an error
21355 elsif Raises_Constraint_Error (Arg) then
21358 -- Otherwise check in range except if Relaxed_RM_Semantics
21359 -- where we ignore the value if out of range.
21362 if not Relaxed_RM_Semantics
21363 and then not Is_In_Range (Arg, RTE (RE_Priority))
21366 ("main subprogram priority is out of range", Arg1);
21369 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21373 -- Load an arbitrary entity from System.Tasking.Stages or
21374 -- System.Tasking.Restricted.Stages (depending on the
21375 -- supported profile) to make sure that one of these packages
21376 -- is implicitly with'ed, since we need to have the tasking
21377 -- run time active for the pragma Priority to have any effect.
21378 -- Previously we with'ed the package System.Tasking, but this
21379 -- package does not trigger the required initialization of the
21380 -- run-time library.
21382 if Restricted_Profile then
21383 Discard_Node (RTE (RE_Activate_Restricted_Tasks));
21385 Discard_Node (RTE (RE_Activate_Tasks));
21388 -- Task or Protected, must be of type Integer
21390 elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
21391 Arg := Get_Pragma_Arg (Arg1);
21392 Ent := Defining_Identifier (Parent (P));
21394 -- The expression must be analyzed in the special manner
21395 -- described in "Handling of Default and Per-Object
21396 -- Expressions" in sem.ads.
21398 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21400 if not Is_OK_Static_Expression (Arg) then
21401 Check_Restriction (Static_Priorities, Arg);
21404 -- Anything else is incorrect
21410 -- Check duplicate pragma before we chain the pragma in the Rep
21411 -- Item chain of Ent.
21413 Check_Duplicate_Pragma (Ent);
21414 Record_Rep_Item (Ent, N);
21417 -----------------------------------
21418 -- Priority_Specific_Dispatching --
21419 -----------------------------------
21421 -- pragma Priority_Specific_Dispatching (
21422 -- policy_IDENTIFIER,
21423 -- first_priority_EXPRESSION,
21424 -- last_priority_EXPRESSION);
21426 when Pragma_Priority_Specific_Dispatching =>
21427 Priority_Specific_Dispatching : declare
21428 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21429 -- This is the entity System.Any_Priority;
21432 Lower_Bound : Node_Id;
21433 Upper_Bound : Node_Id;
21439 Check_Arg_Count (3);
21440 Check_No_Identifiers;
21441 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21442 Check_Valid_Configuration_Pragma;
21443 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21444 DP := Fold_Upper (Name_Buffer (1));
21446 Lower_Bound := Get_Pragma_Arg (Arg2);
21447 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21448 Lower_Val := Expr_Value (Lower_Bound);
21450 Upper_Bound := Get_Pragma_Arg (Arg3);
21451 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21452 Upper_Val := Expr_Value (Upper_Bound);
21454 -- It is not allowed to use Task_Dispatching_Policy and
21455 -- Priority_Specific_Dispatching in the same partition.
21457 if Task_Dispatching_Policy /= ' ' then
21458 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21460 ("pragma% incompatible with Task_Dispatching_Policy#");
21462 -- Check lower bound in range
21464 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21466 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21469 ("first_priority is out of range", Arg2);
21471 -- Check upper bound in range
21473 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21475 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21478 ("last_priority is out of range", Arg3);
21480 -- Check that the priority range is valid
21482 elsif Lower_Val > Upper_Val then
21484 ("last_priority_expression must be greater than or equal to "
21485 & "first_priority_expression");
21487 -- Store the new policy, but always preserve System_Location since
21488 -- we like the error message with the run-time name.
21491 -- Check overlapping in the priority ranges specified in other
21492 -- Priority_Specific_Dispatching pragmas within the same
21493 -- partition. We can only check those we know about.
21496 Specific_Dispatching.First .. Specific_Dispatching.Last
21498 if Specific_Dispatching.Table (J).First_Priority in
21499 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21500 or else Specific_Dispatching.Table (J).Last_Priority in
21501 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21504 Specific_Dispatching.Table (J).Pragma_Loc;
21506 ("priority range overlaps with "
21507 & "Priority_Specific_Dispatching#");
21511 -- The use of Priority_Specific_Dispatching is incompatible
21512 -- with Task_Dispatching_Policy.
21514 if Task_Dispatching_Policy /= ' ' then
21515 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21517 ("Priority_Specific_Dispatching incompatible "
21518 & "with Task_Dispatching_Policy#");
21521 -- The use of Priority_Specific_Dispatching forces ceiling
21524 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21525 Error_Msg_Sloc := Locking_Policy_Sloc;
21527 ("Priority_Specific_Dispatching incompatible "
21528 & "with Locking_Policy#");
21530 -- Set the Ceiling_Locking policy, but preserve System_Location
21531 -- since we like the error message with the run time name.
21534 Locking_Policy := 'C';
21536 if Locking_Policy_Sloc /= System_Location then
21537 Locking_Policy_Sloc := Loc;
21541 -- Add entry in the table
21543 Specific_Dispatching.Append
21544 ((Dispatching_Policy => DP,
21545 First_Priority => UI_To_Int (Lower_Val),
21546 Last_Priority => UI_To_Int (Upper_Val),
21547 Pragma_Loc => Loc));
21549 end Priority_Specific_Dispatching;
21555 -- pragma Profile (profile_IDENTIFIER);
21557 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21559 when Pragma_Profile =>
21561 Check_Arg_Count (1);
21562 Check_Valid_Configuration_Pragma;
21563 Check_No_Identifiers;
21566 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21569 if Nkind (Argx) /= N_Identifier then
21571 ("argument of pragma Profile must be an identifier", N);
21573 elsif Chars (Argx) = Name_Ravenscar then
21574 Set_Ravenscar_Profile (Ravenscar, N);
21576 elsif Chars (Argx) = Name_Jorvik then
21577 Set_Ravenscar_Profile (Jorvik, N);
21579 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21580 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21582 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21583 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21585 elsif Chars (Argx) = Name_Restricted then
21586 Set_Profile_Restrictions
21588 N, Warn => Treat_Restrictions_As_Warnings);
21590 elsif Chars (Argx) = Name_Rational then
21591 Set_Rational_Profile;
21593 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21594 Set_Profile_Restrictions
21595 (No_Implementation_Extensions,
21596 N, Warn => Treat_Restrictions_As_Warnings);
21599 Error_Pragma_Arg ("& is not a valid profile", Argx);
21603 ----------------------
21604 -- Profile_Warnings --
21605 ----------------------
21607 -- pragma Profile_Warnings (profile_IDENTIFIER);
21609 -- profile_IDENTIFIER => Restricted | Ravenscar
21611 when Pragma_Profile_Warnings =>
21613 Check_Arg_Count (1);
21614 Check_Valid_Configuration_Pragma;
21615 Check_No_Identifiers;
21618 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21621 if Chars (Argx) = Name_Ravenscar then
21622 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21624 elsif Chars (Argx) = Name_Restricted then
21625 Set_Profile_Restrictions (Restricted, N, Warn => True);
21627 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21628 Set_Profile_Restrictions
21629 (No_Implementation_Extensions, N, Warn => True);
21632 Error_Pragma_Arg ("& is not a valid profile", Argx);
21636 --------------------------
21637 -- Propagate_Exceptions --
21638 --------------------------
21640 -- pragma Propagate_Exceptions;
21642 -- Note: this pragma is obsolete and has no effect
21644 when Pragma_Propagate_Exceptions =>
21646 Check_Arg_Count (0);
21648 if Warn_On_Obsolescent_Feature then
21650 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21651 "and has no effect?j?", N);
21654 -----------------------------
21655 -- Provide_Shift_Operators --
21656 -----------------------------
21658 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21660 when Pragma_Provide_Shift_Operators =>
21661 Provide_Shift_Operators : declare
21664 procedure Declare_Shift_Operator (Nam : Name_Id);
21665 -- Insert declaration and pragma Instrinsic for named shift op
21667 ----------------------------
21668 -- Declare_Shift_Operator --
21669 ----------------------------
21671 procedure Declare_Shift_Operator (Nam : Name_Id) is
21677 Make_Subprogram_Declaration (Loc,
21678 Make_Function_Specification (Loc,
21679 Defining_Unit_Name =>
21680 Make_Defining_Identifier (Loc, Chars => Nam),
21682 Result_Definition =>
21683 Make_Identifier (Loc, Chars => Chars (Ent)),
21685 Parameter_Specifications => New_List (
21686 Make_Parameter_Specification (Loc,
21687 Defining_Identifier =>
21688 Make_Defining_Identifier (Loc, Name_Value),
21690 Make_Identifier (Loc, Chars => Chars (Ent))),
21692 Make_Parameter_Specification (Loc,
21693 Defining_Identifier =>
21694 Make_Defining_Identifier (Loc, Name_Amount),
21696 New_Occurrence_Of (Standard_Natural, Loc)))));
21700 Chars => Name_Import,
21701 Pragma_Argument_Associations => New_List (
21702 Make_Pragma_Argument_Association (Loc,
21703 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21704 Make_Pragma_Argument_Association (Loc,
21705 Expression => Make_Identifier (Loc, Nam))));
21707 Insert_After (N, Import);
21708 Insert_After (N, Func);
21709 end Declare_Shift_Operator;
21711 -- Start of processing for Provide_Shift_Operators
21715 Check_Arg_Count (1);
21716 Check_Arg_Is_Local_Name (Arg1);
21718 Arg1 := Get_Pragma_Arg (Arg1);
21720 -- We must have an entity name
21722 if not Is_Entity_Name (Arg1) then
21724 ("pragma % must apply to integer first subtype", Arg1);
21727 -- If no Entity, means there was a prior error so ignore
21729 if Present (Entity (Arg1)) then
21730 Ent := Entity (Arg1);
21732 -- Apply error checks
21734 if not Is_First_Subtype (Ent) then
21736 ("cannot apply pragma %",
21737 "\& is not a first subtype",
21740 elsif not Is_Integer_Type (Ent) then
21742 ("cannot apply pragma %",
21743 "\& is not an integer type",
21746 elsif Has_Shift_Operator (Ent) then
21748 ("cannot apply pragma %",
21749 "\& already has declared shift operators",
21752 elsif Is_Frozen (Ent) then
21754 ("pragma % appears too late",
21755 "\& is already frozen",
21759 -- Now declare the operators. We do this during analysis rather
21760 -- than expansion, since we want the operators available if we
21761 -- are operating in -gnatc mode.
21763 Declare_Shift_Operator (Name_Rotate_Left);
21764 Declare_Shift_Operator (Name_Rotate_Right);
21765 Declare_Shift_Operator (Name_Shift_Left);
21766 Declare_Shift_Operator (Name_Shift_Right);
21767 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21769 end Provide_Shift_Operators;
21775 -- pragma Psect_Object (
21776 -- [Internal =>] LOCAL_NAME,
21777 -- [, [External =>] EXTERNAL_SYMBOL]
21778 -- [, [Size =>] EXTERNAL_SYMBOL]);
21780 when Pragma_Common_Object
21781 | Pragma_Psect_Object
21783 Psect_Object : declare
21784 Args : Args_List (1 .. 3);
21785 Names : constant Name_List (1 .. 3) := (
21790 Internal : Node_Id renames Args (1);
21791 External : Node_Id renames Args (2);
21792 Size : Node_Id renames Args (3);
21794 Def_Id : Entity_Id;
21796 procedure Check_Arg (Arg : Node_Id);
21797 -- Checks that argument is either a string literal or an
21798 -- identifier, and posts error message if not.
21804 procedure Check_Arg (Arg : Node_Id) is
21806 if Nkind (Original_Node (Arg)) not in
21807 N_String_Literal | N_Identifier
21810 ("inappropriate argument for pragma %", Arg);
21814 -- Start of processing for Common_Object/Psect_Object
21818 Gather_Associations (Names, Args);
21819 Process_Extended_Import_Export_Internal_Arg (Internal);
21821 Def_Id := Entity (Internal);
21823 if Ekind (Def_Id) not in E_Constant | E_Variable then
21825 ("pragma% must designate an object", Internal);
21828 Check_Arg (Internal);
21830 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21832 ("cannot use pragma% for imported/exported object",
21836 if Is_Concurrent_Type (Etype (Internal)) then
21838 ("cannot specify pragma % for task/protected object",
21842 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21844 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21846 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21849 if Ekind (Def_Id) = E_Constant then
21851 ("cannot specify pragma % for a constant", Internal);
21854 if Is_Record_Type (Etype (Internal)) then
21860 Ent := First_Entity (Etype (Internal));
21861 while Present (Ent) loop
21862 Decl := Declaration_Node (Ent);
21864 if Ekind (Ent) = E_Component
21865 and then Nkind (Decl) = N_Component_Declaration
21866 and then Present (Expression (Decl))
21867 and then Warn_On_Export_Import
21870 ("?x?object for pragma % has defaults", Internal);
21880 if Present (Size) then
21884 if Present (External) then
21885 Check_Arg_Is_External_Name (External);
21888 -- If all error tests pass, link pragma on to the rep item chain
21890 Record_Rep_Item (Def_Id, N);
21897 -- pragma Pure [(library_unit_NAME)];
21899 when Pragma_Pure => Pure : declare
21903 Check_Ada_83_Warning;
21905 -- If the pragma comes from a subprogram instantiation, nothing to
21906 -- check, this can happen at any level of nesting.
21908 if Is_Wrapper_Package (Current_Scope) then
21911 Check_Valid_Library_Unit_Pragma;
21914 Ent := Find_Lib_Unit_Name;
21916 -- A pragma that applies to a Ghost entity becomes Ghost for the
21917 -- purposes of legality checks and removal of ignored Ghost code.
21919 Mark_Ghost_Pragma (N, Ent);
21921 if not Debug_Flag_U then
21923 Set_Has_Pragma_Pure (Ent);
21925 if Legacy_Elaboration_Checks then
21926 Set_Suppress_Elaboration_Warnings (Ent);
21931 -------------------
21932 -- Pure_Function --
21933 -------------------
21935 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21937 when Pragma_Pure_Function => Pure_Function : declare
21938 Def_Id : Entity_Id;
21941 Effective : Boolean := False;
21942 Orig_Def : Entity_Id;
21943 Same_Decl : Boolean := False;
21947 Check_Arg_Count (1);
21948 Check_Optional_Identifier (Arg1, Name_Entity);
21949 Check_Arg_Is_Local_Name (Arg1);
21950 E_Id := Get_Pragma_Arg (Arg1);
21952 if Etype (E_Id) = Any_Type then
21956 -- Loop through homonyms (overloadings) of referenced entity
21958 E := Entity (E_Id);
21960 -- A pragma that applies to a Ghost entity becomes Ghost for the
21961 -- purposes of legality checks and removal of ignored Ghost code.
21963 Mark_Ghost_Pragma (N, E);
21965 if Present (E) then
21967 Def_Id := Get_Base_Subprogram (E);
21969 if Ekind (Def_Id) not in
21970 E_Function | E_Generic_Function | E_Operator
21973 ("pragma% requires a function name", Arg1);
21976 -- When we have a generic function we must jump up a level
21977 -- to the declaration of the wrapper package itself.
21979 Orig_Def := Def_Id;
21981 if Is_Generic_Instance (Def_Id) then
21982 while Nkind (Orig_Def) /= N_Package_Declaration loop
21983 Orig_Def := Parent (Orig_Def);
21987 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
21989 Set_Is_Pure (Def_Id);
21991 if not Has_Pragma_Pure_Function (Def_Id) then
21992 Set_Has_Pragma_Pure_Function (Def_Id);
21997 exit when From_Aspect_Specification (N);
21999 exit when No (E) or else Scope (E) /= Current_Scope;
22003 and then Warn_On_Redundant_Constructs
22006 ("pragma Pure_Function on& is redundant?r?",
22009 elsif not Same_Decl then
22011 ("pragma% argument must be in same declarative part",
22017 --------------------
22018 -- Queuing_Policy --
22019 --------------------
22021 -- pragma Queuing_Policy (policy_IDENTIFIER);
22023 when Pragma_Queuing_Policy => declare
22027 Check_Ada_83_Warning;
22028 Check_Arg_Count (1);
22029 Check_No_Identifiers;
22030 Check_Arg_Is_Queuing_Policy (Arg1);
22031 Check_Valid_Configuration_Pragma;
22032 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22033 QP := Fold_Upper (Name_Buffer (1));
22035 if Queuing_Policy /= ' '
22036 and then Queuing_Policy /= QP
22038 Error_Msg_Sloc := Queuing_Policy_Sloc;
22039 Error_Pragma ("queuing policy incompatible with policy#");
22041 -- Set new policy, but always preserve System_Location since we
22042 -- like the error message with the run time name.
22045 Queuing_Policy := QP;
22047 if Queuing_Policy_Sloc /= System_Location then
22048 Queuing_Policy_Sloc := Loc;
22057 -- pragma Rational, for compatibility with foreign compiler
22059 when Pragma_Rational =>
22060 Set_Rational_Profile;
22062 ---------------------
22063 -- Refined_Depends --
22064 ---------------------
22066 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22068 -- DEPENDENCY_RELATION ::=
22070 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22072 -- DEPENDENCY_CLAUSE ::=
22073 -- OUTPUT_LIST =>[+] INPUT_LIST
22074 -- | NULL_DEPENDENCY_CLAUSE
22076 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22078 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22080 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22082 -- OUTPUT ::= NAME | FUNCTION_RESULT
22085 -- where FUNCTION_RESULT is a function Result attribute_reference
22087 -- Characteristics:
22089 -- * Analysis - The annotation undergoes initial checks to verify
22090 -- the legal placement and context. Secondary checks fully analyze
22091 -- the dependency clauses/global list in:
22093 -- Analyze_Refined_Depends_In_Decl_Part
22095 -- * Expansion - None.
22097 -- * Template - The annotation utilizes the generic template of the
22098 -- related subprogram body.
22100 -- * Globals - Capture of global references must occur after full
22103 -- * Instance - The annotation is instantiated automatically when
22104 -- the related generic subprogram body is instantiated.
22106 when Pragma_Refined_Depends => Refined_Depends : declare
22107 Body_Id : Entity_Id;
22109 Spec_Id : Entity_Id;
22112 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22116 -- Chain the pragma on the contract for further processing by
22117 -- Analyze_Refined_Depends_In_Decl_Part.
22119 Add_Contract_Item (N, Body_Id);
22121 -- The legality checks of pragmas Refined_Depends and
22122 -- Refined_Global are affected by the SPARK mode in effect and
22123 -- the volatility of the context. In addition these two pragmas
22124 -- are subject to an inherent order:
22126 -- 1) Refined_Global
22127 -- 2) Refined_Depends
22129 -- Analyze all these pragmas in the order outlined above
22131 Analyze_If_Present (Pragma_SPARK_Mode);
22132 Analyze_If_Present (Pragma_Volatile_Function);
22133 Analyze_If_Present (Pragma_Refined_Global);
22134 Analyze_Refined_Depends_In_Decl_Part (N);
22136 end Refined_Depends;
22138 --------------------
22139 -- Refined_Global --
22140 --------------------
22142 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22144 -- GLOBAL_SPECIFICATION ::=
22147 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22149 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22151 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22152 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22153 -- GLOBAL_ITEM ::= NAME
22155 -- Characteristics:
22157 -- * Analysis - The annotation undergoes initial checks to verify
22158 -- the legal placement and context. Secondary checks fully analyze
22159 -- the dependency clauses/global list in:
22161 -- Analyze_Refined_Global_In_Decl_Part
22163 -- * Expansion - None.
22165 -- * Template - The annotation utilizes the generic template of the
22166 -- related subprogram body.
22168 -- * Globals - Capture of global references must occur after full
22171 -- * Instance - The annotation is instantiated automatically when
22172 -- the related generic subprogram body is instantiated.
22174 when Pragma_Refined_Global => Refined_Global : declare
22175 Body_Id : Entity_Id;
22177 Spec_Id : Entity_Id;
22180 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22184 -- Chain the pragma on the contract for further processing by
22185 -- Analyze_Refined_Global_In_Decl_Part.
22187 Add_Contract_Item (N, Body_Id);
22189 -- The legality checks of pragmas Refined_Depends and
22190 -- Refined_Global are affected by the SPARK mode in effect and
22191 -- the volatility of the context. In addition these two pragmas
22192 -- are subject to an inherent order:
22194 -- 1) Refined_Global
22195 -- 2) Refined_Depends
22197 -- Analyze all these pragmas in the order outlined above
22199 Analyze_If_Present (Pragma_SPARK_Mode);
22200 Analyze_If_Present (Pragma_Volatile_Function);
22201 Analyze_Refined_Global_In_Decl_Part (N);
22202 Analyze_If_Present (Pragma_Refined_Depends);
22204 end Refined_Global;
22210 -- pragma Refined_Post (boolean_EXPRESSION);
22212 -- Characteristics:
22214 -- * Analysis - The annotation is fully analyzed immediately upon
22215 -- elaboration as it cannot forward reference entities.
22217 -- * Expansion - The annotation is expanded during the expansion of
22218 -- the related subprogram body contract as performed in:
22220 -- Expand_Subprogram_Contract
22222 -- * Template - The annotation utilizes the generic template of the
22223 -- related subprogram body.
22225 -- * Globals - Capture of global references must occur after full
22228 -- * Instance - The annotation is instantiated automatically when
22229 -- the related generic subprogram body is instantiated.
22231 when Pragma_Refined_Post => Refined_Post : declare
22232 Body_Id : Entity_Id;
22234 Spec_Id : Entity_Id;
22237 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22239 -- Fully analyze the pragma when it appears inside a subprogram
22240 -- body because it cannot benefit from forward references.
22244 -- Chain the pragma on the contract for completeness
22246 Add_Contract_Item (N, Body_Id);
22248 -- The legality checks of pragma Refined_Post are affected by
22249 -- the SPARK mode in effect and the volatility of the context.
22250 -- Analyze all pragmas in a specific order.
22252 Analyze_If_Present (Pragma_SPARK_Mode);
22253 Analyze_If_Present (Pragma_Volatile_Function);
22254 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22256 -- Currently it is not possible to inline pre/postconditions on
22257 -- a subprogram subject to pragma Inline_Always.
22259 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22263 -------------------
22264 -- Refined_State --
22265 -------------------
22267 -- pragma Refined_State (REFINEMENT_LIST);
22269 -- REFINEMENT_LIST ::=
22270 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22272 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22274 -- CONSTITUENT_LIST ::=
22277 -- | (CONSTITUENT {, CONSTITUENT})
22279 -- CONSTITUENT ::= object_NAME | state_NAME
22281 -- Characteristics:
22283 -- * Analysis - The annotation undergoes initial checks to verify
22284 -- the legal placement and context. Secondary checks preanalyze the
22285 -- refinement clauses in:
22287 -- Analyze_Refined_State_In_Decl_Part
22289 -- * Expansion - None.
22291 -- * Template - The annotation utilizes the template of the related
22294 -- * Globals - Capture of global references must occur after full
22297 -- * Instance - The annotation is instantiated automatically when
22298 -- the related generic package body is instantiated.
22300 when Pragma_Refined_State => Refined_State : declare
22301 Pack_Decl : Node_Id;
22302 Spec_Id : Entity_Id;
22306 Check_No_Identifiers;
22307 Check_Arg_Count (1);
22309 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22311 if Nkind (Pack_Decl) /= N_Package_Body then
22316 Spec_Id := Corresponding_Spec (Pack_Decl);
22318 -- A pragma that applies to a Ghost entity becomes Ghost for the
22319 -- purposes of legality checks and removal of ignored Ghost code.
22321 Mark_Ghost_Pragma (N, Spec_Id);
22323 -- Chain the pragma on the contract for further processing by
22324 -- Analyze_Refined_State_In_Decl_Part.
22326 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22328 -- The legality checks of pragma Refined_State are affected by the
22329 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22331 Analyze_If_Present (Pragma_SPARK_Mode);
22333 -- State refinement is allowed only when the corresponding package
22334 -- declaration has non-null pragma Abstract_State. Refinement not
22335 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22337 if SPARK_Mode /= Off
22339 (No (Abstract_States (Spec_Id))
22340 or else Has_Null_Abstract_State (Spec_Id))
22343 ("useless refinement, package & does not define abstract "
22344 & "states", N, Spec_Id);
22349 -----------------------
22350 -- Relative_Deadline --
22351 -----------------------
22353 -- pragma Relative_Deadline (time_span_EXPRESSION);
22355 when Pragma_Relative_Deadline => Relative_Deadline : declare
22356 P : constant Node_Id := Parent (N);
22361 Check_No_Identifiers;
22362 Check_Arg_Count (1);
22364 Arg := Get_Pragma_Arg (Arg1);
22366 -- The expression must be analyzed in the special manner described
22367 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22369 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22373 if Nkind (P) = N_Subprogram_Body then
22374 Check_In_Main_Program;
22376 -- Only Task and subprogram cases allowed
22378 elsif Nkind (P) /= N_Task_Definition then
22382 -- Check duplicate pragma before we set the corresponding flag
22384 if Has_Relative_Deadline_Pragma (P) then
22385 Error_Pragma ("duplicate pragma% not allowed");
22388 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22389 -- Relative_Deadline pragma node cannot be inserted in the Rep
22390 -- Item chain of Ent since it is rewritten by the expander as a
22391 -- procedure call statement that will break the chain.
22393 Set_Has_Relative_Deadline_Pragma (P);
22394 end Relative_Deadline;
22396 ------------------------
22397 -- Remote_Access_Type --
22398 ------------------------
22400 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22402 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22407 Check_Arg_Count (1);
22408 Check_Optional_Identifier (Arg1, Name_Entity);
22409 Check_Arg_Is_Local_Name (Arg1);
22411 E := Entity (Get_Pragma_Arg (Arg1));
22413 -- A pragma that applies to a Ghost entity becomes Ghost for the
22414 -- purposes of legality checks and removal of ignored Ghost code.
22416 Mark_Ghost_Pragma (N, E);
22418 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22419 and then Ekind (E) = E_General_Access_Type
22420 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22421 and then Scope (Root_Type (Directly_Designated_Type (E)))
22423 and then Is_Valid_Remote_Object_Type
22424 (Root_Type (Directly_Designated_Type (E)))
22426 Set_Is_Remote_Types (E);
22430 ("pragma% applies only to formal access-to-class-wide types",
22433 end Remote_Access_Type;
22435 ---------------------------
22436 -- Remote_Call_Interface --
22437 ---------------------------
22439 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22441 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22442 Cunit_Node : Node_Id;
22443 Cunit_Ent : Entity_Id;
22447 Check_Ada_83_Warning;
22448 Check_Valid_Library_Unit_Pragma;
22450 Cunit_Node := Cunit (Current_Sem_Unit);
22451 K := Nkind (Unit (Cunit_Node));
22452 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22454 -- A pragma that applies to a Ghost entity becomes Ghost for the
22455 -- purposes of legality checks and removal of ignored Ghost code.
22457 Mark_Ghost_Pragma (N, Cunit_Ent);
22459 if K = N_Package_Declaration
22460 or else K = N_Generic_Package_Declaration
22461 or else K = N_Subprogram_Declaration
22462 or else K = N_Generic_Subprogram_Declaration
22463 or else (K = N_Subprogram_Body
22464 and then Acts_As_Spec (Unit (Cunit_Node)))
22469 "pragma% must apply to package or subprogram declaration");
22472 Set_Is_Remote_Call_Interface (Cunit_Ent);
22473 end Remote_Call_Interface;
22479 -- pragma Remote_Types [(library_unit_NAME)];
22481 when Pragma_Remote_Types => Remote_Types : declare
22482 Cunit_Node : Node_Id;
22483 Cunit_Ent : Entity_Id;
22486 Check_Ada_83_Warning;
22487 Check_Valid_Library_Unit_Pragma;
22489 Cunit_Node := Cunit (Current_Sem_Unit);
22490 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22492 -- A pragma that applies to a Ghost entity becomes Ghost for the
22493 -- purposes of legality checks and removal of ignored Ghost code.
22495 Mark_Ghost_Pragma (N, Cunit_Ent);
22497 if Nkind (Unit (Cunit_Node)) not in
22498 N_Package_Declaration | N_Generic_Package_Declaration
22501 ("pragma% can only apply to a package declaration");
22504 Set_Is_Remote_Types (Cunit_Ent);
22511 -- pragma Ravenscar;
22513 when Pragma_Ravenscar =>
22515 Check_Arg_Count (0);
22516 Check_Valid_Configuration_Pragma;
22517 Set_Ravenscar_Profile (Ravenscar, N);
22519 if Warn_On_Obsolescent_Feature then
22521 ("pragma Ravenscar is an obsolescent feature?j?", N);
22523 ("|use pragma Profile (Ravenscar) instead?j?", N);
22526 -------------------------
22527 -- Restricted_Run_Time --
22528 -------------------------
22530 -- pragma Restricted_Run_Time;
22532 when Pragma_Restricted_Run_Time =>
22534 Check_Arg_Count (0);
22535 Check_Valid_Configuration_Pragma;
22536 Set_Profile_Restrictions
22537 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22539 if Warn_On_Obsolescent_Feature then
22541 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22544 ("|use pragma Profile (Restricted) instead?j?", N);
22551 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22554 -- restriction_IDENTIFIER
22555 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22557 when Pragma_Restrictions =>
22558 Process_Restrictions_Or_Restriction_Warnings
22559 (Warn => Treat_Restrictions_As_Warnings);
22561 --------------------------
22562 -- Restriction_Warnings --
22563 --------------------------
22565 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22568 -- restriction_IDENTIFIER
22569 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22571 when Pragma_Restriction_Warnings =>
22573 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22579 -- pragma Reviewable;
22581 when Pragma_Reviewable =>
22582 Check_Ada_83_Warning;
22583 Check_Arg_Count (0);
22585 -- Call dummy debugging function rv. This is done to assist front
22586 -- end debugging. By placing a Reviewable pragma in the source
22587 -- program, a breakpoint on rv catches this place in the source,
22588 -- allowing convenient stepping to the point of interest.
22592 --------------------------
22593 -- Secondary_Stack_Size --
22594 --------------------------
22596 -- pragma Secondary_Stack_Size (EXPRESSION);
22598 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22599 P : constant Node_Id := Parent (N);
22605 Check_No_Identifiers;
22606 Check_Arg_Count (1);
22608 if Nkind (P) = N_Task_Definition then
22609 Arg := Get_Pragma_Arg (Arg1);
22610 Ent := Defining_Identifier (Parent (P));
22612 -- The expression must be analyzed in the special manner
22613 -- described in "Handling of Default Expressions" in sem.ads.
22615 Preanalyze_Spec_Expression (Arg, Any_Integer);
22617 -- The pragma cannot appear if the No_Secondary_Stack
22618 -- restriction is in effect.
22620 Check_Restriction (No_Secondary_Stack, Arg);
22622 -- Anything else is incorrect
22628 -- Check duplicate pragma before we chain the pragma in the Rep
22629 -- Item chain of Ent.
22631 Check_Duplicate_Pragma (Ent);
22632 Record_Rep_Item (Ent, N);
22633 end Secondary_Stack_Size;
22635 --------------------------
22636 -- Short_Circuit_And_Or --
22637 --------------------------
22639 -- pragma Short_Circuit_And_Or;
22641 when Pragma_Short_Circuit_And_Or =>
22643 Check_Arg_Count (0);
22644 Check_Valid_Configuration_Pragma;
22645 Short_Circuit_And_Or := True;
22647 -------------------
22648 -- Share_Generic --
22649 -------------------
22651 -- pragma Share_Generic (GNAME {, GNAME});
22653 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22655 when Pragma_Share_Generic =>
22657 Process_Generic_List;
22663 -- pragma Shared (LOCAL_NAME);
22665 when Pragma_Shared =>
22667 Process_Atomic_Independent_Shared_Volatile;
22669 --------------------
22670 -- Shared_Passive --
22671 --------------------
22673 -- pragma Shared_Passive [(library_unit_NAME)];
22675 -- Set the flag Is_Shared_Passive of program unit name entity
22677 when Pragma_Shared_Passive => Shared_Passive : declare
22678 Cunit_Node : Node_Id;
22679 Cunit_Ent : Entity_Id;
22682 Check_Ada_83_Warning;
22683 Check_Valid_Library_Unit_Pragma;
22685 Cunit_Node := Cunit (Current_Sem_Unit);
22686 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22688 -- A pragma that applies to a Ghost entity becomes Ghost for the
22689 -- purposes of legality checks and removal of ignored Ghost code.
22691 Mark_Ghost_Pragma (N, Cunit_Ent);
22693 if Nkind (Unit (Cunit_Node)) not in
22694 N_Package_Declaration | N_Generic_Package_Declaration
22697 ("pragma% can only apply to a package declaration");
22700 Set_Is_Shared_Passive (Cunit_Ent);
22701 end Shared_Passive;
22703 -----------------------
22704 -- Short_Descriptors --
22705 -----------------------
22707 -- pragma Short_Descriptors;
22709 -- Recognize and validate, but otherwise ignore
22711 when Pragma_Short_Descriptors =>
22713 Check_Arg_Count (0);
22714 Check_Valid_Configuration_Pragma;
22716 ------------------------------
22717 -- Simple_Storage_Pool_Type --
22718 ------------------------------
22720 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22722 when Pragma_Simple_Storage_Pool_Type =>
22723 Simple_Storage_Pool_Type : declare
22729 Check_Arg_Count (1);
22730 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22732 Type_Id := Get_Pragma_Arg (Arg1);
22733 Find_Type (Type_Id);
22734 Typ := Entity (Type_Id);
22736 if Typ = Any_Type then
22740 -- A pragma that applies to a Ghost entity becomes Ghost for the
22741 -- purposes of legality checks and removal of ignored Ghost code.
22743 Mark_Ghost_Pragma (N, Typ);
22745 -- We require the pragma to apply to a type declared in a package
22746 -- declaration, but not (immediately) within a package body.
22748 if Ekind (Current_Scope) /= E_Package
22749 or else In_Package_Body (Current_Scope)
22752 ("pragma% can only apply to type declared immediately "
22753 & "within a package declaration");
22756 -- A simple storage pool type must be an immutably limited record
22757 -- or private type. If the pragma is given for a private type,
22758 -- the full type is similarly restricted (which is checked later
22759 -- in Freeze_Entity).
22761 if Is_Record_Type (Typ)
22762 and then not Is_Limited_View (Typ)
22765 ("pragma% can only apply to explicitly limited record type");
22767 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22769 ("pragma% can only apply to a private type that is limited");
22771 elsif not Is_Record_Type (Typ)
22772 and then not Is_Private_Type (Typ)
22775 ("pragma% can only apply to limited record or private type");
22778 Record_Rep_Item (Typ, N);
22779 end Simple_Storage_Pool_Type;
22781 ----------------------
22782 -- Source_File_Name --
22783 ----------------------
22785 -- There are five forms for this pragma:
22787 -- pragma Source_File_Name (
22788 -- [UNIT_NAME =>] unit_NAME,
22789 -- BODY_FILE_NAME => STRING_LITERAL
22790 -- [, [INDEX =>] INTEGER_LITERAL]);
22792 -- pragma Source_File_Name (
22793 -- [UNIT_NAME =>] unit_NAME,
22794 -- SPEC_FILE_NAME => STRING_LITERAL
22795 -- [, [INDEX =>] INTEGER_LITERAL]);
22797 -- pragma Source_File_Name (
22798 -- BODY_FILE_NAME => STRING_LITERAL
22799 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22800 -- [, CASING => CASING_SPEC]);
22802 -- pragma Source_File_Name (
22803 -- SPEC_FILE_NAME => STRING_LITERAL
22804 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22805 -- [, CASING => CASING_SPEC]);
22807 -- pragma Source_File_Name (
22808 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22809 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22810 -- [, CASING => CASING_SPEC]);
22812 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22814 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22815 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22816 -- only be used when no project file is used, while SFNP can only be
22817 -- used when a project file is used.
22819 -- No processing here. Processing was completed during parsing, since
22820 -- we need to have file names set as early as possible. Units are
22821 -- loaded well before semantic processing starts.
22823 -- The only processing we defer to this point is the check for
22824 -- correct placement.
22826 when Pragma_Source_File_Name =>
22828 Check_Valid_Configuration_Pragma;
22830 ------------------------------
22831 -- Source_File_Name_Project --
22832 ------------------------------
22834 -- See Source_File_Name for syntax
22836 -- No processing here. Processing was completed during parsing, since
22837 -- we need to have file names set as early as possible. Units are
22838 -- loaded well before semantic processing starts.
22840 -- The only processing we defer to this point is the check for
22841 -- correct placement.
22843 when Pragma_Source_File_Name_Project =>
22845 Check_Valid_Configuration_Pragma;
22847 -- Check that a pragma Source_File_Name_Project is used only in a
22848 -- configuration pragmas file.
22850 -- Pragmas Source_File_Name_Project should only be generated by
22851 -- the Project Manager in configuration pragmas files.
22853 -- This is really an ugly test. It seems to depend on some
22854 -- accidental and undocumented property. At the very least it
22855 -- needs to be documented, but it would be better to have a
22856 -- clean way of testing if we are in a configuration file???
22858 if Present (Parent (N)) then
22860 ("pragma% can only appear in a configuration pragmas file");
22863 ----------------------
22864 -- Source_Reference --
22865 ----------------------
22867 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22869 -- Nothing to do, all processing completed in Par.Prag, since we need
22870 -- the information for possible parser messages that are output.
22872 when Pragma_Source_Reference =>
22879 -- pragma SPARK_Mode [(On | Off)];
22881 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22882 Mode_Id : SPARK_Mode_Type;
22884 procedure Check_Pragma_Conformance
22885 (Context_Pragma : Node_Id;
22886 Entity : Entity_Id;
22887 Entity_Pragma : Node_Id);
22888 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22889 -- conformance of pragma N depending the following scenarios:
22891 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22892 -- compatible with the pragma Context_Pragma that was inherited
22893 -- from the context:
22894 -- * If the mode of Context_Pragma is ON, then the new mode can
22896 -- * If the mode of Context_Pragma is OFF, then the only allowed
22897 -- new mode is also OFF. Emit error if this is not the case.
22899 -- If Entity is not Empty, verify that pragma N is compatible with
22900 -- pragma Entity_Pragma that belongs to Entity.
22901 -- * If Entity_Pragma is Empty, always issue an error as this
22902 -- corresponds to the case where a previous section of Entity
22903 -- has no SPARK_Mode set.
22904 -- * If the mode of Entity_Pragma is ON, then the new mode can
22906 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22907 -- new mode is also OFF. Emit error if this is not the case.
22909 procedure Check_Library_Level_Entity (E : Entity_Id);
22910 -- Subsidiary to routines Process_xxx. Verify that the related
22911 -- entity E subject to pragma SPARK_Mode is library-level.
22913 procedure Process_Body (Decl : Node_Id);
22914 -- Verify the legality of pragma SPARK_Mode when it appears as the
22915 -- top of the body declarations of entry, package, protected unit,
22916 -- subprogram or task unit body denoted by Decl.
22918 procedure Process_Overloadable (Decl : Node_Id);
22919 -- Verify the legality of pragma SPARK_Mode when it applies to an
22920 -- entry or [generic] subprogram declaration denoted by Decl.
22922 procedure Process_Private_Part (Decl : Node_Id);
22923 -- Verify the legality of pragma SPARK_Mode when it appears at the
22924 -- top of the private declarations of a package spec, protected or
22925 -- task unit declaration denoted by Decl.
22927 procedure Process_Statement_Part (Decl : Node_Id);
22928 -- Verify the legality of pragma SPARK_Mode when it appears at the
22929 -- top of the statement sequence of a package body denoted by node
22932 procedure Process_Visible_Part (Decl : Node_Id);
22933 -- Verify the legality of pragma SPARK_Mode when it appears at the
22934 -- top of the visible declarations of a package spec, protected or
22935 -- task unit declaration denoted by Decl. The routine is also used
22936 -- on protected or task units declared without a definition.
22938 procedure Set_SPARK_Context;
22939 -- Subsidiary to routines Process_xxx. Set the global variables
22940 -- which represent the mode of the context from pragma N. Ensure
22941 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22943 ------------------------------
22944 -- Check_Pragma_Conformance --
22945 ------------------------------
22947 procedure Check_Pragma_Conformance
22948 (Context_Pragma : Node_Id;
22949 Entity : Entity_Id;
22950 Entity_Pragma : Node_Id)
22952 Err_Id : Entity_Id;
22956 -- The current pragma may appear without an argument. If this
22957 -- is the case, associate all error messages with the pragma
22960 if Present (Arg1) then
22966 -- The mode of the current pragma is compared against that of
22967 -- an enclosing context.
22969 if Present (Context_Pragma) then
22970 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22972 -- Issue an error if the new mode is less restrictive than
22973 -- that of the context.
22975 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
22976 and then Get_SPARK_Mode_From_Annotation (N) = On
22979 ("cannot change SPARK_Mode from Off to On", Err_N);
22980 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
22981 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
22986 -- The mode of the current pragma is compared against that of
22987 -- an initial package, protected type, subprogram or task type
22990 if Present (Entity) then
22992 -- A simple protected or task type is transformed into an
22993 -- anonymous type whose name cannot be used to issue error
22994 -- messages. Recover the original entity of the type.
22996 if Ekind (Entity) in E_Protected_Type | E_Task_Type then
22999 (Original_Node (Unit_Declaration_Node (Entity)));
23004 -- Both the initial declaration and the completion carry
23005 -- SPARK_Mode pragmas.
23007 if Present (Entity_Pragma) then
23008 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23010 -- Issue an error if the new mode is less restrictive
23011 -- than that of the initial declaration.
23013 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23014 and then Get_SPARK_Mode_From_Annotation (N) = On
23016 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23017 Error_Msg_Sloc := Sloc (Entity_Pragma);
23019 ("\value Off was set for SPARK_Mode on&#",
23024 -- Otherwise the initial declaration lacks a SPARK_Mode
23025 -- pragma in which case the current pragma is illegal as
23026 -- it cannot "complete".
23028 elsif Get_SPARK_Mode_From_Annotation (N) = Off
23029 and then (Is_Generic_Unit (Entity) or else In_Instance)
23034 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23035 Error_Msg_Sloc := Sloc (Err_Id);
23037 ("\no value was set for SPARK_Mode on&#",
23042 end Check_Pragma_Conformance;
23044 --------------------------------
23045 -- Check_Library_Level_Entity --
23046 --------------------------------
23048 procedure Check_Library_Level_Entity (E : Entity_Id) is
23049 procedure Add_Entity_To_Name_Buffer;
23050 -- Add the E_Kind of entity E to the name buffer
23052 -------------------------------
23053 -- Add_Entity_To_Name_Buffer --
23054 -------------------------------
23056 procedure Add_Entity_To_Name_Buffer is
23058 if Ekind (E) in E_Entry | E_Entry_Family then
23059 Add_Str_To_Name_Buffer ("entry");
23061 elsif Ekind (E) in E_Generic_Package
23065 Add_Str_To_Name_Buffer ("package");
23067 elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
23068 Add_Str_To_Name_Buffer ("protected type");
23070 elsif Ekind (E) in E_Function
23071 | E_Generic_Function
23072 | E_Generic_Procedure
23074 | E_Subprogram_Body
23076 Add_Str_To_Name_Buffer ("subprogram");
23079 pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
23080 Add_Str_To_Name_Buffer ("task type");
23082 end Add_Entity_To_Name_Buffer;
23086 Msg_1 : constant String := "incorrect placement of pragma%";
23089 -- Start of processing for Check_Library_Level_Entity
23092 -- A SPARK_Mode of On shall only apply to library-level
23093 -- entities, except for those in generic instances, which are
23094 -- ignored (even if the entity gets SPARK_Mode pragma attached
23095 -- in the AST, its effect is not taken into account unless the
23096 -- context already provides SPARK_Mode of On in GNATprove).
23098 if Get_SPARK_Mode_From_Annotation (N) = On
23099 and then not Is_Library_Level_Entity (E)
23100 and then Instantiation_Location (Sloc (N)) = No_Location
23102 Error_Msg_Name_1 := Pname;
23103 Error_Msg_N (Fix_Error (Msg_1), N);
23106 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23107 Add_Entity_To_Name_Buffer;
23109 Msg_2 := Name_Find;
23110 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23114 end Check_Library_Level_Entity;
23120 procedure Process_Body (Decl : Node_Id) is
23121 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23122 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23125 -- Ignore pragma when applied to the special body created for
23126 -- inlining, recognized by its internal name _Parent.
23128 if Chars (Body_Id) = Name_uParent then
23132 Check_Library_Level_Entity (Body_Id);
23134 -- For entry bodies, verify the legality against:
23135 -- * The mode of the context
23136 -- * The mode of the spec (if any)
23138 if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
23140 -- A stand-alone subprogram body
23142 if Body_Id = Spec_Id then
23143 Check_Pragma_Conformance
23144 (Context_Pragma => SPARK_Pragma (Body_Id),
23146 Entity_Pragma => Empty);
23148 -- An entry or subprogram body that completes a previous
23152 Check_Pragma_Conformance
23153 (Context_Pragma => SPARK_Pragma (Body_Id),
23155 Entity_Pragma => SPARK_Pragma (Spec_Id));
23159 Set_SPARK_Pragma (Body_Id, N);
23160 Set_SPARK_Pragma_Inherited (Body_Id, False);
23162 -- For package bodies, verify the legality against:
23163 -- * The mode of the context
23164 -- * The mode of the private part
23166 -- This case is separated from protected and task bodies
23167 -- because the statement part of the package body inherits
23168 -- the mode of the body declarations.
23170 elsif Nkind (Decl) = N_Package_Body then
23171 Check_Pragma_Conformance
23172 (Context_Pragma => SPARK_Pragma (Body_Id),
23174 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23177 Set_SPARK_Pragma (Body_Id, N);
23178 Set_SPARK_Pragma_Inherited (Body_Id, False);
23179 Set_SPARK_Aux_Pragma (Body_Id, N);
23180 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23182 -- For protected and task bodies, verify the legality against:
23183 -- * The mode of the context
23184 -- * The mode of the private part
23188 (Nkind (Decl) in N_Protected_Body | N_Task_Body);
23190 Check_Pragma_Conformance
23191 (Context_Pragma => SPARK_Pragma (Body_Id),
23193 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23196 Set_SPARK_Pragma (Body_Id, N);
23197 Set_SPARK_Pragma_Inherited (Body_Id, False);
23201 --------------------------
23202 -- Process_Overloadable --
23203 --------------------------
23205 procedure Process_Overloadable (Decl : Node_Id) is
23206 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23207 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23210 Check_Library_Level_Entity (Spec_Id);
23212 -- Verify the legality against:
23213 -- * The mode of the context
23215 Check_Pragma_Conformance
23216 (Context_Pragma => SPARK_Pragma (Spec_Id),
23218 Entity_Pragma => Empty);
23220 Set_SPARK_Pragma (Spec_Id, N);
23221 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23223 -- When the pragma applies to the anonymous object created for
23224 -- a single task type, decorate the type as well. This scenario
23225 -- arises when the single task type lacks a task definition,
23226 -- therefore there is no issue with respect to a potential
23227 -- pragma SPARK_Mode in the private part.
23229 -- task type Anon_Task_Typ;
23230 -- Obj : Anon_Task_Typ;
23231 -- pragma SPARK_Mode ...;
23233 if Is_Single_Task_Object (Spec_Id) then
23234 Set_SPARK_Pragma (Spec_Typ, N);
23235 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23236 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23237 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23239 end Process_Overloadable;
23241 --------------------------
23242 -- Process_Private_Part --
23243 --------------------------
23245 procedure Process_Private_Part (Decl : Node_Id) is
23246 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23249 Check_Library_Level_Entity (Spec_Id);
23251 -- Verify the legality against:
23252 -- * The mode of the visible declarations
23254 Check_Pragma_Conformance
23255 (Context_Pragma => Empty,
23257 Entity_Pragma => SPARK_Pragma (Spec_Id));
23260 Set_SPARK_Aux_Pragma (Spec_Id, N);
23261 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23262 end Process_Private_Part;
23264 ----------------------------
23265 -- Process_Statement_Part --
23266 ----------------------------
23268 procedure Process_Statement_Part (Decl : Node_Id) is
23269 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23272 Check_Library_Level_Entity (Body_Id);
23274 -- Verify the legality against:
23275 -- * The mode of the body declarations
23277 Check_Pragma_Conformance
23278 (Context_Pragma => Empty,
23280 Entity_Pragma => SPARK_Pragma (Body_Id));
23283 Set_SPARK_Aux_Pragma (Body_Id, N);
23284 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23285 end Process_Statement_Part;
23287 --------------------------
23288 -- Process_Visible_Part --
23289 --------------------------
23291 procedure Process_Visible_Part (Decl : Node_Id) is
23292 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23293 Obj_Id : Entity_Id;
23296 Check_Library_Level_Entity (Spec_Id);
23298 -- Verify the legality against:
23299 -- * The mode of the context
23301 Check_Pragma_Conformance
23302 (Context_Pragma => SPARK_Pragma (Spec_Id),
23304 Entity_Pragma => Empty);
23306 -- A task unit declared without a definition does not set the
23307 -- SPARK_Mode of the context because the task does not have any
23308 -- entries that could inherit the mode.
23310 if Nkind (Decl) not in
23311 N_Single_Task_Declaration | N_Task_Type_Declaration
23316 Set_SPARK_Pragma (Spec_Id, N);
23317 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23318 Set_SPARK_Aux_Pragma (Spec_Id, N);
23319 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23321 -- When the pragma applies to a single protected or task type,
23322 -- decorate the corresponding anonymous object as well.
23324 -- protected Anon_Prot_Typ is
23325 -- pragma SPARK_Mode ...;
23327 -- end Anon_Prot_Typ;
23329 -- Obj : Anon_Prot_Typ;
23331 if Is_Single_Concurrent_Type (Spec_Id) then
23332 Obj_Id := Anonymous_Object (Spec_Id);
23334 Set_SPARK_Pragma (Obj_Id, N);
23335 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23337 end Process_Visible_Part;
23339 -----------------------
23340 -- Set_SPARK_Context --
23341 -----------------------
23343 procedure Set_SPARK_Context is
23345 SPARK_Mode := Mode_Id;
23346 SPARK_Mode_Pragma := N;
23347 end Set_SPARK_Context;
23355 -- Start of processing for Do_SPARK_Mode
23359 Check_No_Identifiers;
23360 Check_At_Most_N_Arguments (1);
23362 -- Check the legality of the mode (no argument = ON)
23364 if Arg_Count = 1 then
23365 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23366 Mode := Chars (Get_Pragma_Arg (Arg1));
23371 Mode_Id := Get_SPARK_Mode_Type (Mode);
23372 Context := Parent (N);
23374 -- When a SPARK_Mode pragma appears inside an instantiation whose
23375 -- enclosing context has SPARK_Mode set to "off", the pragma has
23376 -- no semantic effect.
23378 if Ignore_SPARK_Mode_Pragmas_In_Instance
23379 and then Mode_Id /= Off
23381 Rewrite (N, Make_Null_Statement (Loc));
23386 -- The pragma appears in a configuration file
23388 if No (Context) then
23389 Check_Valid_Configuration_Pragma;
23391 if Present (SPARK_Mode_Pragma) then
23394 Prev => SPARK_Mode_Pragma);
23400 -- The pragma acts as a configuration pragma in a compilation unit
23402 -- pragma SPARK_Mode ...;
23403 -- package Pack is ...;
23405 elsif Nkind (Context) = N_Compilation_Unit
23406 and then List_Containing (N) = Context_Items (Context)
23408 Check_Valid_Configuration_Pragma;
23411 -- Otherwise the placement of the pragma within the tree dictates
23412 -- its associated construct. Inspect the declarative list where
23413 -- the pragma resides to find a potential construct.
23417 while Present (Stmt) loop
23419 -- Skip prior pragmas, but check for duplicates. Note that
23420 -- this also takes care of pragmas generated for aspects.
23422 if Nkind (Stmt) = N_Pragma then
23423 if Pragma_Name (Stmt) = Pname then
23430 -- The pragma applies to an expression function that has
23431 -- already been rewritten into a subprogram declaration.
23433 -- function Expr_Func return ... is (...);
23434 -- pragma SPARK_Mode ...;
23436 elsif Nkind (Stmt) = N_Subprogram_Declaration
23437 and then Nkind (Original_Node (Stmt)) =
23438 N_Expression_Function
23440 Process_Overloadable (Stmt);
23443 -- The pragma applies to the anonymous object created for a
23444 -- single concurrent type.
23446 -- protected type Anon_Prot_Typ ...;
23447 -- Obj : Anon_Prot_Typ;
23448 -- pragma SPARK_Mode ...;
23450 elsif Nkind (Stmt) = N_Object_Declaration
23451 and then Is_Single_Concurrent_Object
23452 (Defining_Entity (Stmt))
23454 Process_Overloadable (Stmt);
23457 -- Skip internally generated code
23459 elsif not Comes_From_Source (Stmt) then
23462 -- The pragma applies to an entry or [generic] subprogram
23466 -- pragma SPARK_Mode ...;
23469 -- procedure Proc ...;
23470 -- pragma SPARK_Mode ...;
23472 elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
23473 | N_Subprogram_Declaration
23474 or else (Nkind (Stmt) = N_Entry_Declaration
23475 and then Is_Protected_Type
23476 (Scope (Defining_Entity (Stmt))))
23478 Process_Overloadable (Stmt);
23481 -- Otherwise the pragma does not apply to a legal construct
23482 -- or it does not appear at the top of a declarative or a
23483 -- statement list. Issue an error and stop the analysis.
23493 -- The pragma applies to a package or a subprogram that acts as
23494 -- a compilation unit.
23496 -- procedure Proc ...;
23497 -- pragma SPARK_Mode ...;
23499 if Nkind (Context) = N_Compilation_Unit_Aux then
23500 Context := Unit (Parent (Context));
23503 -- The pragma appears at the top of entry, package, protected
23504 -- unit, subprogram or task unit body declarations.
23506 -- entry Ent when ... is
23507 -- pragma SPARK_Mode ...;
23509 -- package body Pack is
23510 -- pragma SPARK_Mode ...;
23512 -- procedure Proc ... is
23513 -- pragma SPARK_Mode;
23515 -- protected body Prot is
23516 -- pragma SPARK_Mode ...;
23518 if Nkind (Context) in N_Entry_Body
23521 | N_Subprogram_Body
23524 Process_Body (Context);
23526 -- The pragma appears at the top of the visible or private
23527 -- declaration of a package spec, protected or task unit.
23530 -- pragma SPARK_Mode ...;
23532 -- pragma SPARK_Mode ...;
23534 -- protected [type] Prot is
23535 -- pragma SPARK_Mode ...;
23537 -- pragma SPARK_Mode ...;
23539 elsif Nkind (Context) in N_Package_Specification
23540 | N_Protected_Definition
23541 | N_Task_Definition
23543 if List_Containing (N) = Visible_Declarations (Context) then
23544 Process_Visible_Part (Parent (Context));
23546 Process_Private_Part (Parent (Context));
23549 -- The pragma appears at the top of package body statements
23551 -- package body Pack is
23553 -- pragma SPARK_Mode;
23555 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23556 and then Nkind (Parent (Context)) = N_Package_Body
23558 Process_Statement_Part (Parent (Context));
23560 -- The pragma appeared as an aspect of a [generic] subprogram
23561 -- declaration that acts as a compilation unit.
23564 -- procedure Proc ...;
23565 -- pragma SPARK_Mode ...;
23567 elsif Nkind (Context) in N_Generic_Subprogram_Declaration
23568 | N_Subprogram_Declaration
23570 Process_Overloadable (Context);
23572 -- The pragma does not apply to a legal construct, issue error
23580 --------------------------------
23581 -- Static_Elaboration_Desired --
23582 --------------------------------
23584 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23586 when Pragma_Static_Elaboration_Desired =>
23588 Check_At_Most_N_Arguments (1);
23590 if Is_Compilation_Unit (Current_Scope)
23591 and then Ekind (Current_Scope) = E_Package
23593 Set_Static_Elaboration_Desired (Current_Scope, True);
23595 Error_Pragma ("pragma% must apply to a library-level package");
23602 -- pragma Storage_Size (EXPRESSION);
23604 when Pragma_Storage_Size => Storage_Size : declare
23605 P : constant Node_Id := Parent (N);
23609 Check_No_Identifiers;
23610 Check_Arg_Count (1);
23612 -- The expression must be analyzed in the special manner described
23613 -- in "Handling of Default Expressions" in sem.ads.
23615 Arg := Get_Pragma_Arg (Arg1);
23616 Preanalyze_Spec_Expression (Arg, Any_Integer);
23618 if not Is_OK_Static_Expression (Arg) then
23619 Check_Restriction (Static_Storage_Size, Arg);
23622 if Nkind (P) /= N_Task_Definition then
23627 if Has_Storage_Size_Pragma (P) then
23628 Error_Pragma ("duplicate pragma% not allowed");
23630 Set_Has_Storage_Size_Pragma (P, True);
23633 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23641 -- pragma Storage_Unit (NUMERIC_LITERAL);
23643 -- Only permitted argument is System'Storage_Unit value
23645 when Pragma_Storage_Unit =>
23646 Check_No_Identifiers;
23647 Check_Arg_Count (1);
23648 Check_Arg_Is_Integer_Literal (Arg1);
23650 if Intval (Get_Pragma_Arg (Arg1)) /=
23651 UI_From_Int (Ttypes.System_Storage_Unit)
23653 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23655 ("the only allowed argument for pragma% is ^", Arg1);
23658 --------------------
23659 -- Stream_Convert --
23660 --------------------
23662 -- pragma Stream_Convert (
23663 -- [Entity =>] type_LOCAL_NAME,
23664 -- [Read =>] function_NAME,
23665 -- [Write =>] function NAME);
23667 when Pragma_Stream_Convert => Stream_Convert : declare
23668 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23669 -- Check that the given argument is the name of a local function
23670 -- of one argument that is not overloaded earlier in the current
23671 -- local scope. A check is also made that the argument is a
23672 -- function with one parameter.
23674 --------------------------------------
23675 -- Check_OK_Stream_Convert_Function --
23676 --------------------------------------
23678 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23682 Check_Arg_Is_Local_Name (Arg);
23683 Ent := Entity (Get_Pragma_Arg (Arg));
23685 if Has_Homonym (Ent) then
23687 ("argument for pragma% may not be overloaded", Arg);
23690 if Ekind (Ent) /= E_Function
23691 or else No (First_Formal (Ent))
23692 or else Present (Next_Formal (First_Formal (Ent)))
23695 ("argument for pragma% must be function of one argument",
23697 elsif Is_Abstract_Subprogram (Ent) then
23699 ("argument for pragma% cannot be abstract", Arg);
23701 end Check_OK_Stream_Convert_Function;
23703 -- Start of processing for Stream_Convert
23707 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23708 Check_Arg_Count (3);
23709 Check_Optional_Identifier (Arg1, Name_Entity);
23710 Check_Optional_Identifier (Arg2, Name_Read);
23711 Check_Optional_Identifier (Arg3, Name_Write);
23712 Check_Arg_Is_Local_Name (Arg1);
23713 Check_OK_Stream_Convert_Function (Arg2);
23714 Check_OK_Stream_Convert_Function (Arg3);
23717 Typ : constant Entity_Id :=
23718 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23719 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23720 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23723 Check_First_Subtype (Arg1);
23725 -- Check for too early or too late. Note that we don't enforce
23726 -- the rule about primitive operations in this case, since, as
23727 -- is the case for explicit stream attributes themselves, these
23728 -- restrictions are not appropriate. Note that the chaining of
23729 -- the pragma by Rep_Item_Too_Late is actually the critical
23730 -- processing done for this pragma.
23732 if Rep_Item_Too_Early (Typ, N)
23734 Rep_Item_Too_Late (Typ, N, FOnly => True)
23739 -- Return if previous error
23741 if Etype (Typ) = Any_Type
23743 Etype (Read) = Any_Type
23745 Etype (Write) = Any_Type
23752 if Underlying_Type (Etype (Read)) /= Typ then
23754 ("incorrect return type for function&", Arg2);
23757 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23759 ("incorrect parameter type for function&", Arg3);
23762 if Underlying_Type (Etype (First_Formal (Read))) /=
23763 Underlying_Type (Etype (Write))
23766 ("result type of & does not match Read parameter type",
23770 end Stream_Convert;
23776 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23778 -- This is processed by the parser since some of the style checks
23779 -- take place during source scanning and parsing. This means that
23780 -- we don't need to issue error messages here.
23782 when Pragma_Style_Checks => Style_Checks : declare
23783 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23789 Check_No_Identifiers;
23791 -- Two argument form
23793 if Arg_Count = 2 then
23794 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23801 E_Id := Get_Pragma_Arg (Arg2);
23804 if not Is_Entity_Name (E_Id) then
23806 ("second argument of pragma% must be entity name",
23810 E := Entity (E_Id);
23812 if not Ignore_Style_Checks_Pragmas then
23817 Set_Suppress_Style_Checks
23818 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23819 exit when No (Homonym (E));
23826 -- One argument form
23829 Check_Arg_Count (1);
23831 if Nkind (A) = N_String_Literal then
23835 Slen : constant Natural := Natural (String_Length (S));
23836 Options : String (1 .. Slen);
23842 C := Get_String_Char (S, Pos (J));
23843 exit when not In_Character_Range (C);
23844 Options (J) := Get_Character (C);
23846 -- If at end of string, set options. As per discussion
23847 -- above, no need to check for errors, since we issued
23848 -- them in the parser.
23851 if not Ignore_Style_Checks_Pragmas then
23852 Set_Style_Check_Options (Options);
23862 elsif Nkind (A) = N_Identifier then
23863 if Chars (A) = Name_All_Checks then
23864 if not Ignore_Style_Checks_Pragmas then
23866 Set_GNAT_Style_Check_Options;
23868 Set_Default_Style_Check_Options;
23872 elsif Chars (A) = Name_On then
23873 if not Ignore_Style_Checks_Pragmas then
23874 Style_Check := True;
23877 elsif Chars (A) = Name_Off then
23878 if not Ignore_Style_Checks_Pragmas then
23879 Style_Check := False;
23886 ------------------------
23887 -- Subprogram_Variant --
23888 ------------------------
23890 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM
23891 -- {, SUBPROGRAM_VARIANT_ITEM } );
23893 -- SUBPROGRAM_VARIANT_ITEM ::=
23894 -- CHANGE_DIRECTION => discrete_EXPRESSION
23896 -- CHANGE_DIRECTION ::= Increases | Decreases
23898 -- Characteristics:
23900 -- * Analysis - The annotation undergoes initial checks to verify
23901 -- the legal placement and context. Secondary checks preanalyze the
23904 -- Analyze_Subprogram_Variant_In_Decl_Part
23906 -- * Expansion - The annotation is expanded during the expansion of
23907 -- the related subprogram [body] contract as performed in:
23909 -- Expand_Subprogram_Contract
23911 -- * Template - The annotation utilizes the generic template of the
23912 -- related subprogram [body] when it is:
23914 -- aspect on subprogram declaration
23915 -- aspect on stand-alone subprogram body
23916 -- pragma on stand-alone subprogram body
23918 -- The annotation must prepare its own template when it is:
23920 -- pragma on subprogram declaration
23922 -- * Globals - Capture of global references must occur after full
23925 -- * Instance - The annotation is instantiated automatically when
23926 -- the related generic subprogram [body] is instantiated except for
23927 -- the "pragma on subprogram declaration" case. In that scenario
23928 -- the annotation must instantiate itself.
23930 when Pragma_Subprogram_Variant => Subprogram_Variant : declare
23931 Spec_Id : Entity_Id;
23932 Subp_Decl : Node_Id;
23933 Subp_Spec : Node_Id;
23937 Check_No_Identifiers;
23938 Check_Arg_Count (1);
23940 -- Ensure the proper placement of the pragma. Subprogram_Variant
23941 -- must be associated with a subprogram declaration or a body that
23945 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23947 -- Generic subprogram
23949 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23952 -- Body acts as spec
23954 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23955 and then No (Corresponding_Spec (Subp_Decl))
23959 -- Body stub acts as spec
23961 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23962 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23968 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23969 Subp_Spec := Specification (Subp_Decl);
23971 -- Pragma Subprogram_Variant is forbidden on null procedures,
23972 -- as this may lead to potential ambiguities in behavior when
23973 -- interface null procedures are involved. Also, it just
23974 -- wouldn't make sense, because null procedure is not
23977 if Nkind (Subp_Spec) = N_Procedure_Specification
23978 and then Null_Present (Subp_Spec)
23980 Error_Msg_N (Fix_Error
23981 ("pragma % cannot apply to null procedure"), N);
23990 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23992 -- A pragma that applies to a Ghost entity becomes Ghost for the
23993 -- purposes of legality checks and removal of ignored Ghost code.
23995 Mark_Ghost_Pragma (N, Spec_Id);
23996 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
23998 -- Chain the pragma on the contract for further processing by
23999 -- Analyze_Subprogram_Variant_In_Decl_Part.
24001 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
24003 -- Fully analyze the pragma when it appears inside a subprogram
24004 -- body because it cannot benefit from forward references.
24006 if Nkind (Subp_Decl) in N_Subprogram_Body
24007 | N_Subprogram_Body_Stub
24009 -- The legality checks of pragma Subprogram_Variant are
24010 -- affected by the SPARK mode in effect and the volatility
24011 -- of the context. Analyze all pragmas in a specific order.
24013 Analyze_If_Present (Pragma_SPARK_Mode);
24014 Analyze_If_Present (Pragma_Volatile_Function);
24015 Analyze_Subprogram_Variant_In_Decl_Part (N);
24017 end Subprogram_Variant;
24023 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24025 when Pragma_Subtitle =>
24027 Check_Arg_Count (1);
24028 Check_Optional_Identifier (Arg1, Name_Subtitle);
24029 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24036 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24038 when Pragma_Suppress =>
24039 Process_Suppress_Unsuppress (Suppress_Case => True);
24045 -- pragma Suppress_All;
24047 -- The only check made here is that the pragma has no arguments.
24048 -- There are no placement rules, and the processing required (setting
24049 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24050 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24051 -- then creates and inserts a pragma Suppress (All_Checks).
24053 when Pragma_Suppress_All =>
24055 Check_Arg_Count (0);
24057 -------------------------
24058 -- Suppress_Debug_Info --
24059 -------------------------
24061 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24063 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24064 Nam_Id : Entity_Id;
24068 Check_Arg_Count (1);
24069 Check_Optional_Identifier (Arg1, Name_Entity);
24070 Check_Arg_Is_Local_Name (Arg1);
24072 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24074 -- A pragma that applies to a Ghost entity becomes Ghost for the
24075 -- purposes of legality checks and removal of ignored Ghost code.
24077 Mark_Ghost_Pragma (N, Nam_Id);
24078 Set_Debug_Info_Off (Nam_Id);
24079 end Suppress_Debug_Info;
24081 ----------------------------------
24082 -- Suppress_Exception_Locations --
24083 ----------------------------------
24085 -- pragma Suppress_Exception_Locations;
24087 when Pragma_Suppress_Exception_Locations =>
24089 Check_Arg_Count (0);
24090 Check_Valid_Configuration_Pragma;
24091 Exception_Locations_Suppressed := True;
24093 -----------------------------
24094 -- Suppress_Initialization --
24095 -----------------------------
24097 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24099 when Pragma_Suppress_Initialization => Suppress_Init : declare
24105 Check_Arg_Count (1);
24106 Check_Optional_Identifier (Arg1, Name_Entity);
24107 Check_Arg_Is_Local_Name (Arg1);
24109 E_Id := Get_Pragma_Arg (Arg1);
24111 if Etype (E_Id) = Any_Type then
24115 E := Entity (E_Id);
24117 -- A pragma that applies to a Ghost entity becomes Ghost for the
24118 -- purposes of legality checks and removal of ignored Ghost code.
24120 Mark_Ghost_Pragma (N, E);
24122 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24124 ("pragma% requires variable, type or subtype", Arg1);
24127 if Rep_Item_Too_Early (E, N)
24129 Rep_Item_Too_Late (E, N, FOnly => True)
24134 -- For incomplete/private type, set flag on full view
24136 if Is_Incomplete_Or_Private_Type (E) then
24137 if No (Full_View (Base_Type (E))) then
24139 ("argument of pragma% cannot be an incomplete type", Arg1);
24141 Set_Suppress_Initialization (Full_View (E));
24144 -- For first subtype, set flag on base type
24146 elsif Is_First_Subtype (E) then
24147 Set_Suppress_Initialization (Base_Type (E));
24149 -- For other than first subtype, set flag on subtype or variable
24152 Set_Suppress_Initialization (E);
24160 -- pragma System_Name (DIRECT_NAME);
24162 -- Syntax check: one argument, which must be the identifier GNAT or
24163 -- the identifier GCC, no other identifiers are acceptable.
24165 when Pragma_System_Name =>
24167 Check_No_Identifiers;
24168 Check_Arg_Count (1);
24169 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24171 -----------------------------
24172 -- Task_Dispatching_Policy --
24173 -----------------------------
24175 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24177 when Pragma_Task_Dispatching_Policy => declare
24181 Check_Ada_83_Warning;
24182 Check_Arg_Count (1);
24183 Check_No_Identifiers;
24184 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24185 Check_Valid_Configuration_Pragma;
24186 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24187 DP := Fold_Upper (Name_Buffer (1));
24189 if Task_Dispatching_Policy /= ' '
24190 and then Task_Dispatching_Policy /= DP
24192 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24194 ("task dispatching policy incompatible with policy#");
24196 -- Set new policy, but always preserve System_Location since we
24197 -- like the error message with the run time name.
24200 Task_Dispatching_Policy := DP;
24202 if Task_Dispatching_Policy_Sloc /= System_Location then
24203 Task_Dispatching_Policy_Sloc := Loc;
24212 -- pragma Task_Info (EXPRESSION);
24214 when Pragma_Task_Info => Task_Info : declare
24215 P : constant Node_Id := Parent (N);
24221 if Warn_On_Obsolescent_Feature then
24223 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24224 & "instead?j?", N);
24227 if Nkind (P) /= N_Task_Definition then
24228 Error_Pragma ("pragma% must appear in task definition");
24231 Check_No_Identifiers;
24232 Check_Arg_Count (1);
24234 Analyze_And_Resolve
24235 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24237 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24241 Ent := Defining_Identifier (Parent (P));
24243 -- Check duplicate pragma before we chain the pragma in the Rep
24244 -- Item chain of Ent.
24247 (Ent, Name_Task_Info, Check_Parents => False)
24249 Error_Pragma ("duplicate pragma% not allowed");
24252 Record_Rep_Item (Ent, N);
24259 -- pragma Task_Name (string_EXPRESSION);
24261 when Pragma_Task_Name => Task_Name : declare
24262 P : constant Node_Id := Parent (N);
24267 Check_No_Identifiers;
24268 Check_Arg_Count (1);
24270 Arg := Get_Pragma_Arg (Arg1);
24272 -- The expression is used in the call to Create_Task, and must be
24273 -- expanded there, not in the context of the current spec. It must
24274 -- however be analyzed to capture global references, in case it
24275 -- appears in a generic context.
24277 Preanalyze_And_Resolve (Arg, Standard_String);
24279 if Nkind (P) /= N_Task_Definition then
24283 Ent := Defining_Identifier (Parent (P));
24285 -- Check duplicate pragma before we chain the pragma in the Rep
24286 -- Item chain of Ent.
24289 (Ent, Name_Task_Name, Check_Parents => False)
24291 Error_Pragma ("duplicate pragma% not allowed");
24294 Record_Rep_Item (Ent, N);
24301 -- pragma Task_Storage (
24302 -- [Task_Type =>] LOCAL_NAME,
24303 -- [Top_Guard =>] static_integer_EXPRESSION);
24305 when Pragma_Task_Storage => Task_Storage : declare
24306 Args : Args_List (1 .. 2);
24307 Names : constant Name_List (1 .. 2) := (
24311 Task_Type : Node_Id renames Args (1);
24312 Top_Guard : Node_Id renames Args (2);
24318 Gather_Associations (Names, Args);
24320 if No (Task_Type) then
24322 ("missing task_type argument for pragma%");
24325 Check_Arg_Is_Local_Name (Task_Type);
24327 Ent := Entity (Task_Type);
24329 if not Is_Task_Type (Ent) then
24331 ("argument for pragma% must be task type", Task_Type);
24334 if No (Top_Guard) then
24336 ("pragma% takes two arguments", Task_Type);
24338 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24341 Check_First_Subtype (Task_Type);
24343 if Rep_Item_Too_Late (Ent, N) then
24352 -- pragma Test_Case
24353 -- ([Name =>] Static_String_EXPRESSION
24354 -- ,[Mode =>] MODE_TYPE
24355 -- [, Requires => Boolean_EXPRESSION]
24356 -- [, Ensures => Boolean_EXPRESSION]);
24358 -- MODE_TYPE ::= Nominal | Robustness
24360 -- Characteristics:
24362 -- * Analysis - The annotation undergoes initial checks to verify
24363 -- the legal placement and context. Secondary checks preanalyze the
24366 -- Analyze_Test_Case_In_Decl_Part
24368 -- * Expansion - None.
24370 -- * Template - The annotation utilizes the generic template of the
24371 -- related subprogram when it is:
24373 -- aspect on subprogram declaration
24375 -- The annotation must prepare its own template when it is:
24377 -- pragma on subprogram declaration
24379 -- * Globals - Capture of global references must occur after full
24382 -- * Instance - The annotation is instantiated automatically when
24383 -- the related generic subprogram is instantiated except for the
24384 -- "pragma on subprogram declaration" case. In that scenario the
24385 -- annotation must instantiate itself.
24387 when Pragma_Test_Case => Test_Case : declare
24388 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24389 -- Ensure that the contract of subprogram Subp_Id does not contain
24390 -- another Test_Case pragma with the same Name as the current one.
24392 -------------------------
24393 -- Check_Distinct_Name --
24394 -------------------------
24396 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24397 Items : constant Node_Id := Contract (Subp_Id);
24398 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24402 -- Inspect all Test_Case pragma of the related subprogram
24403 -- looking for one with a duplicate "Name" argument.
24405 if Present (Items) then
24406 Prag := Contract_Test_Cases (Items);
24407 while Present (Prag) loop
24408 if Pragma_Name (Prag) = Name_Test_Case
24410 and then String_Equal
24411 (Name, Get_Name_From_CTC_Pragma (Prag))
24413 Error_Msg_Sloc := Sloc (Prag);
24414 Error_Pragma ("name for pragma % is already used #");
24417 Prag := Next_Pragma (Prag);
24420 end Check_Distinct_Name;
24424 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24427 Subp_Decl : Node_Id;
24428 Subp_Id : Entity_Id;
24430 -- Start of processing for Test_Case
24434 Check_At_Least_N_Arguments (2);
24435 Check_At_Most_N_Arguments (4);
24437 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24441 Check_Optional_Identifier (Arg1, Name_Name);
24442 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24446 Check_Optional_Identifier (Arg2, Name_Mode);
24447 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24449 -- Arguments "Requires" and "Ensures"
24451 if Present (Arg3) then
24452 if Present (Arg4) then
24453 Check_Identifier (Arg3, Name_Requires);
24454 Check_Identifier (Arg4, Name_Ensures);
24456 Check_Identifier_Is_One_Of
24457 (Arg3, Name_Requires, Name_Ensures);
24461 -- Pragma Test_Case must be associated with a subprogram declared
24462 -- in a library-level package. First determine whether the current
24463 -- compilation unit is a legal context.
24465 if Nkind (Pack_Decl) in N_Package_Declaration
24466 | N_Generic_Package_Declaration
24470 -- Otherwise the placement is illegal
24474 ("pragma % must be specified within a package declaration");
24478 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24480 -- Find the enclosing context
24482 Context := Parent (Subp_Decl);
24484 if Present (Context) then
24485 Context := Parent (Context);
24488 -- Verify the placement of the pragma
24490 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24492 ("pragma % cannot be applied to abstract subprogram");
24495 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24496 Error_Pragma ("pragma % cannot be applied to entry");
24499 -- The context is a [generic] subprogram declared at the top level
24500 -- of the [generic] package unit.
24502 elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
24503 | N_Subprogram_Declaration
24504 and then Present (Context)
24505 and then Nkind (Context) in N_Generic_Package_Declaration
24506 | N_Package_Declaration
24510 -- Otherwise the placement is illegal
24514 ("pragma % must be applied to a library-level subprogram "
24519 Subp_Id := Defining_Entity (Subp_Decl);
24521 -- A pragma that applies to a Ghost entity becomes Ghost for the
24522 -- purposes of legality checks and removal of ignored Ghost code.
24524 Mark_Ghost_Pragma (N, Subp_Id);
24526 -- Chain the pragma on the contract for further processing by
24527 -- Analyze_Test_Case_In_Decl_Part.
24529 Add_Contract_Item (N, Subp_Id);
24531 -- Preanalyze the original aspect argument "Name" for a generic
24532 -- subprogram to properly capture global references.
24534 if Is_Generic_Subprogram (Subp_Id) then
24535 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24537 if Present (Asp_Arg) then
24539 -- The argument appears with an identifier in association
24542 if Nkind (Asp_Arg) = N_Component_Association then
24543 Asp_Arg := Expression (Asp_Arg);
24546 Check_Expr_Is_OK_Static_Expression
24547 (Asp_Arg, Standard_String);
24551 -- Ensure that the all Test_Case pragmas of the related subprogram
24552 -- have distinct names.
24554 Check_Distinct_Name (Subp_Id);
24556 -- Fully analyze the pragma when it appears inside an entry
24557 -- or subprogram body because it cannot benefit from forward
24560 if Nkind (Subp_Decl) in N_Entry_Body
24561 | N_Subprogram_Body
24562 | N_Subprogram_Body_Stub
24564 -- The legality checks of pragma Test_Case are affected by the
24565 -- SPARK mode in effect and the volatility of the context.
24566 -- Analyze all pragmas in a specific order.
24568 Analyze_If_Present (Pragma_SPARK_Mode);
24569 Analyze_If_Present (Pragma_Volatile_Function);
24570 Analyze_Test_Case_In_Decl_Part (N);
24574 --------------------------
24575 -- Thread_Local_Storage --
24576 --------------------------
24578 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24580 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24586 Check_Arg_Count (1);
24587 Check_Optional_Identifier (Arg1, Name_Entity);
24588 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24590 Id := Get_Pragma_Arg (Arg1);
24593 if not Is_Entity_Name (Id)
24594 or else Ekind (Entity (Id)) /= E_Variable
24596 Error_Pragma_Arg ("local variable name required", Arg1);
24601 -- A pragma that applies to a Ghost entity becomes Ghost for the
24602 -- purposes of legality checks and removal of ignored Ghost code.
24604 Mark_Ghost_Pragma (N, E);
24606 if Rep_Item_Too_Early (E, N)
24608 Rep_Item_Too_Late (E, N)
24613 Set_Has_Pragma_Thread_Local_Storage (E);
24614 Set_Has_Gigi_Rep_Item (E);
24615 end Thread_Local_Storage;
24621 -- pragma Time_Slice (static_duration_EXPRESSION);
24623 when Pragma_Time_Slice => Time_Slice : declare
24629 Check_Arg_Count (1);
24630 Check_No_Identifiers;
24631 Check_In_Main_Program;
24632 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24634 if not Error_Posted (Arg1) then
24636 while Present (Nod) loop
24637 if Nkind (Nod) = N_Pragma
24638 and then Pragma_Name (Nod) = Name_Time_Slice
24640 Error_Msg_Name_1 := Pname;
24641 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24648 -- Process only if in main unit
24650 if Get_Source_Unit (Loc) = Main_Unit then
24651 Opt.Time_Slice_Set := True;
24652 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24654 if Val <= Ureal_0 then
24655 Opt.Time_Slice_Value := 0;
24657 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24658 Opt.Time_Slice_Value := 1_000_000_000;
24661 Opt.Time_Slice_Value :=
24662 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24671 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24673 -- TITLING_OPTION ::=
24674 -- [Title =>] STRING_LITERAL
24675 -- | [Subtitle =>] STRING_LITERAL
24677 when Pragma_Title => Title : declare
24678 Args : Args_List (1 .. 2);
24679 Names : constant Name_List (1 .. 2) := (
24685 Gather_Associations (Names, Args);
24688 for J in 1 .. 2 loop
24689 if Present (Args (J)) then
24690 Check_Arg_Is_OK_Static_Expression
24691 (Args (J), Standard_String);
24696 ----------------------------
24697 -- Type_Invariant[_Class] --
24698 ----------------------------
24700 -- pragma Type_Invariant[_Class]
24701 -- ([Entity =>] type_LOCAL_NAME,
24702 -- [Check =>] EXPRESSION);
24704 when Pragma_Type_Invariant
24705 | Pragma_Type_Invariant_Class
24707 Type_Invariant : declare
24708 I_Pragma : Node_Id;
24711 Check_Arg_Count (2);
24713 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24714 -- setting Class_Present for the Type_Invariant_Class case.
24716 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24717 I_Pragma := New_Copy (N);
24718 Set_Pragma_Identifier
24719 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24720 Rewrite (N, I_Pragma);
24721 Set_Analyzed (N, False);
24723 end Type_Invariant;
24725 ---------------------
24726 -- Unchecked_Union --
24727 ---------------------
24729 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24731 when Pragma_Unchecked_Union => Unchecked_Union : declare
24732 Assoc : constant Node_Id := Arg1;
24733 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24743 Check_No_Identifiers;
24744 Check_Arg_Count (1);
24745 Check_Arg_Is_Local_Name (Arg1);
24747 Find_Type (Type_Id);
24749 Typ := Entity (Type_Id);
24751 -- A pragma that applies to a Ghost entity becomes Ghost for the
24752 -- purposes of legality checks and removal of ignored Ghost code.
24754 Mark_Ghost_Pragma (N, Typ);
24757 or else Rep_Item_Too_Early (Typ, N)
24761 Typ := Underlying_Type (Typ);
24764 if Rep_Item_Too_Late (Typ, N) then
24768 Check_First_Subtype (Arg1);
24770 -- Note remaining cases are references to a type in the current
24771 -- declarative part. If we find an error, we post the error on
24772 -- the relevant type declaration at an appropriate point.
24774 if not Is_Record_Type (Typ) then
24775 Error_Msg_N ("unchecked union must be record type", Typ);
24778 elsif Is_Tagged_Type (Typ) then
24779 Error_Msg_N ("unchecked union must not be tagged", Typ);
24782 elsif not Has_Discriminants (Typ) then
24784 ("unchecked union must have one discriminant", Typ);
24787 -- Note: in previous versions of GNAT we used to check for limited
24788 -- types and give an error, but in fact the standard does allow
24789 -- Unchecked_Union on limited types, so this check was removed.
24791 -- Similarly, GNAT used to require that all discriminants have
24792 -- default values, but this is not mandated by the RM.
24794 -- Proceed with basic error checks completed
24797 Tdef := Type_Definition (Declaration_Node (Typ));
24798 Clist := Component_List (Tdef);
24800 -- Check presence of component list and variant part
24802 if No (Clist) or else No (Variant_Part (Clist)) then
24804 ("unchecked union must have variant part", Tdef);
24808 -- Check components
24810 Comp := First_Non_Pragma (Component_Items (Clist));
24811 while Present (Comp) loop
24812 Check_Component (Comp, Typ);
24813 Next_Non_Pragma (Comp);
24816 -- Check variant part
24818 Vpart := Variant_Part (Clist);
24820 Variant := First_Non_Pragma (Variants (Vpart));
24821 while Present (Variant) loop
24822 Check_Variant (Variant, Typ);
24823 Next_Non_Pragma (Variant);
24827 Set_Is_Unchecked_Union (Typ);
24828 Set_Convention (Typ, Convention_C);
24829 Set_Has_Unchecked_Union (Base_Type (Typ));
24830 Set_Is_Unchecked_Union (Base_Type (Typ));
24831 end Unchecked_Union;
24833 ----------------------------
24834 -- Unevaluated_Use_Of_Old --
24835 ----------------------------
24837 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24839 when Pragma_Unevaluated_Use_Of_Old =>
24841 Check_Arg_Count (1);
24842 Check_No_Identifiers;
24843 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24845 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24846 -- a declarative part or a package spec.
24848 if not Is_Configuration_Pragma then
24849 Check_Is_In_Decl_Part_Or_Package_Spec;
24852 -- Store proper setting of Uneval_Old
24854 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24855 Uneval_Old := Fold_Upper (Name_Buffer (1));
24857 ------------------------
24858 -- Unimplemented_Unit --
24859 ------------------------
24861 -- pragma Unimplemented_Unit;
24863 -- Note: this only gives an error if we are generating code, or if
24864 -- we are in a generic library unit (where the pragma appears in the
24865 -- body, not in the spec).
24867 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24868 Cunitent : constant Entity_Id :=
24869 Cunit_Entity (Get_Source_Unit (Loc));
24873 Check_Arg_Count (0);
24875 if Operating_Mode = Generate_Code
24876 or else Is_Generic_Unit (Cunitent)
24878 Get_Name_String (Chars (Cunitent));
24879 Set_Casing (Mixed_Case);
24880 Write_Str (Name_Buffer (1 .. Name_Len));
24881 Write_Str (" is not supported in this configuration");
24883 raise Unrecoverable_Error;
24885 end Unimplemented_Unit;
24887 ------------------------
24888 -- Universal_Aliasing --
24889 ------------------------
24891 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24893 when Pragma_Universal_Aliasing => Universal_Alias : declare
24899 Check_Arg_Count (1);
24900 Check_Optional_Identifier (Arg2, Name_Entity);
24901 Check_Arg_Is_Local_Name (Arg1);
24902 E_Id := Get_Pragma_Arg (Arg1);
24904 if Etype (E_Id) = Any_Type then
24908 E := Entity (E_Id);
24910 if not Is_Type (E) then
24911 Error_Pragma_Arg ("pragma% requires type", Arg1);
24914 -- A pragma that applies to a Ghost entity becomes Ghost for the
24915 -- purposes of legality checks and removal of ignored Ghost code.
24917 Mark_Ghost_Pragma (N, E);
24918 Set_Universal_Aliasing (Base_Type (E));
24919 Record_Rep_Item (E, N);
24920 end Universal_Alias;
24922 --------------------
24923 -- Universal_Data --
24924 --------------------
24926 -- pragma Universal_Data [(library_unit_NAME)];
24928 when Pragma_Universal_Data =>
24930 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24936 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24938 when Pragma_Unmodified =>
24939 Analyze_Unmodified_Or_Unused;
24945 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24947 -- or when used in a context clause:
24949 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24951 when Pragma_Unreferenced =>
24952 Analyze_Unreferenced_Or_Unused;
24954 --------------------------
24955 -- Unreferenced_Objects --
24956 --------------------------
24958 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24960 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24962 Arg_Expr : Node_Id;
24963 Arg_Id : Entity_Id;
24965 Ghost_Error_Posted : Boolean := False;
24966 -- Flag set when an error concerning the illegal mix of Ghost and
24967 -- non-Ghost types is emitted.
24969 Ghost_Id : Entity_Id := Empty;
24970 -- The entity of the first Ghost type encountered while processing
24971 -- the arguments of the pragma.
24975 Check_At_Least_N_Arguments (1);
24978 while Present (Arg) loop
24979 Check_No_Identifier (Arg);
24980 Check_Arg_Is_Local_Name (Arg);
24981 Arg_Expr := Get_Pragma_Arg (Arg);
24983 if Is_Entity_Name (Arg_Expr) then
24984 Arg_Id := Entity (Arg_Expr);
24986 if Is_Type (Arg_Id) then
24987 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24989 -- A pragma that applies to a Ghost entity becomes Ghost
24990 -- for the purposes of legality checks and removal of
24991 -- ignored Ghost code.
24993 Mark_Ghost_Pragma (N, Arg_Id);
24995 -- Capture the entity of the first Ghost type being
24996 -- processed for error detection purposes.
24998 if Is_Ghost_Entity (Arg_Id) then
24999 if No (Ghost_Id) then
25000 Ghost_Id := Arg_Id;
25003 -- Otherwise the type is non-Ghost. It is illegal to mix
25004 -- references to Ghost and non-Ghost entities
25007 elsif Present (Ghost_Id)
25008 and then not Ghost_Error_Posted
25010 Ghost_Error_Posted := True;
25012 Error_Msg_Name_1 := Pname;
25014 ("pragma % cannot mention ghost and non-ghost types",
25017 Error_Msg_Sloc := Sloc (Ghost_Id);
25018 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25020 Error_Msg_Sloc := Sloc (Arg_Id);
25021 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25025 ("argument for pragma% must be type or subtype", Arg);
25029 ("argument for pragma% must be type or subtype", Arg);
25034 end Unreferenced_Objects;
25036 ------------------------------
25037 -- Unreserve_All_Interrupts --
25038 ------------------------------
25040 -- pragma Unreserve_All_Interrupts;
25042 when Pragma_Unreserve_All_Interrupts =>
25044 Check_Arg_Count (0);
25046 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25047 Unreserve_All_Interrupts := True;
25054 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25056 when Pragma_Unsuppress =>
25058 Process_Suppress_Unsuppress (Suppress_Case => False);
25064 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25066 when Pragma_Unused =>
25067 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25068 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25070 -------------------
25071 -- Use_VADS_Size --
25072 -------------------
25074 -- pragma Use_VADS_Size;
25076 when Pragma_Use_VADS_Size =>
25078 Check_Arg_Count (0);
25079 Check_Valid_Configuration_Pragma;
25080 Use_VADS_Size := True;
25082 ---------------------
25083 -- Validity_Checks --
25084 ---------------------
25086 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25088 when Pragma_Validity_Checks => Validity_Checks : declare
25089 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25095 Check_Arg_Count (1);
25096 Check_No_Identifiers;
25098 -- Pragma always active unless in CodePeer or GNATprove modes,
25099 -- which use a fixed configuration of validity checks.
25101 if not (CodePeer_Mode or GNATprove_Mode) then
25102 if Nkind (A) = N_String_Literal then
25106 Slen : constant Natural := Natural (String_Length (S));
25107 Options : String (1 .. Slen);
25111 -- Couldn't we use a for loop here over Options'Range???
25115 C := Get_String_Char (S, Pos (J));
25117 -- This is a weird test, it skips setting validity
25118 -- checks entirely if any element of S is out of
25119 -- range of Character, what is that about ???
25121 exit when not In_Character_Range (C);
25122 Options (J) := Get_Character (C);
25125 Set_Validity_Check_Options (Options);
25133 elsif Nkind (A) = N_Identifier then
25134 if Chars (A) = Name_All_Checks then
25135 Set_Validity_Check_Options ("a");
25136 elsif Chars (A) = Name_On then
25137 Validity_Checks_On := True;
25138 elsif Chars (A) = Name_Off then
25139 Validity_Checks_On := False;
25143 end Validity_Checks;
25149 -- pragma Volatile (LOCAL_NAME);
25151 when Pragma_Volatile =>
25152 Process_Atomic_Independent_Shared_Volatile;
25154 -------------------------
25155 -- Volatile_Components --
25156 -------------------------
25158 -- pragma Volatile_Components (array_LOCAL_NAME);
25160 -- Volatile is handled by the same circuit as Atomic_Components
25162 --------------------------
25163 -- Volatile_Full_Access --
25164 --------------------------
25166 -- pragma Volatile_Full_Access (LOCAL_NAME);
25168 when Pragma_Volatile_Full_Access =>
25170 Process_Atomic_Independent_Shared_Volatile;
25172 -----------------------
25173 -- Volatile_Function --
25174 -----------------------
25176 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25178 when Pragma_Volatile_Function => Volatile_Function : declare
25179 Over_Id : Entity_Id;
25180 Spec_Id : Entity_Id;
25181 Subp_Decl : Node_Id;
25185 Check_No_Identifiers;
25186 Check_At_Most_N_Arguments (1);
25189 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25191 -- Generic subprogram
25193 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25196 -- Body acts as spec
25198 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25199 and then No (Corresponding_Spec (Subp_Decl))
25203 -- Body stub acts as spec
25205 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25206 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25212 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25220 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25222 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
25227 -- A pragma that applies to a Ghost entity becomes Ghost for the
25228 -- purposes of legality checks and removal of ignored Ghost code.
25230 Mark_Ghost_Pragma (N, Spec_Id);
25232 -- Chain the pragma on the contract for completeness
25234 Add_Contract_Item (N, Spec_Id);
25236 -- The legality checks of pragma Volatile_Function are affected by
25237 -- the SPARK mode in effect. Analyze all pragmas in a specific
25240 Analyze_If_Present (Pragma_SPARK_Mode);
25242 -- A volatile function cannot override a non-volatile function
25243 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25244 -- in New_Overloaded_Entity, however at that point the pragma has
25245 -- not been processed yet.
25247 Over_Id := Overridden_Operation (Spec_Id);
25249 if Present (Over_Id)
25250 and then not Is_Volatile_Function (Over_Id)
25253 ("incompatible volatile function values in effect", Spec_Id);
25255 Error_Msg_Sloc := Sloc (Over_Id);
25257 ("\& declared # with Volatile_Function value False",
25260 Error_Msg_Sloc := Sloc (Spec_Id);
25262 ("\overridden # with Volatile_Function value True",
25266 -- Analyze the Boolean expression (if any)
25268 if Present (Arg1) then
25269 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25271 end Volatile_Function;
25273 ----------------------
25274 -- Warning_As_Error --
25275 ----------------------
25277 -- pragma Warning_As_Error (static_string_EXPRESSION);
25279 when Pragma_Warning_As_Error =>
25281 Check_Arg_Count (1);
25282 Check_No_Identifiers;
25283 Check_Valid_Configuration_Pragma;
25285 if not Is_Static_String_Expression (Arg1) then
25287 ("argument of pragma% must be static string expression",
25290 -- OK static string expression
25293 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25294 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25295 new String'(Acquire_Warning_Match_String
25296 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25303 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25305 -- DETAILS ::= On | Off
25306 -- DETAILS ::= On | Off, local_NAME
25307 -- DETAILS ::= static_string_EXPRESSION
25308 -- DETAILS ::= On | Off, static_string_EXPRESSION
25310 -- TOOL_NAME ::= GNAT | GNATprove
25312 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25314 -- Note: If the first argument matches an allowed tool name, it is
25315 -- always considered to be a tool name, even if there is a string
25316 -- variable of that name.
25318 -- Note if the second argument of DETAILS is a local_NAME then the
25319 -- second form is always understood. If the intention is to use
25320 -- the fourth form, then you can write NAME & "" to force the
25321 -- intepretation as a static_string_EXPRESSION.
25323 when Pragma_Warnings => Warnings : declare
25324 Reason : String_Id;
25328 Check_At_Least_N_Arguments (1);
25330 -- See if last argument is labeled Reason. If so, make sure we
25331 -- have a string literal or a concatenation of string literals,
25332 -- and acquire the REASON string. Then remove the REASON argument
25333 -- by decreasing Num_Args by one; Remaining processing looks only
25334 -- at first Num_Args arguments).
25337 Last_Arg : constant Node_Id :=
25338 Last (Pragma_Argument_Associations (N));
25341 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25342 and then Chars (Last_Arg) = Name_Reason
25345 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25346 Reason := End_String;
25347 Arg_Count := Arg_Count - 1;
25349 -- Not allowed in compiler units (bootstrap issues)
25351 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25353 -- No REASON string, set null string as reason
25356 Reason := Null_String_Id;
25360 -- Now proceed with REASON taken care of and eliminated
25362 Check_No_Identifiers;
25364 -- If debug flag -gnatd.i is set, pragma is ignored
25366 if Debug_Flag_Dot_I then
25370 -- Process various forms of the pragma
25373 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25374 Shifted_Args : List_Id;
25377 -- See if first argument is a tool name, currently either
25378 -- GNAT or GNATprove. If so, either ignore the pragma if the
25379 -- tool used does not match, or continue as if no tool name
25380 -- was given otherwise, by shifting the arguments.
25382 if Nkind (Argx) = N_Identifier
25383 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25385 if Chars (Argx) = Name_Gnat then
25386 if CodePeer_Mode or GNATprove_Mode then
25387 Rewrite (N, Make_Null_Statement (Loc));
25392 elsif Chars (Argx) = Name_Gnatprove then
25393 if not GNATprove_Mode then
25394 Rewrite (N, Make_Null_Statement (Loc));
25400 raise Program_Error;
25403 -- At this point, the pragma Warnings applies to the tool,
25404 -- so continue with shifted arguments.
25406 Arg_Count := Arg_Count - 1;
25408 if Arg_Count = 1 then
25409 Shifted_Args := New_List (New_Copy (Arg2));
25410 elsif Arg_Count = 2 then
25411 Shifted_Args := New_List (New_Copy (Arg2),
25413 elsif Arg_Count = 3 then
25414 Shifted_Args := New_List (New_Copy (Arg2),
25418 raise Program_Error;
25423 Chars => Name_Warnings,
25424 Pragma_Argument_Associations => Shifted_Args));
25429 -- One argument case
25431 if Arg_Count = 1 then
25433 -- On/Off one argument case was processed by parser
25435 if Nkind (Argx) = N_Identifier
25436 and then Chars (Argx) in Name_On | Name_Off
25440 -- One argument case must be ON/OFF or static string expr
25442 elsif not Is_Static_String_Expression (Arg1) then
25444 ("argument of pragma% must be On/Off or static string "
25445 & "expression", Arg1);
25447 -- One argument string expression case
25451 Lit : constant Node_Id := Expr_Value_S (Argx);
25452 Str : constant String_Id := Strval (Lit);
25453 Len : constant Nat := String_Length (Str);
25461 while J <= Len loop
25462 C := Get_String_Char (Str, J);
25463 OK := In_Character_Range (C);
25466 Chr := Get_Character (C);
25468 -- Dash case: only -Wxxx is accepted
25475 C := Get_String_Char (Str, J);
25476 Chr := Get_Character (C);
25477 exit when Chr = 'W';
25482 elsif J < Len and then Chr = '.' then
25484 C := Get_String_Char (Str, J);
25485 Chr := Get_Character (C);
25487 if not Set_Dot_Warning_Switch (Chr) then
25489 ("invalid warning switch character "
25490 & '.' & Chr, Arg1);
25496 OK := Set_Warning_Switch (Chr);
25501 ("invalid warning switch character " & Chr,
25507 ("invalid wide character in warning switch ",
25516 -- Two or more arguments (must be two)
25519 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25520 Check_Arg_Count (2);
25528 E_Id := Get_Pragma_Arg (Arg2);
25531 -- In the expansion of an inlined body, a reference to
25532 -- the formal may be wrapped in a conversion if the
25533 -- actual is a conversion. Retrieve the real entity name.
25535 if (In_Instance_Body or In_Inlined_Body)
25536 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25538 E_Id := Expression (E_Id);
25541 -- Entity name case
25543 if Is_Entity_Name (E_Id) then
25544 E := Entity (E_Id);
25551 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25554 -- Suppress elaboration warnings if the entity
25555 -- denotes an elaboration target.
25557 if Is_Elaboration_Target (E) then
25558 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25561 -- For OFF case, make entry in warnings off
25562 -- pragma table for later processing. But we do
25563 -- not do that within an instance, since these
25564 -- warnings are about what is needed in the
25565 -- template, not an instance of it.
25567 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25568 and then Warn_On_Warnings_Off
25569 and then not In_Instance
25571 Warnings_Off_Pragmas.Append ((N, E, Reason));
25574 if Is_Enumeration_Type (E) then
25578 Lit := First_Literal (E);
25579 while Present (Lit) loop
25580 Set_Warnings_Off (Lit);
25581 Next_Literal (Lit);
25586 exit when No (Homonym (E));
25591 -- Error if not entity or static string expression case
25593 elsif not Is_Static_String_Expression (Arg2) then
25595 ("second argument of pragma% must be entity name "
25596 & "or static string expression", Arg2);
25598 -- Static string expression case
25601 -- Note on configuration pragma case: If this is a
25602 -- configuration pragma, then for an OFF pragma, we
25603 -- just set Config True in the call, which is all
25604 -- that needs to be done. For the case of ON, this
25605 -- is normally an error, unless it is canceling the
25606 -- effect of a previous OFF pragma in the same file.
25607 -- In any other case, an error will be signalled (ON
25608 -- with no matching OFF).
25610 -- Note: We set Used if we are inside a generic to
25611 -- disable the test that the non-config case actually
25612 -- cancels a warning. That's because we can't be sure
25613 -- there isn't an instantiation in some other unit
25614 -- where a warning is suppressed.
25616 -- We could do a little better here by checking if the
25617 -- generic unit we are inside is public, but for now
25618 -- we don't bother with that refinement.
25621 Message : constant String :=
25622 Acquire_Warning_Match_String
25623 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25625 if Chars (Argx) = Name_Off then
25626 Set_Specific_Warning_Off
25627 (Loc, Message, Reason,
25628 Config => Is_Configuration_Pragma,
25629 Used => Inside_A_Generic or else In_Instance);
25631 elsif Chars (Argx) = Name_On then
25632 Set_Specific_Warning_On (Loc, Message, Err);
25636 ("??pragma Warnings On with no matching "
25637 & "Warnings Off", Loc);
25647 -------------------
25648 -- Weak_External --
25649 -------------------
25651 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25653 when Pragma_Weak_External => Weak_External : declare
25658 Check_Arg_Count (1);
25659 Check_Optional_Identifier (Arg1, Name_Entity);
25660 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25661 Ent := Entity (Get_Pragma_Arg (Arg1));
25663 if Rep_Item_Too_Early (Ent, N) then
25666 Ent := Underlying_Type (Ent);
25669 -- The pragma applies to entities with addresses
25671 if Is_Type (Ent) then
25672 Error_Pragma ("pragma applies to objects and subprograms");
25675 -- The only processing required is to link this item on to the
25676 -- list of rep items for the given entity. This is accomplished
25677 -- by the call to Rep_Item_Too_Late (when no error is detected
25678 -- and False is returned).
25680 if Rep_Item_Too_Late (Ent, N) then
25683 Set_Has_Gigi_Rep_Item (Ent);
25687 -----------------------------
25688 -- Wide_Character_Encoding --
25689 -----------------------------
25691 -- pragma Wide_Character_Encoding (IDENTIFIER);
25693 when Pragma_Wide_Character_Encoding =>
25696 -- Nothing to do, handled in parser. Note that we do not enforce
25697 -- configuration pragma placement, this pragma can appear at any
25698 -- place in the source, allowing mixed encodings within a single
25703 --------------------
25704 -- Unknown_Pragma --
25705 --------------------
25707 -- Should be impossible, since the case of an unknown pragma is
25708 -- separately processed before the case statement is entered.
25710 when Unknown_Pragma =>
25711 raise Program_Error;
25714 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25715 -- until AI is formally approved.
25717 -- Check_Order_Dependence;
25720 when Pragma_Exit => null;
25721 end Analyze_Pragma;
25723 ---------------------------------------------
25724 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25725 ---------------------------------------------
25727 -- WARNING: This routine manages Ghost regions. Return statements must be
25728 -- replaced by gotos which jump to the end of the routine and restore the
25731 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25733 Freeze_Id : Entity_Id := Empty)
25735 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25736 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25738 Disp_Typ : Entity_Id;
25739 -- The dispatching type of the subprogram subject to the pre- or
25742 function Check_References (Nod : Node_Id) return Traverse_Result;
25743 -- Check that expression Nod does not mention non-primitives of the
25744 -- type, global objects of the type, or other illegalities described
25745 -- and implied by AI12-0113.
25747 ----------------------
25748 -- Check_References --
25749 ----------------------
25751 function Check_References (Nod : Node_Id) return Traverse_Result is
25753 if Nkind (Nod) = N_Function_Call
25754 and then Is_Entity_Name (Name (Nod))
25757 Func : constant Entity_Id := Entity (Name (Nod));
25761 -- An operation of the type must be a primitive
25763 if No (Find_Dispatching_Type (Func)) then
25764 Form := First_Formal (Func);
25765 while Present (Form) loop
25766 if Etype (Form) = Disp_Typ then
25768 ("operation in class-wide condition must be "
25769 & "primitive of &", Nod, Disp_Typ);
25772 Next_Formal (Form);
25775 -- A return object of the type is illegal as well
25777 if Etype (Func) = Disp_Typ
25778 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25781 ("operation in class-wide condition must be primitive "
25782 & "of &", Nod, Disp_Typ);
25785 -- Otherwise we have a call to an overridden primitive, and we
25786 -- will create a common class-wide clone for the body of
25787 -- original operation and its eventual inherited versions. If
25788 -- the original operation dispatches on result it is never
25789 -- inherited and there is no need for a clone. There is not
25790 -- need for a clone either in GNATprove mode, as cases that
25791 -- would require it are rejected (when an inherited primitive
25792 -- calls an overridden operation in a class-wide contract), and
25793 -- the clone would make proof impossible in some cases.
25795 elsif not Is_Abstract_Subprogram (Spec_Id)
25796 and then No (Class_Wide_Clone (Spec_Id))
25797 and then not Has_Controlling_Result (Spec_Id)
25798 and then not GNATprove_Mode
25800 Build_Class_Wide_Clone_Decl (Spec_Id);
25804 elsif Is_Entity_Name (Nod)
25806 (Etype (Nod) = Disp_Typ
25807 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25808 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
25811 ("object in class-wide condition must be formal of type &",
25814 elsif Nkind (Nod) = N_Explicit_Dereference
25815 and then (Etype (Nod) = Disp_Typ
25816 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25817 and then (not Is_Entity_Name (Prefix (Nod))
25818 or else not Is_Formal (Entity (Prefix (Nod))))
25821 ("operation in class-wide condition must be primitive of &",
25826 end Check_References;
25828 procedure Check_Class_Wide_Condition is
25829 new Traverse_Proc (Check_References);
25833 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25835 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25836 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25837 -- Save the Ghost-related attributes to restore on exit
25840 Restore_Scope : Boolean := False;
25842 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25845 -- Do not analyze the pragma multiple times
25847 if Is_Analyzed_Pragma (N) then
25851 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25852 -- analysis of the pragma, the Ghost mode at point of declaration and
25853 -- point of analysis may not necessarily be the same. Use the mode in
25854 -- effect at the point of declaration.
25856 Set_Ghost_Mode (N);
25858 -- Ensure that the subprogram and its formals are visible when analyzing
25859 -- the expression of the pragma.
25861 if not In_Open_Scopes (Spec_Id) then
25862 Restore_Scope := True;
25863 Push_Scope (Spec_Id);
25865 if Is_Generic_Subprogram (Spec_Id) then
25866 Install_Generic_Formals (Spec_Id);
25868 Install_Formals (Spec_Id);
25872 Errors := Serious_Errors_Detected;
25873 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25875 -- Emit a clarification message when the expression contains at least
25876 -- one undefined reference, possibly due to contract freezing.
25878 if Errors /= Serious_Errors_Detected
25879 and then Present (Freeze_Id)
25880 and then Has_Undefined_Reference (Expr)
25882 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25885 if Class_Present (N) then
25887 -- Verify that a class-wide condition is legal, i.e. the operation is
25888 -- a primitive of a tagged type. Note that a generic subprogram is
25889 -- not a primitive operation.
25891 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25893 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25894 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25896 if From_Aspect_Specification (N) then
25898 ("aspect % can only be specified for a primitive operation "
25899 & "of a tagged type", Corresponding_Aspect (N));
25901 -- The pragma is a source construct
25905 ("pragma % can only be specified for a primitive operation "
25906 & "of a tagged type", N);
25909 -- Remaining semantic checks require a full tree traversal
25912 Check_Class_Wide_Condition (Expr);
25917 if Restore_Scope then
25921 -- If analysis of the condition indicates that a class-wide clone
25922 -- has been created, build and analyze its declaration.
25924 if Is_Subprogram (Spec_Id)
25925 and then Present (Class_Wide_Clone (Spec_Id))
25927 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25930 -- Currently it is not possible to inline pre/postconditions on a
25931 -- subprogram subject to pragma Inline_Always.
25933 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25934 Set_Is_Analyzed_Pragma (N);
25936 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25937 end Analyze_Pre_Post_Condition_In_Decl_Part;
25939 ------------------------------------------
25940 -- Analyze_Refined_Depends_In_Decl_Part --
25941 ------------------------------------------
25943 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25944 procedure Check_Dependency_Clause
25945 (Spec_Id : Entity_Id;
25946 Dep_Clause : Node_Id;
25947 Dep_States : Elist_Id;
25948 Refinements : List_Id;
25949 Matched_Items : in out Elist_Id);
25950 -- Try to match a single dependency clause Dep_Clause against one or
25951 -- more refinement clauses found in list Refinements. Each successful
25952 -- match eliminates at least one refinement clause from Refinements.
25953 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25954 -- denotes the entities of all abstract states which appear in pragma
25955 -- Depends. Matched_Items contains the entities of all successfully
25956 -- matched items found in pragma Depends.
25958 procedure Check_Output_States
25959 (Spec_Inputs : Elist_Id;
25960 Spec_Outputs : Elist_Id;
25961 Body_Inputs : Elist_Id;
25962 Body_Outputs : Elist_Id);
25963 -- Determine whether pragma Depends contains an output state with a
25964 -- visible refinement and if so, ensure that pragma Refined_Depends
25965 -- mentions all its constituents as outputs. Spec_Inputs and
25966 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25967 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25968 -- the inputs and outputs of the subprogram body synthesized from pragma
25969 -- Refined_Depends.
25971 function Collect_States (Clauses : List_Id) return Elist_Id;
25972 -- Given a normalized list of dependencies obtained from calling
25973 -- Normalize_Clauses, return a list containing the entities of all
25974 -- states appearing in dependencies. It helps in checking refinements
25975 -- involving a state and a corresponding constituent which is not a
25976 -- direct constituent of the state.
25978 procedure Normalize_Clauses (Clauses : List_Id);
25979 -- Given a list of dependence or refinement clauses Clauses, normalize
25980 -- each clause by creating multiple dependencies with exactly one input
25983 procedure Remove_Extra_Clauses
25984 (Clauses : List_Id;
25985 Matched_Items : Elist_Id);
25986 -- Given a list of refinement clauses Clauses, remove all clauses whose
25987 -- inputs and/or outputs have been previously matched. See the body for
25988 -- all special cases. Matched_Items contains the entities of all matched
25989 -- items found in pragma Depends.
25991 procedure Report_Extra_Clauses (Clauses : List_Id);
25992 -- Emit an error for each extra clause found in list Clauses
25994 -----------------------------
25995 -- Check_Dependency_Clause --
25996 -----------------------------
25998 procedure Check_Dependency_Clause
25999 (Spec_Id : Entity_Id;
26000 Dep_Clause : Node_Id;
26001 Dep_States : Elist_Id;
26002 Refinements : List_Id;
26003 Matched_Items : in out Elist_Id)
26005 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26006 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26008 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26009 -- Determine whether dependency item Dep_Item has been matched in a
26010 -- previous clause.
26012 function Is_In_Out_State_Clause return Boolean;
26013 -- Determine whether dependence clause Dep_Clause denotes an abstract
26014 -- state that depends on itself (State => State).
26016 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26017 -- Determine whether item Item denotes an abstract state with visible
26018 -- null refinement.
26020 procedure Match_Items
26021 (Dep_Item : Node_Id;
26022 Ref_Item : Node_Id;
26023 Matched : out Boolean);
26024 -- Try to match dependence item Dep_Item against refinement item
26025 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26026 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26027 -- the following conformance scenarios is in effect:
26028 -- 1) Both items denote null
26029 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26030 -- 3) Both items denote attribute 'Result
26031 -- 4) Both items denote the same object
26032 -- 5) Both items denote the same formal parameter
26033 -- 6) Both items denote the same current instance of a type
26034 -- 7) Both items denote the same discriminant
26035 -- 8) Dep_Item is an abstract state with visible null refinement
26036 -- and Ref_Item denotes null.
26037 -- 9) Dep_Item is an abstract state with visible null refinement
26038 -- and Ref_Item is Empty (special case).
26039 -- 10) Dep_Item is an abstract state with full or partial visible
26040 -- non-null refinement and Ref_Item denotes one of its
26042 -- 11) Dep_Item is an abstract state without a full visible
26043 -- refinement and Ref_Item denotes the same state.
26044 -- When scenario 10 is in effect, the entity of the abstract state
26045 -- denoted by Dep_Item is added to list Refined_States.
26047 procedure Record_Item (Item_Id : Entity_Id);
26048 -- Store the entity of an item denoted by Item_Id in Matched_Items
26050 ------------------------
26051 -- Is_Already_Matched --
26052 ------------------------
26054 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26055 Item_Id : Entity_Id := Empty;
26058 -- When the dependency item denotes attribute 'Result, check for
26059 -- the entity of the related subprogram.
26061 if Is_Attribute_Result (Dep_Item) then
26062 Item_Id := Spec_Id;
26064 elsif Is_Entity_Name (Dep_Item) then
26065 Item_Id := Available_View (Entity_Of (Dep_Item));
26069 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26070 end Is_Already_Matched;
26072 ----------------------------
26073 -- Is_In_Out_State_Clause --
26074 ----------------------------
26076 function Is_In_Out_State_Clause return Boolean is
26077 Dep_Input_Id : Entity_Id;
26078 Dep_Output_Id : Entity_Id;
26081 -- Detect the following clause:
26084 if Is_Entity_Name (Dep_Input)
26085 and then Is_Entity_Name (Dep_Output)
26087 -- Handle abstract views generated for limited with clauses
26089 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26090 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26093 Ekind (Dep_Input_Id) = E_Abstract_State
26094 and then Dep_Input_Id = Dep_Output_Id;
26098 end Is_In_Out_State_Clause;
26100 ---------------------------
26101 -- Is_Null_Refined_State --
26102 ---------------------------
26104 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26105 Item_Id : Entity_Id;
26108 if Is_Entity_Name (Item) then
26110 -- Handle abstract views generated for limited with clauses
26112 Item_Id := Available_View (Entity_Of (Item));
26115 Ekind (Item_Id) = E_Abstract_State
26116 and then Has_Null_Visible_Refinement (Item_Id);
26120 end Is_Null_Refined_State;
26126 procedure Match_Items
26127 (Dep_Item : Node_Id;
26128 Ref_Item : Node_Id;
26129 Matched : out Boolean)
26131 Dep_Item_Id : Entity_Id;
26132 Ref_Item_Id : Entity_Id;
26135 -- Assume that the two items do not match
26139 -- A null matches null or Empty (special case)
26141 if Nkind (Dep_Item) = N_Null
26142 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26146 -- Attribute 'Result matches attribute 'Result
26148 elsif Is_Attribute_Result (Dep_Item)
26149 and then Is_Attribute_Result (Ref_Item)
26151 -- Put the entity of the related function on the list of
26152 -- matched items because attribute 'Result does not carry
26153 -- an entity similar to states and constituents.
26155 Record_Item (Spec_Id);
26158 -- Abstract states, current instances of concurrent types,
26159 -- discriminants, formal parameters and objects.
26161 elsif Is_Entity_Name (Dep_Item) then
26163 -- Handle abstract views generated for limited with clauses
26165 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26167 if Ekind (Dep_Item_Id) = E_Abstract_State then
26169 -- An abstract state with visible null refinement matches
26170 -- null or Empty (special case).
26172 if Has_Null_Visible_Refinement (Dep_Item_Id)
26173 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26175 Record_Item (Dep_Item_Id);
26178 -- An abstract state with visible non-null refinement
26179 -- matches one of its constituents, or itself for an
26180 -- abstract state with partial visible refinement.
26182 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26183 if Is_Entity_Name (Ref_Item) then
26184 Ref_Item_Id := Entity_Of (Ref_Item);
26186 if Ekind (Ref_Item_Id) in
26187 E_Abstract_State | E_Constant | E_Variable
26188 and then Present (Encapsulating_State (Ref_Item_Id))
26189 and then Find_Encapsulating_State
26190 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26192 Record_Item (Dep_Item_Id);
26195 elsif not Has_Visible_Refinement (Dep_Item_Id)
26196 and then Ref_Item_Id = Dep_Item_Id
26198 Record_Item (Dep_Item_Id);
26203 -- An abstract state without a visible refinement matches
26206 elsif Is_Entity_Name (Ref_Item)
26207 and then Entity_Of (Ref_Item) = Dep_Item_Id
26209 Record_Item (Dep_Item_Id);
26213 -- A current instance of a concurrent type, discriminant,
26214 -- formal parameter or an object matches itself.
26216 elsif Is_Entity_Name (Ref_Item)
26217 and then Entity_Of (Ref_Item) = Dep_Item_Id
26219 Record_Item (Dep_Item_Id);
26229 procedure Record_Item (Item_Id : Entity_Id) is
26231 if No (Matched_Items) then
26232 Matched_Items := New_Elmt_List;
26235 Append_Unique_Elmt (Item_Id, Matched_Items);
26240 Clause_Matched : Boolean := False;
26241 Dummy : Boolean := False;
26242 Inputs_Match : Boolean;
26243 Next_Ref_Clause : Node_Id;
26244 Outputs_Match : Boolean;
26245 Ref_Clause : Node_Id;
26246 Ref_Input : Node_Id;
26247 Ref_Output : Node_Id;
26249 -- Start of processing for Check_Dependency_Clause
26252 -- Do not perform this check in an instance because it was already
26253 -- performed successfully in the generic template.
26255 if In_Instance then
26259 -- Examine all refinement clauses and compare them against the
26260 -- dependence clause.
26262 Ref_Clause := First (Refinements);
26263 while Present (Ref_Clause) loop
26264 Next_Ref_Clause := Next (Ref_Clause);
26266 -- Obtain the attributes of the current refinement clause
26268 Ref_Input := Expression (Ref_Clause);
26269 Ref_Output := First (Choices (Ref_Clause));
26271 -- The current refinement clause matches the dependence clause
26272 -- when both outputs match and both inputs match. See routine
26273 -- Match_Items for all possible conformance scenarios.
26275 -- Depends Dep_Output => Dep_Input
26279 -- Refined_Depends Ref_Output => Ref_Input
26282 (Dep_Item => Dep_Input,
26283 Ref_Item => Ref_Input,
26284 Matched => Inputs_Match);
26287 (Dep_Item => Dep_Output,
26288 Ref_Item => Ref_Output,
26289 Matched => Outputs_Match);
26291 -- An In_Out state clause may be matched against a refinement with
26292 -- a null input or null output as long as the non-null side of the
26293 -- relation contains a valid constituent of the In_Out_State.
26295 if Is_In_Out_State_Clause then
26297 -- Depends => (State => State)
26298 -- Refined_Depends => (null => Constit) -- OK
26301 and then not Outputs_Match
26302 and then Nkind (Ref_Output) = N_Null
26304 Outputs_Match := True;
26307 -- Depends => (State => State)
26308 -- Refined_Depends => (Constit => null) -- OK
26310 if not Inputs_Match
26311 and then Outputs_Match
26312 and then Nkind (Ref_Input) = N_Null
26314 Inputs_Match := True;
26318 -- The current refinement clause is legally constructed following
26319 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26320 -- the pool of candidates. The seach continues because a single
26321 -- dependence clause may have multiple matching refinements.
26323 if Inputs_Match and Outputs_Match then
26324 Clause_Matched := True;
26325 Remove (Ref_Clause);
26328 Ref_Clause := Next_Ref_Clause;
26331 -- Depending on the order or composition of refinement clauses, an
26332 -- In_Out state clause may not be directly refinable.
26334 -- Refined_State => (State => (Constit_1, Constit_2))
26335 -- Depends => ((Output, State) => (Input, State))
26336 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26338 -- Matching normalized clause (State => State) fails because there is
26339 -- no direct refinement capable of satisfying this relation. Another
26340 -- similar case arises when clauses (Constit_1 => Input) and (Output
26341 -- => Constit_2) are matched first, leaving no candidates for clause
26342 -- (State => State). Both scenarios are legal as long as one of the
26343 -- previous clauses mentioned a valid constituent of State.
26345 if not Clause_Matched
26346 and then Is_In_Out_State_Clause
26347 and then Is_Already_Matched (Dep_Input)
26349 Clause_Matched := True;
26352 -- A clause where the input is an abstract state with visible null
26353 -- refinement or a 'Result attribute is implicitly matched when the
26354 -- output has already been matched in a previous clause.
26356 -- Refined_State => (State => null)
26357 -- Depends => (Output => State) -- implicitly OK
26358 -- Refined_Depends => (Output => ...)
26359 -- Depends => (...'Result => State) -- implicitly OK
26360 -- Refined_Depends => (...'Result => ...)
26362 if not Clause_Matched
26363 and then Is_Null_Refined_State (Dep_Input)
26364 and then Is_Already_Matched (Dep_Output)
26366 Clause_Matched := True;
26369 -- A clause where the output is an abstract state with visible null
26370 -- refinement is implicitly matched when the input has already been
26371 -- matched in a previous clause.
26373 -- Refined_State => (State => null)
26374 -- Depends => (State => Input) -- implicitly OK
26375 -- Refined_Depends => (... => Input)
26377 if not Clause_Matched
26378 and then Is_Null_Refined_State (Dep_Output)
26379 and then Is_Already_Matched (Dep_Input)
26381 Clause_Matched := True;
26384 -- At this point either all refinement clauses have been examined or
26385 -- pragma Refined_Depends contains a solitary null. Only an abstract
26386 -- state with null refinement can possibly match these cases.
26388 -- Refined_State => (State => null)
26389 -- Depends => (State => null)
26390 -- Refined_Depends => null -- OK
26392 if not Clause_Matched then
26394 (Dep_Item => Dep_Input,
26396 Matched => Inputs_Match);
26399 (Dep_Item => Dep_Output,
26401 Matched => Outputs_Match);
26403 Clause_Matched := Inputs_Match and Outputs_Match;
26406 -- If the contents of Refined_Depends are legal, then the current
26407 -- dependence clause should be satisfied either by an explicit match
26408 -- or by one of the special cases.
26410 if not Clause_Matched then
26412 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26413 & "matching refinement in body"), Dep_Clause, Spec_Id);
26415 end Check_Dependency_Clause;
26417 -------------------------
26418 -- Check_Output_States --
26419 -------------------------
26421 procedure Check_Output_States
26422 (Spec_Inputs : Elist_Id;
26423 Spec_Outputs : Elist_Id;
26424 Body_Inputs : Elist_Id;
26425 Body_Outputs : Elist_Id)
26427 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26428 -- Determine whether all constituents of state State_Id with full
26429 -- visible refinement are used as outputs in pragma Refined_Depends.
26430 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26432 -----------------------------
26433 -- Check_Constituent_Usage --
26434 -----------------------------
26436 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26437 Constits : constant Elist_Id :=
26438 Partial_Refinement_Constituents (State_Id);
26439 Constit_Elmt : Elmt_Id;
26440 Constit_Id : Entity_Id;
26441 Only_Partial : constant Boolean :=
26442 not Has_Visible_Refinement (State_Id);
26443 Posted : Boolean := False;
26446 if Present (Constits) then
26447 Constit_Elmt := First_Elmt (Constits);
26448 while Present (Constit_Elmt) loop
26449 Constit_Id := Node (Constit_Elmt);
26451 -- Issue an error when a constituent of State_Id is used,
26452 -- and State_Id has only partial visible refinement
26453 -- (SPARK RM 7.2.4(3d)).
26455 if Only_Partial then
26456 if (Present (Body_Inputs)
26457 and then Appears_In (Body_Inputs, Constit_Id))
26459 (Present (Body_Outputs)
26460 and then Appears_In (Body_Outputs, Constit_Id))
26462 Error_Msg_Name_1 := Chars (State_Id);
26464 ("constituent & of state % cannot be used in "
26465 & "dependence refinement", N, Constit_Id);
26466 Error_Msg_Name_1 := Chars (State_Id);
26467 SPARK_Msg_N ("\use state % instead", N);
26470 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26472 elsif Present (Body_Inputs)
26473 and then Appears_In (Body_Inputs, Constit_Id)
26475 Error_Msg_Name_1 := Chars (State_Id);
26477 ("constituent & of state % must act as output in "
26478 & "dependence refinement", N, Constit_Id);
26480 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26482 elsif No (Body_Outputs)
26483 or else not Appears_In (Body_Outputs, Constit_Id)
26488 ("output state & must be replaced by all its "
26489 & "constituents in dependence refinement",
26494 ("\constituent & is missing in output list",
26498 Next_Elmt (Constit_Elmt);
26501 end Check_Constituent_Usage;
26506 Item_Elmt : Elmt_Id;
26507 Item_Id : Entity_Id;
26509 -- Start of processing for Check_Output_States
26512 -- Do not perform this check in an instance because it was already
26513 -- performed successfully in the generic template.
26515 if In_Instance then
26518 -- Inspect the outputs of pragma Depends looking for a state with a
26519 -- visible refinement.
26521 elsif Present (Spec_Outputs) then
26522 Item_Elmt := First_Elmt (Spec_Outputs);
26523 while Present (Item_Elmt) loop
26524 Item := Node (Item_Elmt);
26526 -- Deal with the mixed nature of the input and output lists
26528 if Nkind (Item) = N_Defining_Identifier then
26531 Item_Id := Available_View (Entity_Of (Item));
26534 if Ekind (Item_Id) = E_Abstract_State then
26536 -- The state acts as an input-output, skip it
26538 if Present (Spec_Inputs)
26539 and then Appears_In (Spec_Inputs, Item_Id)
26543 -- Ensure that all of the constituents are utilized as
26544 -- outputs in pragma Refined_Depends.
26546 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26547 Check_Constituent_Usage (Item_Id);
26551 Next_Elmt (Item_Elmt);
26554 end Check_Output_States;
26556 --------------------
26557 -- Collect_States --
26558 --------------------
26560 function Collect_States (Clauses : List_Id) return Elist_Id is
26561 procedure Collect_State
26563 States : in out Elist_Id);
26564 -- Add the entity of Item to list States when it denotes to a state
26566 -------------------
26567 -- Collect_State --
26568 -------------------
26570 procedure Collect_State
26572 States : in out Elist_Id)
26577 if Is_Entity_Name (Item) then
26578 Id := Entity_Of (Item);
26580 if Ekind (Id) = E_Abstract_State then
26581 if No (States) then
26582 States := New_Elmt_List;
26585 Append_Unique_Elmt (Id, States);
26595 States : Elist_Id := No_Elist;
26597 -- Start of processing for Collect_States
26600 Clause := First (Clauses);
26601 while Present (Clause) loop
26602 Input := Expression (Clause);
26603 Output := First (Choices (Clause));
26605 Collect_State (Input, States);
26606 Collect_State (Output, States);
26612 end Collect_States;
26614 -----------------------
26615 -- Normalize_Clauses --
26616 -----------------------
26618 procedure Normalize_Clauses (Clauses : List_Id) is
26619 procedure Normalize_Inputs (Clause : Node_Id);
26620 -- Normalize clause Clause by creating multiple clauses for each
26621 -- input item of Clause. It is assumed that Clause has exactly one
26622 -- output. The transformation is as follows:
26624 -- Output => (Input_1, Input_2) -- original
26626 -- Output => Input_1 -- normalizations
26627 -- Output => Input_2
26629 procedure Normalize_Outputs (Clause : Node_Id);
26630 -- Normalize clause Clause by creating multiple clause for each
26631 -- output item of Clause. The transformation is as follows:
26633 -- (Output_1, Output_2) => Input -- original
26635 -- Output_1 => Input -- normalization
26636 -- Output_2 => Input
26638 ----------------------
26639 -- Normalize_Inputs --
26640 ----------------------
26642 procedure Normalize_Inputs (Clause : Node_Id) is
26643 Inputs : constant Node_Id := Expression (Clause);
26644 Loc : constant Source_Ptr := Sloc (Clause);
26645 Output : constant List_Id := Choices (Clause);
26646 Last_Input : Node_Id;
26648 New_Clause : Node_Id;
26649 Next_Input : Node_Id;
26652 -- Normalization is performed only when the original clause has
26653 -- more than one input. Multiple inputs appear as an aggregate.
26655 if Nkind (Inputs) = N_Aggregate then
26656 Last_Input := Last (Expressions (Inputs));
26658 -- Create a new clause for each input
26660 Input := First (Expressions (Inputs));
26661 while Present (Input) loop
26662 Next_Input := Next (Input);
26664 -- Unhook the current input from the original input list
26665 -- because it will be relocated to a new clause.
26669 -- Special processing for the last input. At this point the
26670 -- original aggregate has been stripped down to one element.
26671 -- Replace the aggregate by the element itself.
26673 if Input = Last_Input then
26674 Rewrite (Inputs, Input);
26676 -- Generate a clause of the form:
26681 Make_Component_Association (Loc,
26682 Choices => New_Copy_List_Tree (Output),
26683 Expression => Input);
26685 -- The new clause contains replicated content that has
26686 -- already been analyzed, mark the clause as analyzed.
26688 Set_Analyzed (New_Clause);
26689 Insert_After (Clause, New_Clause);
26692 Input := Next_Input;
26695 end Normalize_Inputs;
26697 -----------------------
26698 -- Normalize_Outputs --
26699 -----------------------
26701 procedure Normalize_Outputs (Clause : Node_Id) is
26702 Inputs : constant Node_Id := Expression (Clause);
26703 Loc : constant Source_Ptr := Sloc (Clause);
26704 Outputs : constant Node_Id := First (Choices (Clause));
26705 Last_Output : Node_Id;
26706 New_Clause : Node_Id;
26707 Next_Output : Node_Id;
26711 -- Multiple outputs appear as an aggregate. Nothing to do when
26712 -- the clause has exactly one output.
26714 if Nkind (Outputs) = N_Aggregate then
26715 Last_Output := Last (Expressions (Outputs));
26717 -- Create a clause for each output. Note that each time a new
26718 -- clause is created, the original output list slowly shrinks
26719 -- until there is one item left.
26721 Output := First (Expressions (Outputs));
26722 while Present (Output) loop
26723 Next_Output := Next (Output);
26725 -- Unhook the output from the original output list as it
26726 -- will be relocated to a new clause.
26730 -- Special processing for the last output. At this point
26731 -- the original aggregate has been stripped down to one
26732 -- element. Replace the aggregate by the element itself.
26734 if Output = Last_Output then
26735 Rewrite (Outputs, Output);
26738 -- Generate a clause of the form:
26739 -- (Output => Inputs)
26742 Make_Component_Association (Loc,
26743 Choices => New_List (Output),
26744 Expression => New_Copy_Tree (Inputs));
26746 -- The new clause contains replicated content that has
26747 -- already been analyzed. There is not need to reanalyze
26750 Set_Analyzed (New_Clause);
26751 Insert_After (Clause, New_Clause);
26754 Output := Next_Output;
26757 end Normalize_Outputs;
26763 -- Start of processing for Normalize_Clauses
26766 Clause := First (Clauses);
26767 while Present (Clause) loop
26768 Normalize_Outputs (Clause);
26772 Clause := First (Clauses);
26773 while Present (Clause) loop
26774 Normalize_Inputs (Clause);
26777 end Normalize_Clauses;
26779 --------------------------
26780 -- Remove_Extra_Clauses --
26781 --------------------------
26783 procedure Remove_Extra_Clauses
26784 (Clauses : List_Id;
26785 Matched_Items : Elist_Id)
26789 Input_Id : Entity_Id;
26790 Next_Clause : Node_Id;
26792 State_Id : Entity_Id;
26795 Clause := First (Clauses);
26796 while Present (Clause) loop
26797 Next_Clause := Next (Clause);
26799 Input := Expression (Clause);
26800 Output := First (Choices (Clause));
26802 -- Recognize a clause of the form
26806 -- where Input is a constituent of a state which was already
26807 -- successfully matched. This clause must be removed because it
26808 -- simply indicates that some of the constituents of the state
26811 -- Refined_State => (State => (Constit_1, Constit_2))
26812 -- Depends => (Output => State)
26813 -- Refined_Depends => ((Output => Constit_1), -- State matched
26814 -- (null => Constit_2)) -- OK
26816 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26818 -- Handle abstract views generated for limited with clauses
26820 Input_Id := Available_View (Entity_Of (Input));
26822 -- The input must be a constituent of a state
26824 if Ekind (Input_Id) in
26825 E_Abstract_State | E_Constant | E_Variable
26826 and then Present (Encapsulating_State (Input_Id))
26828 State_Id := Encapsulating_State (Input_Id);
26830 -- The state must have a non-null visible refinement and be
26831 -- matched in a previous clause.
26833 if Has_Non_Null_Visible_Refinement (State_Id)
26834 and then Contains (Matched_Items, State_Id)
26840 -- Recognize a clause of the form
26844 -- where Output is an arbitrary item. This clause must be removed
26845 -- because a null input legitimately matches anything.
26847 elsif Nkind (Input) = N_Null then
26851 Clause := Next_Clause;
26853 end Remove_Extra_Clauses;
26855 --------------------------
26856 -- Report_Extra_Clauses --
26857 --------------------------
26859 procedure Report_Extra_Clauses (Clauses : List_Id) is
26863 -- Do not perform this check in an instance because it was already
26864 -- performed successfully in the generic template.
26866 if In_Instance then
26869 elsif Present (Clauses) then
26870 Clause := First (Clauses);
26871 while Present (Clause) loop
26873 ("unmatched or extra clause in dependence refinement",
26879 end Report_Extra_Clauses;
26883 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26884 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26885 Errors : constant Nat := Serious_Errors_Detected;
26892 Body_Inputs : Elist_Id := No_Elist;
26893 Body_Outputs : Elist_Id := No_Elist;
26894 -- The inputs and outputs of the subprogram body synthesized from pragma
26895 -- Refined_Depends.
26897 Dependencies : List_Id := No_List;
26899 -- The corresponding Depends pragma along with its clauses
26901 Matched_Items : Elist_Id := No_Elist;
26902 -- A list containing the entities of all successfully matched items
26903 -- found in pragma Depends.
26905 Refinements : List_Id := No_List;
26906 -- The clauses of pragma Refined_Depends
26908 Spec_Id : Entity_Id;
26909 -- The entity of the subprogram subject to pragma Refined_Depends
26911 Spec_Inputs : Elist_Id := No_Elist;
26912 Spec_Outputs : Elist_Id := No_Elist;
26913 -- The inputs and outputs of the subprogram spec synthesized from pragma
26916 States : Elist_Id := No_Elist;
26917 -- A list containing the entities of all states whose constituents
26918 -- appear in pragma Depends.
26920 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26923 -- Do not analyze the pragma multiple times
26925 if Is_Analyzed_Pragma (N) then
26929 Spec_Id := Unique_Defining_Entity (Body_Decl);
26931 -- Use the anonymous object as the proper spec when Refined_Depends
26932 -- applies to the body of a single task type. The object carries the
26933 -- proper Chars as well as all non-refined versions of pragmas.
26935 if Is_Single_Concurrent_Type (Spec_Id) then
26936 Spec_Id := Anonymous_Object (Spec_Id);
26939 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26941 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26942 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26944 if No (Depends) then
26946 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26947 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26951 Deps := Expression (Get_Argument (Depends, Spec_Id));
26953 -- A null dependency relation renders the refinement useless because it
26954 -- cannot possibly mention abstract states with visible refinement. Note
26955 -- that the inverse is not true as states may be refined to null
26956 -- (SPARK RM 7.2.5(2)).
26958 if Nkind (Deps) = N_Null then
26960 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26961 & "depend on abstract state with visible refinement"), N, Spec_Id);
26965 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26966 -- This ensures that the categorization of all refined dependency items
26967 -- is consistent with their role.
26969 Analyze_Depends_In_Decl_Part (N);
26971 -- Do not match dependencies against refinements if Refined_Depends is
26972 -- illegal to avoid emitting misleading error.
26974 if Serious_Errors_Detected = Errors then
26976 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26977 -- the inputs and outputs of the subprogram spec and body to verify
26978 -- the use of states with visible refinement and their constituents.
26980 if No (Get_Pragma (Spec_Id, Pragma_Global))
26981 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26983 Collect_Subprogram_Inputs_Outputs
26984 (Subp_Id => Spec_Id,
26985 Synthesize => True,
26986 Subp_Inputs => Spec_Inputs,
26987 Subp_Outputs => Spec_Outputs,
26988 Global_Seen => Dummy);
26990 Collect_Subprogram_Inputs_Outputs
26991 (Subp_Id => Body_Id,
26992 Synthesize => True,
26993 Subp_Inputs => Body_Inputs,
26994 Subp_Outputs => Body_Outputs,
26995 Global_Seen => Dummy);
26997 -- For an output state with a visible refinement, ensure that all
26998 -- constituents appear as outputs in the dependency refinement.
27000 Check_Output_States
27001 (Spec_Inputs => Spec_Inputs,
27002 Spec_Outputs => Spec_Outputs,
27003 Body_Inputs => Body_Inputs,
27004 Body_Outputs => Body_Outputs);
27007 -- Multiple dependency clauses appear as component associations of an
27008 -- aggregate. Note that the clauses are copied because the algorithm
27009 -- modifies them and this should not be visible in Depends.
27011 pragma Assert (Nkind (Deps) = N_Aggregate);
27012 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
27013 Normalize_Clauses (Dependencies);
27015 -- Gather all states which appear in Depends
27017 States := Collect_States (Dependencies);
27019 Refs := Expression (Get_Argument (N, Spec_Id));
27021 if Nkind (Refs) = N_Null then
27022 Refinements := No_List;
27024 -- Multiple dependency clauses appear as component associations of an
27025 -- aggregate. Note that the clauses are copied because the algorithm
27026 -- modifies them and this should not be visible in Refined_Depends.
27028 else pragma Assert (Nkind (Refs) = N_Aggregate);
27029 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27030 Normalize_Clauses (Refinements);
27033 -- At this point the clauses of pragmas Depends and Refined_Depends
27034 -- have been normalized into simple dependencies between one output
27035 -- and one input. Examine all clauses of pragma Depends looking for
27036 -- matching clauses in pragma Refined_Depends.
27038 Clause := First (Dependencies);
27039 while Present (Clause) loop
27040 Check_Dependency_Clause
27041 (Spec_Id => Spec_Id,
27042 Dep_Clause => Clause,
27043 Dep_States => States,
27044 Refinements => Refinements,
27045 Matched_Items => Matched_Items);
27050 -- Pragma Refined_Depends may contain multiple clarification clauses
27051 -- which indicate that certain constituents do not influence the data
27052 -- flow in any way. Such clauses must be removed as long as the state
27053 -- has been matched, otherwise they will be incorrectly flagged as
27056 -- Refined_State => (State => (Constit_1, Constit_2))
27057 -- Depends => (Output => State)
27058 -- Refined_Depends => ((Output => Constit_1), -- State matched
27059 -- (null => Constit_2)) -- must be removed
27061 Remove_Extra_Clauses (Refinements, Matched_Items);
27063 if Serious_Errors_Detected = Errors then
27064 Report_Extra_Clauses (Refinements);
27069 Set_Is_Analyzed_Pragma (N);
27070 end Analyze_Refined_Depends_In_Decl_Part;
27072 -----------------------------------------
27073 -- Analyze_Refined_Global_In_Decl_Part --
27074 -----------------------------------------
27076 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27078 -- The corresponding Global pragma
27080 Has_In_State : Boolean := False;
27081 Has_In_Out_State : Boolean := False;
27082 Has_Out_State : Boolean := False;
27083 Has_Proof_In_State : Boolean := False;
27084 -- These flags are set when the corresponding Global pragma has a state
27085 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27088 Has_Null_State : Boolean := False;
27089 -- This flag is set when the corresponding Global pragma has at least
27090 -- one state with a null refinement.
27092 In_Constits : Elist_Id := No_Elist;
27093 In_Out_Constits : Elist_Id := No_Elist;
27094 Out_Constits : Elist_Id := No_Elist;
27095 Proof_In_Constits : Elist_Id := No_Elist;
27096 -- These lists contain the entities of all Input, In_Out, Output and
27097 -- Proof_In constituents that appear in Refined_Global and participate
27098 -- in state refinement.
27100 In_Items : Elist_Id := No_Elist;
27101 In_Out_Items : Elist_Id := No_Elist;
27102 Out_Items : Elist_Id := No_Elist;
27103 Proof_In_Items : Elist_Id := No_Elist;
27104 -- These lists contain the entities of all Input, In_Out, Output and
27105 -- Proof_In items defined in the corresponding Global pragma.
27107 Repeat_Items : Elist_Id := No_Elist;
27108 -- A list of all global items without full visible refinement found
27109 -- in pragma Global. These states should be repeated in the global
27110 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27111 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27113 Spec_Id : Entity_Id;
27114 -- The entity of the subprogram subject to pragma Refined_Global
27116 States : Elist_Id := No_Elist;
27117 -- A list of all states with full or partial visible refinement found in
27120 procedure Check_In_Out_States;
27121 -- Determine whether the corresponding Global pragma mentions In_Out
27122 -- states with visible refinement and if so, ensure that one of the
27123 -- following completions apply to the constituents of the state:
27124 -- 1) there is at least one constituent of mode In_Out
27125 -- 2) there is at least one Input and one Output constituent
27126 -- 3) not all constituents are present and one of them is of mode
27128 -- This routine may remove elements from In_Constits, In_Out_Constits,
27129 -- Out_Constits and Proof_In_Constits.
27131 procedure Check_Input_States;
27132 -- Determine whether the corresponding Global pragma mentions Input
27133 -- states with visible refinement and if so, ensure that at least one of
27134 -- its constituents appears as an Input item in Refined_Global.
27135 -- This routine may remove elements from In_Constits, In_Out_Constits,
27136 -- Out_Constits and Proof_In_Constits.
27138 procedure Check_Output_States;
27139 -- Determine whether the corresponding Global pragma mentions Output
27140 -- states with visible refinement and if so, ensure that all of its
27141 -- constituents appear as Output items in Refined_Global.
27142 -- This routine may remove elements from In_Constits, In_Out_Constits,
27143 -- Out_Constits and Proof_In_Constits.
27145 procedure Check_Proof_In_States;
27146 -- Determine whether the corresponding Global pragma mentions Proof_In
27147 -- states with visible refinement and if so, ensure that at least one of
27148 -- its constituents appears as a Proof_In item in Refined_Global.
27149 -- This routine may remove elements from In_Constits, In_Out_Constits,
27150 -- Out_Constits and Proof_In_Constits.
27152 procedure Check_Refined_Global_List
27154 Global_Mode : Name_Id := Name_Input);
27155 -- Verify the legality of a single global list declaration. Global_Mode
27156 -- denotes the current mode in effect.
27158 procedure Collect_Global_Items
27160 Mode : Name_Id := Name_Input);
27161 -- Gather all Input, In_Out, Output and Proof_In items from node List
27162 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27163 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27164 -- and Has_Proof_In_State are set when there is at least one abstract
27165 -- state with full or partial visible refinement available in the
27166 -- corresponding mode. Flag Has_Null_State is set when at least state
27167 -- has a null refinement. Mode denotes the current global mode in
27170 function Present_Then_Remove
27172 Item : Entity_Id) return Boolean;
27173 -- Search List for a particular entity Item. If Item has been found,
27174 -- remove it from List. This routine is used to strip lists In_Constits,
27175 -- In_Out_Constits and Out_Constits of valid constituents.
27177 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27178 -- Same as function Present_Then_Remove, but do not report the presence
27179 -- of Item in List.
27181 procedure Report_Extra_Constituents;
27182 -- Emit an error for each constituent found in lists In_Constits,
27183 -- In_Out_Constits and Out_Constits.
27185 procedure Report_Missing_Items;
27186 -- Emit an error for each global item not repeated found in list
27189 -------------------------
27190 -- Check_In_Out_States --
27191 -------------------------
27193 procedure Check_In_Out_States is
27194 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27195 -- Determine whether one of the following coverage scenarios is in
27197 -- 1) there is at least one constituent of mode In_Out or Output
27198 -- 2) there is at least one pair of constituents with modes Input
27199 -- and Output, or Proof_In and Output.
27200 -- 3) there is at least one constituent of mode Output and not all
27201 -- constituents are present.
27202 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27204 -----------------------------
27205 -- Check_Constituent_Usage --
27206 -----------------------------
27208 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27209 Constits : constant Elist_Id :=
27210 Partial_Refinement_Constituents (State_Id);
27211 Constit_Elmt : Elmt_Id;
27212 Constit_Id : Entity_Id;
27213 Has_Missing : Boolean := False;
27214 In_Out_Seen : Boolean := False;
27215 Input_Seen : Boolean := False;
27216 Output_Seen : Boolean := False;
27217 Proof_In_Seen : Boolean := False;
27220 -- Process all the constituents of the state and note their modes
27221 -- within the global refinement.
27223 if Present (Constits) then
27224 Constit_Elmt := First_Elmt (Constits);
27225 while Present (Constit_Elmt) loop
27226 Constit_Id := Node (Constit_Elmt);
27228 if Present_Then_Remove (In_Constits, Constit_Id) then
27229 Input_Seen := True;
27231 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27232 In_Out_Seen := True;
27234 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27235 Output_Seen := True;
27237 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27239 Proof_In_Seen := True;
27242 Has_Missing := True;
27245 Next_Elmt (Constit_Elmt);
27249 -- An In_Out constituent is a valid completion
27251 if In_Out_Seen then
27254 -- A pair of one Input/Proof_In and one Output constituent is a
27255 -- valid completion.
27257 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27260 elsif Output_Seen then
27262 -- A single Output constituent is a valid completion only when
27263 -- some of the other constituents are missing.
27265 if Has_Missing then
27268 -- Otherwise all constituents are of mode Output
27272 ("global refinement of state & must include at least one "
27273 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27277 -- The state lacks a completion. When full refinement is visible,
27278 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27279 -- refinement is visible, emit an error if the abstract state
27280 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27281 -- both are utilized, Check_State_And_Constituent_Use. will issue
27284 elsif not Input_Seen
27285 and then not In_Out_Seen
27286 and then not Output_Seen
27287 and then not Proof_In_Seen
27289 if Has_Visible_Refinement (State_Id)
27290 or else Contains (Repeat_Items, State_Id)
27293 ("missing global refinement of state &", N, State_Id);
27296 -- Otherwise the state has a malformed completion where at least
27297 -- one of the constituents has a different mode.
27301 ("global refinement of state & redefines the mode of its "
27302 & "constituents", N, State_Id);
27304 end Check_Constituent_Usage;
27308 Item_Elmt : Elmt_Id;
27309 Item_Id : Entity_Id;
27311 -- Start of processing for Check_In_Out_States
27314 -- Do not perform this check in an instance because it was already
27315 -- performed successfully in the generic template.
27317 if In_Instance then
27320 -- Inspect the In_Out items of the corresponding Global pragma
27321 -- looking for a state with a visible refinement.
27323 elsif Has_In_Out_State and then Present (In_Out_Items) then
27324 Item_Elmt := First_Elmt (In_Out_Items);
27325 while Present (Item_Elmt) loop
27326 Item_Id := Node (Item_Elmt);
27328 -- Ensure that one of the three coverage variants is satisfied
27330 if Ekind (Item_Id) = E_Abstract_State
27331 and then Has_Non_Null_Visible_Refinement (Item_Id)
27333 Check_Constituent_Usage (Item_Id);
27336 Next_Elmt (Item_Elmt);
27339 end Check_In_Out_States;
27341 ------------------------
27342 -- Check_Input_States --
27343 ------------------------
27345 procedure Check_Input_States is
27346 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27347 -- Determine whether at least one constituent of state State_Id with
27348 -- full or partial visible refinement is used and has mode Input.
27349 -- Ensure that the remaining constituents do not have In_Out or
27350 -- Output modes. Emit an error if this is not the case
27351 -- (SPARK RM 7.2.4(5)).
27353 -----------------------------
27354 -- Check_Constituent_Usage --
27355 -----------------------------
27357 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27358 Constits : constant Elist_Id :=
27359 Partial_Refinement_Constituents (State_Id);
27360 Constit_Elmt : Elmt_Id;
27361 Constit_Id : Entity_Id;
27362 In_Seen : Boolean := False;
27365 if Present (Constits) then
27366 Constit_Elmt := First_Elmt (Constits);
27367 while Present (Constit_Elmt) loop
27368 Constit_Id := Node (Constit_Elmt);
27370 -- At least one of the constituents appears as an Input
27372 if Present_Then_Remove (In_Constits, Constit_Id) then
27375 -- A Proof_In constituent can refine an Input state as long
27376 -- as there is at least one Input constituent present.
27378 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27382 -- The constituent appears in the global refinement, but has
27383 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27385 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27386 or else Present_Then_Remove (Out_Constits, Constit_Id)
27388 Error_Msg_Name_1 := Chars (State_Id);
27390 ("constituent & of state % must have mode `Input` in "
27391 & "global refinement", N, Constit_Id);
27394 Next_Elmt (Constit_Elmt);
27398 -- Not one of the constituents appeared as Input. Always emit an
27399 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27400 -- When only partial refinement is visible, emit an error if the
27401 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27402 -- the case where both are utilized, an error will be issued in
27403 -- Check_State_And_Constituent_Use.
27406 and then (Has_Visible_Refinement (State_Id)
27407 or else Contains (Repeat_Items, State_Id))
27410 ("global refinement of state & must include at least one "
27411 & "constituent of mode `Input`", N, State_Id);
27413 end Check_Constituent_Usage;
27417 Item_Elmt : Elmt_Id;
27418 Item_Id : Entity_Id;
27420 -- Start of processing for Check_Input_States
27423 -- Do not perform this check in an instance because it was already
27424 -- performed successfully in the generic template.
27426 if In_Instance then
27429 -- Inspect the Input items of the corresponding Global pragma looking
27430 -- for a state with a visible refinement.
27432 elsif Has_In_State and then Present (In_Items) then
27433 Item_Elmt := First_Elmt (In_Items);
27434 while Present (Item_Elmt) loop
27435 Item_Id := Node (Item_Elmt);
27437 -- When full refinement is visible, ensure that at least one of
27438 -- the constituents is utilized and is of mode Input. When only
27439 -- partial refinement is visible, ensure that either one of
27440 -- the constituents is utilized and is of mode Input, or the
27441 -- abstract state is repeated and no constituent is utilized.
27443 if Ekind (Item_Id) = E_Abstract_State
27444 and then Has_Non_Null_Visible_Refinement (Item_Id)
27446 Check_Constituent_Usage (Item_Id);
27449 Next_Elmt (Item_Elmt);
27452 end Check_Input_States;
27454 -------------------------
27455 -- Check_Output_States --
27456 -------------------------
27458 procedure Check_Output_States is
27459 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27460 -- Determine whether all constituents of state State_Id with full
27461 -- visible refinement are used and have mode Output. Emit an error
27462 -- if this is not the case (SPARK RM 7.2.4(5)).
27464 -----------------------------
27465 -- Check_Constituent_Usage --
27466 -----------------------------
27468 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27469 Constits : constant Elist_Id :=
27470 Partial_Refinement_Constituents (State_Id);
27471 Only_Partial : constant Boolean :=
27472 not Has_Visible_Refinement (State_Id);
27473 Constit_Elmt : Elmt_Id;
27474 Constit_Id : Entity_Id;
27475 Posted : Boolean := False;
27478 if Present (Constits) then
27479 Constit_Elmt := First_Elmt (Constits);
27480 while Present (Constit_Elmt) loop
27481 Constit_Id := Node (Constit_Elmt);
27483 -- Issue an error when a constituent of State_Id is utilized
27484 -- and State_Id has only partial visible refinement
27485 -- (SPARK RM 7.2.4(3d)).
27487 if Only_Partial then
27488 if Present_Then_Remove (Out_Constits, Constit_Id)
27489 or else Present_Then_Remove (In_Constits, Constit_Id)
27491 Present_Then_Remove (In_Out_Constits, Constit_Id)
27493 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27495 Error_Msg_Name_1 := Chars (State_Id);
27497 ("constituent & of state % cannot be used in global "
27498 & "refinement", N, Constit_Id);
27499 Error_Msg_Name_1 := Chars (State_Id);
27500 SPARK_Msg_N ("\use state % instead", N);
27503 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27506 -- The constituent appears in the global refinement, but has
27507 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27509 elsif Present_Then_Remove (In_Constits, Constit_Id)
27510 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27511 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27513 Error_Msg_Name_1 := Chars (State_Id);
27515 ("constituent & of state % must have mode `Output` in "
27516 & "global refinement", N, Constit_Id);
27518 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27524 ("`Output` state & must be replaced by all its "
27525 & "constituents in global refinement", N, State_Id);
27529 ("\constituent & is missing in output list",
27533 Next_Elmt (Constit_Elmt);
27536 end Check_Constituent_Usage;
27540 Item_Elmt : Elmt_Id;
27541 Item_Id : Entity_Id;
27543 -- Start of processing for Check_Output_States
27546 -- Do not perform this check in an instance because it was already
27547 -- performed successfully in the generic template.
27549 if In_Instance then
27552 -- Inspect the Output items of the corresponding Global pragma
27553 -- looking for a state with a visible refinement.
27555 elsif Has_Out_State and then Present (Out_Items) then
27556 Item_Elmt := First_Elmt (Out_Items);
27557 while Present (Item_Elmt) loop
27558 Item_Id := Node (Item_Elmt);
27560 -- When full refinement is visible, ensure that all of the
27561 -- constituents are utilized and they have mode Output. When
27562 -- only partial refinement is visible, ensure that no
27563 -- constituent is utilized.
27565 if Ekind (Item_Id) = E_Abstract_State
27566 and then Has_Non_Null_Visible_Refinement (Item_Id)
27568 Check_Constituent_Usage (Item_Id);
27571 Next_Elmt (Item_Elmt);
27574 end Check_Output_States;
27576 ---------------------------
27577 -- Check_Proof_In_States --
27578 ---------------------------
27580 procedure Check_Proof_In_States is
27581 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27582 -- Determine whether at least one constituent of state State_Id with
27583 -- full or partial visible refinement is used and has mode Proof_In.
27584 -- Ensure that the remaining constituents do not have Input, In_Out,
27585 -- or Output modes. Emit an error if this is not the case
27586 -- (SPARK RM 7.2.4(5)).
27588 -----------------------------
27589 -- Check_Constituent_Usage --
27590 -----------------------------
27592 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27593 Constits : constant Elist_Id :=
27594 Partial_Refinement_Constituents (State_Id);
27595 Constit_Elmt : Elmt_Id;
27596 Constit_Id : Entity_Id;
27597 Proof_In_Seen : Boolean := False;
27600 if Present (Constits) then
27601 Constit_Elmt := First_Elmt (Constits);
27602 while Present (Constit_Elmt) loop
27603 Constit_Id := Node (Constit_Elmt);
27605 -- At least one of the constituents appears as Proof_In
27607 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27608 Proof_In_Seen := True;
27610 -- The constituent appears in the global refinement, but has
27611 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27613 elsif Present_Then_Remove (In_Constits, Constit_Id)
27614 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27615 or else Present_Then_Remove (Out_Constits, Constit_Id)
27617 Error_Msg_Name_1 := Chars (State_Id);
27619 ("constituent & of state % must have mode `Proof_In` "
27620 & "in global refinement", N, Constit_Id);
27623 Next_Elmt (Constit_Elmt);
27627 -- Not one of the constituents appeared as Proof_In. Always emit
27628 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27629 -- When only partial refinement is visible, emit an error if the
27630 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27631 -- the case where both are utilized, an error will be issued by
27632 -- Check_State_And_Constituent_Use.
27634 if not Proof_In_Seen
27635 and then (Has_Visible_Refinement (State_Id)
27636 or else Contains (Repeat_Items, State_Id))
27639 ("global refinement of state & must include at least one "
27640 & "constituent of mode `Proof_In`", N, State_Id);
27642 end Check_Constituent_Usage;
27646 Item_Elmt : Elmt_Id;
27647 Item_Id : Entity_Id;
27649 -- Start of processing for Check_Proof_In_States
27652 -- Do not perform this check in an instance because it was already
27653 -- performed successfully in the generic template.
27655 if In_Instance then
27658 -- Inspect the Proof_In items of the corresponding Global pragma
27659 -- looking for a state with a visible refinement.
27661 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27662 Item_Elmt := First_Elmt (Proof_In_Items);
27663 while Present (Item_Elmt) loop
27664 Item_Id := Node (Item_Elmt);
27666 -- Ensure that at least one of the constituents is utilized
27667 -- and is of mode Proof_In. When only partial refinement is
27668 -- visible, ensure that either one of the constituents is
27669 -- utilized and is of mode Proof_In, or the abstract state
27670 -- is repeated and no constituent is utilized.
27672 if Ekind (Item_Id) = E_Abstract_State
27673 and then Has_Non_Null_Visible_Refinement (Item_Id)
27675 Check_Constituent_Usage (Item_Id);
27678 Next_Elmt (Item_Elmt);
27681 end Check_Proof_In_States;
27683 -------------------------------
27684 -- Check_Refined_Global_List --
27685 -------------------------------
27687 procedure Check_Refined_Global_List
27689 Global_Mode : Name_Id := Name_Input)
27691 procedure Check_Refined_Global_Item
27693 Global_Mode : Name_Id);
27694 -- Verify the legality of a single global item declaration. Parameter
27695 -- Global_Mode denotes the current mode in effect.
27697 -------------------------------
27698 -- Check_Refined_Global_Item --
27699 -------------------------------
27701 procedure Check_Refined_Global_Item
27703 Global_Mode : Name_Id)
27705 Item_Id : constant Entity_Id := Entity_Of (Item);
27707 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27708 -- Issue a common error message for all mode mismatches. Expect
27709 -- denotes the expected mode.
27711 -----------------------------
27712 -- Inconsistent_Mode_Error --
27713 -----------------------------
27715 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27718 ("global item & has inconsistent modes", Item, Item_Id);
27720 Error_Msg_Name_1 := Global_Mode;
27721 Error_Msg_Name_2 := Expect;
27722 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27723 end Inconsistent_Mode_Error;
27727 Enc_State : Entity_Id := Empty;
27728 -- Encapsulating state for constituent, Empty otherwise
27730 -- Start of processing for Check_Refined_Global_Item
27733 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
27735 Enc_State := Find_Encapsulating_State (States, Item_Id);
27738 -- When the state or object acts as a constituent of another
27739 -- state with a visible refinement, collect it for the state
27740 -- completeness checks performed later on. Note that the item
27741 -- acts as a constituent only when the encapsulating state is
27742 -- present in pragma Global.
27744 if Present (Enc_State)
27745 and then (Has_Visible_Refinement (Enc_State)
27746 or else Has_Partial_Visible_Refinement (Enc_State))
27747 and then Contains (States, Enc_State)
27749 -- If the state has only partial visible refinement, remove it
27750 -- from the list of items that should be repeated from pragma
27753 if not Has_Visible_Refinement (Enc_State) then
27754 Present_Then_Remove (Repeat_Items, Enc_State);
27757 if Global_Mode = Name_Input then
27758 Append_New_Elmt (Item_Id, In_Constits);
27760 elsif Global_Mode = Name_In_Out then
27761 Append_New_Elmt (Item_Id, In_Out_Constits);
27763 elsif Global_Mode = Name_Output then
27764 Append_New_Elmt (Item_Id, Out_Constits);
27766 elsif Global_Mode = Name_Proof_In then
27767 Append_New_Elmt (Item_Id, Proof_In_Constits);
27770 -- When not a constituent, ensure that both occurrences of the
27771 -- item in pragmas Global and Refined_Global match. Also remove
27772 -- it when present from the list of items that should be repeated
27773 -- from pragma Global.
27776 Present_Then_Remove (Repeat_Items, Item_Id);
27778 if Contains (In_Items, Item_Id) then
27779 if Global_Mode /= Name_Input then
27780 Inconsistent_Mode_Error (Name_Input);
27783 elsif Contains (In_Out_Items, Item_Id) then
27784 if Global_Mode /= Name_In_Out then
27785 Inconsistent_Mode_Error (Name_In_Out);
27788 elsif Contains (Out_Items, Item_Id) then
27789 if Global_Mode /= Name_Output then
27790 Inconsistent_Mode_Error (Name_Output);
27793 elsif Contains (Proof_In_Items, Item_Id) then
27796 -- The item does not appear in the corresponding Global pragma,
27797 -- it must be an extra (SPARK RM 7.2.4(3)).
27800 pragma Assert (Present (Global));
27801 Error_Msg_Sloc := Sloc (Global);
27803 ("extra global item & does not refine or repeat any "
27804 & "global item #", Item, Item_Id);
27807 end Check_Refined_Global_Item;
27813 -- Start of processing for Check_Refined_Global_List
27816 -- Do not perform this check in an instance because it was already
27817 -- performed successfully in the generic template.
27819 if In_Instance then
27822 elsif Nkind (List) = N_Null then
27825 -- Single global item declaration
27827 elsif Nkind (List) in N_Expanded_Name
27829 | N_Selected_Component
27831 Check_Refined_Global_Item (List, Global_Mode);
27833 -- Simple global list or moded global list declaration
27835 elsif Nkind (List) = N_Aggregate then
27837 -- The declaration of a simple global list appear as a collection
27840 if Present (Expressions (List)) then
27841 Item := First (Expressions (List));
27842 while Present (Item) loop
27843 Check_Refined_Global_Item (Item, Global_Mode);
27847 -- The declaration of a moded global list appears as a collection
27848 -- of component associations where individual choices denote
27851 elsif Present (Component_Associations (List)) then
27852 Item := First (Component_Associations (List));
27853 while Present (Item) loop
27854 Check_Refined_Global_List
27855 (List => Expression (Item),
27856 Global_Mode => Chars (First (Choices (Item))));
27864 raise Program_Error;
27870 raise Program_Error;
27872 end Check_Refined_Global_List;
27874 --------------------------
27875 -- Collect_Global_Items --
27876 --------------------------
27878 procedure Collect_Global_Items
27880 Mode : Name_Id := Name_Input)
27882 procedure Collect_Global_Item
27884 Item_Mode : Name_Id);
27885 -- Add a single item to the appropriate list. Item_Mode denotes the
27886 -- current mode in effect.
27888 -------------------------
27889 -- Collect_Global_Item --
27890 -------------------------
27892 procedure Collect_Global_Item
27894 Item_Mode : Name_Id)
27896 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27897 -- The above handles abstract views of variables and states built
27898 -- for limited with clauses.
27901 -- Signal that the global list contains at least one abstract
27902 -- state with a visible refinement. Note that the refinement may
27903 -- be null in which case there are no constituents.
27905 if Ekind (Item_Id) = E_Abstract_State then
27906 if Has_Null_Visible_Refinement (Item_Id) then
27907 Has_Null_State := True;
27909 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27910 Append_New_Elmt (Item_Id, States);
27912 if Item_Mode = Name_Input then
27913 Has_In_State := True;
27914 elsif Item_Mode = Name_In_Out then
27915 Has_In_Out_State := True;
27916 elsif Item_Mode = Name_Output then
27917 Has_Out_State := True;
27918 elsif Item_Mode = Name_Proof_In then
27919 Has_Proof_In_State := True;
27924 -- Record global items without full visible refinement found in
27925 -- pragma Global which should be repeated in the global refinement
27926 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27928 if Ekind (Item_Id) /= E_Abstract_State
27929 or else not Has_Visible_Refinement (Item_Id)
27931 Append_New_Elmt (Item_Id, Repeat_Items);
27934 -- Add the item to the proper list
27936 if Item_Mode = Name_Input then
27937 Append_New_Elmt (Item_Id, In_Items);
27938 elsif Item_Mode = Name_In_Out then
27939 Append_New_Elmt (Item_Id, In_Out_Items);
27940 elsif Item_Mode = Name_Output then
27941 Append_New_Elmt (Item_Id, Out_Items);
27942 elsif Item_Mode = Name_Proof_In then
27943 Append_New_Elmt (Item_Id, Proof_In_Items);
27945 end Collect_Global_Item;
27951 -- Start of processing for Collect_Global_Items
27954 if Nkind (List) = N_Null then
27957 -- Single global item declaration
27959 elsif Nkind (List) in N_Expanded_Name
27961 | N_Selected_Component
27963 Collect_Global_Item (List, Mode);
27965 -- Single global list or moded global list declaration
27967 elsif Nkind (List) = N_Aggregate then
27969 -- The declaration of a simple global list appear as a collection
27972 if Present (Expressions (List)) then
27973 Item := First (Expressions (List));
27974 while Present (Item) loop
27975 Collect_Global_Item (Item, Mode);
27979 -- The declaration of a moded global list appears as a collection
27980 -- of component associations where individual choices denote mode.
27982 elsif Present (Component_Associations (List)) then
27983 Item := First (Component_Associations (List));
27984 while Present (Item) loop
27985 Collect_Global_Items
27986 (List => Expression (Item),
27987 Mode => Chars (First (Choices (Item))));
27995 raise Program_Error;
27998 -- To accommodate partial decoration of disabled SPARK features, this
27999 -- routine may be called with illegal input. If this is the case, do
28000 -- not raise Program_Error.
28005 end Collect_Global_Items;
28007 -------------------------
28008 -- Present_Then_Remove --
28009 -------------------------
28011 function Present_Then_Remove
28013 Item : Entity_Id) return Boolean
28018 if Present (List) then
28019 Elmt := First_Elmt (List);
28020 while Present (Elmt) loop
28021 if Node (Elmt) = Item then
28022 Remove_Elmt (List, Elmt);
28031 end Present_Then_Remove;
28033 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28036 Ignore := Present_Then_Remove (List, Item);
28037 end Present_Then_Remove;
28039 -------------------------------
28040 -- Report_Extra_Constituents --
28041 -------------------------------
28043 procedure Report_Extra_Constituents is
28044 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28045 -- Emit an error for every element of List
28047 ---------------------------------------
28048 -- Report_Extra_Constituents_In_List --
28049 ---------------------------------------
28051 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28052 Constit_Elmt : Elmt_Id;
28055 if Present (List) then
28056 Constit_Elmt := First_Elmt (List);
28057 while Present (Constit_Elmt) loop
28058 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28059 Next_Elmt (Constit_Elmt);
28062 end Report_Extra_Constituents_In_List;
28064 -- Start of processing for Report_Extra_Constituents
28067 -- Do not perform this check in an instance because it was already
28068 -- performed successfully in the generic template.
28070 if In_Instance then
28074 Report_Extra_Constituents_In_List (In_Constits);
28075 Report_Extra_Constituents_In_List (In_Out_Constits);
28076 Report_Extra_Constituents_In_List (Out_Constits);
28077 Report_Extra_Constituents_In_List (Proof_In_Constits);
28079 end Report_Extra_Constituents;
28081 --------------------------
28082 -- Report_Missing_Items --
28083 --------------------------
28085 procedure Report_Missing_Items is
28086 Item_Elmt : Elmt_Id;
28087 Item_Id : Entity_Id;
28090 -- Do not perform this check in an instance because it was already
28091 -- performed successfully in the generic template.
28093 if In_Instance then
28097 if Present (Repeat_Items) then
28098 Item_Elmt := First_Elmt (Repeat_Items);
28099 while Present (Item_Elmt) loop
28100 Item_Id := Node (Item_Elmt);
28101 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28102 Next_Elmt (Item_Elmt);
28106 end Report_Missing_Items;
28110 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28111 Errors : constant Nat := Serious_Errors_Detected;
28113 No_Constit : Boolean;
28115 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28118 -- Do not analyze the pragma multiple times
28120 if Is_Analyzed_Pragma (N) then
28124 Spec_Id := Unique_Defining_Entity (Body_Decl);
28126 -- Use the anonymous object as the proper spec when Refined_Global
28127 -- applies to the body of a single task type. The object carries the
28128 -- proper Chars as well as all non-refined versions of pragmas.
28130 if Is_Single_Concurrent_Type (Spec_Id) then
28131 Spec_Id := Anonymous_Object (Spec_Id);
28134 Global := Get_Pragma (Spec_Id, Pragma_Global);
28135 Items := Expression (Get_Argument (N, Spec_Id));
28137 -- The subprogram declaration lacks pragma Global. This renders
28138 -- Refined_Global useless as there is nothing to refine.
28140 if No (Global) then
28142 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28143 & "& lacks aspect or pragma Global"), N, Spec_Id);
28147 -- Extract all relevant items from the corresponding Global pragma
28149 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28151 -- Package and subprogram bodies are instantiated individually in
28152 -- a separate compiler pass. Due to this mode of instantiation, the
28153 -- refinement of a state may no longer be visible when a subprogram
28154 -- body contract is instantiated. Since the generic template is legal,
28155 -- do not perform this check in the instance to circumvent this oddity.
28157 if In_Instance then
28160 -- Non-instance case
28163 -- The corresponding Global pragma must mention at least one
28164 -- state with a visible refinement at the point Refined_Global
28165 -- is processed. States with null refinements need Refined_Global
28166 -- pragma (SPARK RM 7.2.4(2)).
28168 if not Has_In_State
28169 and then not Has_In_Out_State
28170 and then not Has_Out_State
28171 and then not Has_Proof_In_State
28172 and then not Has_Null_State
28175 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28176 & "depend on abstract state with visible refinement"),
28180 -- The global refinement of inputs and outputs cannot be null when
28181 -- the corresponding Global pragma contains at least one item except
28182 -- in the case where we have states with null refinements.
28184 elsif Nkind (Items) = N_Null
28186 (Present (In_Items)
28187 or else Present (In_Out_Items)
28188 or else Present (Out_Items)
28189 or else Present (Proof_In_Items))
28190 and then not Has_Null_State
28193 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28194 & "global items"), N, Spec_Id);
28199 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28200 -- This ensures that the categorization of all refined global items is
28201 -- consistent with their role.
28203 Analyze_Global_In_Decl_Part (N);
28205 -- Perform all refinement checks with respect to completeness and mode
28208 if Serious_Errors_Detected = Errors then
28209 Check_Refined_Global_List (Items);
28212 -- Store the information that no constituent is used in the global
28213 -- refinement, prior to calling checking procedures which remove items
28214 -- from the list of constituents.
28218 and then No (In_Out_Constits)
28219 and then No (Out_Constits)
28220 and then No (Proof_In_Constits);
28222 -- For Input states with visible refinement, at least one constituent
28223 -- must be used as an Input in the global refinement.
28225 if Serious_Errors_Detected = Errors then
28226 Check_Input_States;
28229 -- Verify all possible completion variants for In_Out states with
28230 -- visible refinement.
28232 if Serious_Errors_Detected = Errors then
28233 Check_In_Out_States;
28236 -- For Output states with visible refinement, all constituents must be
28237 -- used as Outputs in the global refinement.
28239 if Serious_Errors_Detected = Errors then
28240 Check_Output_States;
28243 -- For Proof_In states with visible refinement, at least one constituent
28244 -- must be used as Proof_In in the global refinement.
28246 if Serious_Errors_Detected = Errors then
28247 Check_Proof_In_States;
28250 -- Emit errors for all constituents that belong to other states with
28251 -- visible refinement that do not appear in Global.
28253 if Serious_Errors_Detected = Errors then
28254 Report_Extra_Constituents;
28257 -- Emit errors for all items in Global that are not repeated in the
28258 -- global refinement and for which there is no full visible refinement
28259 -- and, in the case of states with partial visible refinement, no
28260 -- constituent is mentioned in the global refinement.
28262 if Serious_Errors_Detected = Errors then
28263 Report_Missing_Items;
28266 -- Emit an error if no constituent is used in the global refinement
28267 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28268 -- one may be issued by the checking procedures. Do not perform this
28269 -- check in an instance because it was already performed successfully
28270 -- in the generic template.
28272 if Serious_Errors_Detected = Errors
28273 and then not In_Instance
28274 and then not Has_Null_State
28275 and then No_Constit
28277 SPARK_Msg_N ("missing refinement", N);
28281 Set_Is_Analyzed_Pragma (N);
28282 end Analyze_Refined_Global_In_Decl_Part;
28284 ----------------------------------------
28285 -- Analyze_Refined_State_In_Decl_Part --
28286 ----------------------------------------
28288 procedure Analyze_Refined_State_In_Decl_Part
28290 Freeze_Id : Entity_Id := Empty)
28292 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28293 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28294 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28296 Available_States : Elist_Id := No_Elist;
28297 -- A list of all abstract states defined in the package declaration that
28298 -- are available for refinement. The list is used to report unrefined
28301 Body_States : Elist_Id := No_Elist;
28302 -- A list of all hidden states that appear in the body of the related
28303 -- package. The list is used to report unused hidden states.
28305 Constituents_Seen : Elist_Id := No_Elist;
28306 -- A list that contains all constituents processed so far. The list is
28307 -- used to detect multiple uses of the same constituent.
28309 Freeze_Posted : Boolean := False;
28310 -- A flag that controls the output of a freezing-related error (see use
28313 Refined_States_Seen : Elist_Id := No_Elist;
28314 -- A list that contains all refined states processed so far. The list is
28315 -- used to detect duplicate refinements.
28317 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28318 -- Perform full analysis of a single refinement clause
28320 procedure Report_Unrefined_States (States : Elist_Id);
28321 -- Emit errors for all unrefined abstract states found in list States
28323 -------------------------------
28324 -- Analyze_Refinement_Clause --
28325 -------------------------------
28327 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28328 AR_Constit : Entity_Id := Empty;
28329 AW_Constit : Entity_Id := Empty;
28330 ER_Constit : Entity_Id := Empty;
28331 EW_Constit : Entity_Id := Empty;
28332 -- The entities of external constituents that contain one of the
28333 -- following enabled properties: Async_Readers, Async_Writers,
28334 -- Effective_Reads and Effective_Writes.
28336 External_Constit_Seen : Boolean := False;
28337 -- Flag used to mark when at least one external constituent is part
28338 -- of the state refinement.
28340 Non_Null_Seen : Boolean := False;
28341 Null_Seen : Boolean := False;
28342 -- Flags used to detect multiple uses of null in a single clause or a
28343 -- mixture of null and non-null constituents.
28345 Part_Of_Constits : Elist_Id := No_Elist;
28346 -- A list of all candidate constituents subject to indicator Part_Of
28347 -- where the encapsulating state is the current state.
28350 State_Id : Entity_Id;
28351 -- The current state being refined
28353 procedure Analyze_Constituent (Constit : Node_Id);
28354 -- Perform full analysis of a single constituent
28356 procedure Check_External_Property
28357 (Prop_Nam : Name_Id;
28359 Constit : Entity_Id);
28360 -- Determine whether a property denoted by name Prop_Nam is present
28361 -- in the refined state. Emit an error if this is not the case. Flag
28362 -- Enabled should be set when the property applies to the refined
28363 -- state. Constit denotes the constituent (if any) which introduces
28364 -- the property in the refinement.
28366 procedure Match_State;
28367 -- Determine whether the state being refined appears in list
28368 -- Available_States. Emit an error when attempting to re-refine the
28369 -- state or when the state is not defined in the package declaration,
28370 -- otherwise remove the state from Available_States.
28372 procedure Report_Unused_Constituents (Constits : Elist_Id);
28373 -- Emit errors for all unused Part_Of constituents in list Constits
28375 -------------------------
28376 -- Analyze_Constituent --
28377 -------------------------
28379 procedure Analyze_Constituent (Constit : Node_Id) is
28380 procedure Match_Constituent (Constit_Id : Entity_Id);
28381 -- Determine whether constituent Constit denoted by its entity
28382 -- Constit_Id appears in Body_States. Emit an error when the
28383 -- constituent is not a valid hidden state of the related package
28384 -- or when it is used more than once. Otherwise remove the
28385 -- constituent from Body_States.
28387 -----------------------
28388 -- Match_Constituent --
28389 -----------------------
28391 procedure Match_Constituent (Constit_Id : Entity_Id) is
28392 procedure Collect_Constituent;
28393 -- Verify the legality of constituent Constit_Id and add it to
28394 -- the refinements of State_Id.
28396 -------------------------
28397 -- Collect_Constituent --
28398 -------------------------
28400 procedure Collect_Constituent is
28401 Constits : Elist_Id;
28404 -- The Ghost policy in effect at the point of abstract state
28405 -- declaration and constituent must match (SPARK RM 6.9(15))
28407 Check_Ghost_Refinement
28408 (State, State_Id, Constit, Constit_Id);
28410 -- A synchronized state must be refined by a synchronized
28411 -- object or another synchronized state (SPARK RM 9.6).
28413 if Is_Synchronized_State (State_Id)
28414 and then not Is_Synchronized_Object (Constit_Id)
28415 and then not Is_Synchronized_State (Constit_Id)
28418 ("constituent of synchronized state & must be "
28419 & "synchronized", Constit, State_Id);
28422 -- Add the constituent to the list of processed items to aid
28423 -- with the detection of duplicates.
28425 Append_New_Elmt (Constit_Id, Constituents_Seen);
28427 -- Collect the constituent in the list of refinement items
28428 -- and establish a relation between the refined state and
28431 Constits := Refinement_Constituents (State_Id);
28433 if No (Constits) then
28434 Constits := New_Elmt_List;
28435 Set_Refinement_Constituents (State_Id, Constits);
28438 Append_Elmt (Constit_Id, Constits);
28439 Set_Encapsulating_State (Constit_Id, State_Id);
28441 -- The state has at least one legal constituent, mark the
28442 -- start of the refinement region. The region ends when the
28443 -- body declarations end (see routine Analyze_Declarations).
28445 Set_Has_Visible_Refinement (State_Id);
28447 -- When the constituent is external, save its relevant
28448 -- property for further checks.
28450 if Async_Readers_Enabled (Constit_Id) then
28451 AR_Constit := Constit_Id;
28452 External_Constit_Seen := True;
28455 if Async_Writers_Enabled (Constit_Id) then
28456 AW_Constit := Constit_Id;
28457 External_Constit_Seen := True;
28460 if Effective_Reads_Enabled (Constit_Id) then
28461 ER_Constit := Constit_Id;
28462 External_Constit_Seen := True;
28465 if Effective_Writes_Enabled (Constit_Id) then
28466 EW_Constit := Constit_Id;
28467 External_Constit_Seen := True;
28469 end Collect_Constituent;
28473 State_Elmt : Elmt_Id;
28475 -- Start of processing for Match_Constituent
28478 -- Detect a duplicate use of a constituent
28480 if Contains (Constituents_Seen, Constit_Id) then
28482 ("duplicate use of constituent &", Constit, Constit_Id);
28486 -- The constituent is subject to a Part_Of indicator
28488 if Present (Encapsulating_State (Constit_Id)) then
28489 if Encapsulating_State (Constit_Id) = State_Id then
28490 Remove (Part_Of_Constits, Constit_Id);
28491 Collect_Constituent;
28493 -- The constituent is part of another state and is used
28494 -- incorrectly in the refinement of the current state.
28497 Error_Msg_Name_1 := Chars (State_Id);
28499 ("& cannot act as constituent of state %",
28500 Constit, Constit_Id);
28502 ("\Part_Of indicator specifies encapsulator &",
28503 Constit, Encapsulating_State (Constit_Id));
28508 Pack_Id : Entity_Id;
28509 Placement : State_Space_Kind;
28511 -- Find where the constituent lives with respect to the
28514 Find_Placement_In_State_Space
28515 (Item_Id => Constit_Id,
28516 Placement => Placement,
28517 Pack_Id => Pack_Id);
28519 -- The constituent is part of the visible state of a
28520 -- private child package, but lacks a Part_Of indicator.
28522 if Placement = Visible_State_Space
28523 and then Is_Child_Unit (Pack_Id)
28524 and then not Is_Generic_Unit (Pack_Id)
28525 and then Is_Private_Descendant (Pack_Id)
28527 Error_Msg_Name_1 := Chars (State_Id);
28529 ("& cannot act as constituent of state %",
28530 Constit, Constit_Id);
28532 Sloc (Enclosing_Declaration (Constit_Id));
28534 ("\missing Part_Of indicator # should specify "
28535 & "encapsulator &",
28536 Constit, State_Id);
28538 -- The only other source of legal constituents is the
28539 -- body state space of the related package.
28542 if Present (Body_States) then
28543 State_Elmt := First_Elmt (Body_States);
28544 while Present (State_Elmt) loop
28546 -- Consume a valid constituent to signal that it
28547 -- has been encountered.
28549 if Node (State_Elmt) = Constit_Id then
28550 Remove_Elmt (Body_States, State_Elmt);
28551 Collect_Constituent;
28555 Next_Elmt (State_Elmt);
28559 -- At this point it is known that the constituent is
28560 -- not part of the package hidden state and cannot be
28561 -- used in a refinement (SPARK RM 7.2.2(9)).
28563 Error_Msg_Name_1 := Chars (Spec_Id);
28565 ("cannot use & in refinement, constituent is not a "
28566 & "hidden state of package %", Constit, Constit_Id);
28570 end Match_Constituent;
28574 Constit_Id : Entity_Id;
28575 Constits : Elist_Id;
28577 -- Start of processing for Analyze_Constituent
28580 -- Detect multiple uses of null in a single refinement clause or a
28581 -- mixture of null and non-null constituents.
28583 if Nkind (Constit) = N_Null then
28586 ("multiple null constituents not allowed", Constit);
28588 elsif Non_Null_Seen then
28590 ("cannot mix null and non-null constituents", Constit);
28595 -- Collect the constituent in the list of refinement items
28597 Constits := Refinement_Constituents (State_Id);
28599 if No (Constits) then
28600 Constits := New_Elmt_List;
28601 Set_Refinement_Constituents (State_Id, Constits);
28604 Append_Elmt (Constit, Constits);
28606 -- The state has at least one legal constituent, mark the
28607 -- start of the refinement region. The region ends when the
28608 -- body declarations end (see Analyze_Declarations).
28610 Set_Has_Visible_Refinement (State_Id);
28613 -- Non-null constituents
28616 Non_Null_Seen := True;
28620 ("cannot mix null and non-null constituents", Constit);
28624 Resolve_State (Constit);
28626 -- Ensure that the constituent denotes a valid state or a
28627 -- whole object (SPARK RM 7.2.2(5)).
28629 if Is_Entity_Name (Constit) then
28630 Constit_Id := Entity_Of (Constit);
28632 -- When a constituent is declared after a subprogram body
28633 -- that caused freezing of the related contract where
28634 -- pragma Refined_State resides, the constituent appears
28635 -- undefined and carries Any_Id as its entity.
28637 -- package body Pack
28638 -- with Refined_State => (State => Constit)
28641 -- with Refined_Global => (Input => Constit)
28649 if Constit_Id = Any_Id then
28650 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28652 -- Emit a specialized info message when the contract of
28653 -- the related package body was "frozen" by another body.
28654 -- Note that it is not possible to precisely identify why
28655 -- the constituent is undefined because it is not visible
28656 -- when pragma Refined_State is analyzed. This message is
28657 -- a reasonable approximation.
28659 if Present (Freeze_Id) and then not Freeze_Posted then
28660 Freeze_Posted := True;
28662 Error_Msg_Name_1 := Chars (Body_Id);
28663 Error_Msg_Sloc := Sloc (Freeze_Id);
28665 ("body & declared # freezes the contract of %",
28668 ("\all constituents must be declared before body #",
28671 -- A misplaced constituent is a critical error because
28672 -- pragma Refined_Depends or Refined_Global depends on
28673 -- the proper link between a state and a constituent.
28674 -- Stop the compilation, as this leads to a multitude
28675 -- of misleading cascaded errors.
28677 raise Unrecoverable_Error;
28680 -- The constituent is a valid state or object
28682 elsif Ekind (Constit_Id) in
28683 E_Abstract_State | E_Constant | E_Variable
28685 Match_Constituent (Constit_Id);
28687 -- The variable may eventually become a constituent of a
28688 -- single protected/task type. Record the reference now
28689 -- and verify its legality when analyzing the contract of
28690 -- the variable (SPARK RM 9.3).
28692 if Ekind (Constit_Id) = E_Variable then
28693 Record_Possible_Part_Of_Reference
28694 (Var_Id => Constit_Id,
28698 -- Otherwise the constituent is illegal
28702 ("constituent & must denote object or state",
28703 Constit, Constit_Id);
28706 -- The constituent is illegal
28709 SPARK_Msg_N ("malformed constituent", Constit);
28712 end Analyze_Constituent;
28714 -----------------------------
28715 -- Check_External_Property --
28716 -----------------------------
28718 procedure Check_External_Property
28719 (Prop_Nam : Name_Id;
28721 Constit : Entity_Id)
28724 -- The property is missing in the declaration of the state, but
28725 -- a constituent is introducing it in the state refinement
28726 -- (SPARK RM 7.2.8(2)).
28728 if not Enabled and then Present (Constit) then
28729 Error_Msg_Name_1 := Prop_Nam;
28730 Error_Msg_Name_2 := Chars (State_Id);
28732 ("constituent & introduces external property % in refinement "
28733 & "of state %", State, Constit);
28735 Error_Msg_Sloc := Sloc (State_Id);
28737 ("\property is missing in abstract state declaration #",
28740 end Check_External_Property;
28746 procedure Match_State is
28747 State_Elmt : Elmt_Id;
28750 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28752 if Contains (Refined_States_Seen, State_Id) then
28754 ("duplicate refinement of state &", State, State_Id);
28758 -- Inspect the abstract states defined in the package declaration
28759 -- looking for a match.
28761 State_Elmt := First_Elmt (Available_States);
28762 while Present (State_Elmt) loop
28764 -- A valid abstract state is being refined in the body. Add
28765 -- the state to the list of processed refined states to aid
28766 -- with the detection of duplicate refinements. Remove the
28767 -- state from Available_States to signal that it has already
28770 if Node (State_Elmt) = State_Id then
28771 Append_New_Elmt (State_Id, Refined_States_Seen);
28772 Remove_Elmt (Available_States, State_Elmt);
28776 Next_Elmt (State_Elmt);
28779 -- If we get here, we are refining a state that is not defined in
28780 -- the package declaration.
28782 Error_Msg_Name_1 := Chars (Spec_Id);
28784 ("cannot refine state, & is not defined in package %",
28788 --------------------------------
28789 -- Report_Unused_Constituents --
28790 --------------------------------
28792 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28793 Constit_Elmt : Elmt_Id;
28794 Constit_Id : Entity_Id;
28795 Posted : Boolean := False;
28798 if Present (Constits) then
28799 Constit_Elmt := First_Elmt (Constits);
28800 while Present (Constit_Elmt) loop
28801 Constit_Id := Node (Constit_Elmt);
28803 -- Generate an error message of the form:
28805 -- state ... has unused Part_Of constituents
28806 -- abstract state ... defined at ...
28807 -- constant ... defined at ...
28808 -- variable ... defined at ...
28813 ("state & has unused Part_Of constituents",
28817 Error_Msg_Sloc := Sloc (Constit_Id);
28819 if Ekind (Constit_Id) = E_Abstract_State then
28821 ("\abstract state & defined #", State, Constit_Id);
28823 elsif Ekind (Constit_Id) = E_Constant then
28825 ("\constant & defined #", State, Constit_Id);
28828 pragma Assert (Ekind (Constit_Id) = E_Variable);
28829 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28832 Next_Elmt (Constit_Elmt);
28835 end Report_Unused_Constituents;
28837 -- Local declarations
28839 Body_Ref : Node_Id;
28840 Body_Ref_Elmt : Elmt_Id;
28842 Extra_State : Node_Id;
28844 -- Start of processing for Analyze_Refinement_Clause
28847 -- A refinement clause appears as a component association where the
28848 -- sole choice is the state and the expressions are the constituents.
28849 -- This is a syntax error, always report.
28851 if Nkind (Clause) /= N_Component_Association then
28852 Error_Msg_N ("malformed state refinement clause", Clause);
28856 -- Analyze the state name of a refinement clause
28858 State := First (Choices (Clause));
28861 Resolve_State (State);
28863 -- Ensure that the state name denotes a valid abstract state that is
28864 -- defined in the spec of the related package.
28866 if Is_Entity_Name (State) then
28867 State_Id := Entity_Of (State);
28869 -- When the abstract state is undefined, it appears as Any_Id. Do
28870 -- not continue with the analysis of the clause.
28872 if State_Id = Any_Id then
28875 -- Catch any attempts to re-refine a state or refine a state that
28876 -- is not defined in the package declaration.
28878 elsif Ekind (State_Id) = E_Abstract_State then
28882 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28886 -- References to a state with visible refinement are illegal.
28887 -- When nested packages are involved, detecting such references is
28888 -- tricky because pragma Refined_State is analyzed later than the
28889 -- offending pragma Depends or Global. References that occur in
28890 -- such nested context are stored in a list. Emit errors for all
28891 -- references found in Body_References (SPARK RM 6.1.4(8)).
28893 if Present (Body_References (State_Id)) then
28894 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28895 while Present (Body_Ref_Elmt) loop
28896 Body_Ref := Node (Body_Ref_Elmt);
28898 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28899 Error_Msg_Sloc := Sloc (State);
28900 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28902 Next_Elmt (Body_Ref_Elmt);
28906 -- The state name is illegal. This is a syntax error, always report.
28909 Error_Msg_N ("malformed state name in refinement clause", State);
28913 -- A refinement clause may only refine one state at a time
28915 Extra_State := Next (State);
28917 if Present (Extra_State) then
28919 ("refinement clause cannot cover multiple states", Extra_State);
28922 -- Replicate the Part_Of constituents of the refined state because
28923 -- the algorithm will consume items.
28925 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28927 -- Analyze all constituents of the refinement. Multiple constituents
28928 -- appear as an aggregate.
28930 Constit := Expression (Clause);
28932 if Nkind (Constit) = N_Aggregate then
28933 if Present (Component_Associations (Constit)) then
28935 ("constituents of refinement clause must appear in "
28936 & "positional form", Constit);
28938 else pragma Assert (Present (Expressions (Constit)));
28939 Constit := First (Expressions (Constit));
28940 while Present (Constit) loop
28941 Analyze_Constituent (Constit);
28946 -- Various forms of a single constituent. Note that these may include
28947 -- malformed constituents.
28950 Analyze_Constituent (Constit);
28953 -- Verify that external constituents do not introduce new external
28954 -- property in the state refinement (SPARK RM 7.2.8(2)).
28956 if Is_External_State (State_Id) then
28957 Check_External_Property
28958 (Prop_Nam => Name_Async_Readers,
28959 Enabled => Async_Readers_Enabled (State_Id),
28960 Constit => AR_Constit);
28962 Check_External_Property
28963 (Prop_Nam => Name_Async_Writers,
28964 Enabled => Async_Writers_Enabled (State_Id),
28965 Constit => AW_Constit);
28967 Check_External_Property
28968 (Prop_Nam => Name_Effective_Reads,
28969 Enabled => Effective_Reads_Enabled (State_Id),
28970 Constit => ER_Constit);
28972 Check_External_Property
28973 (Prop_Nam => Name_Effective_Writes,
28974 Enabled => Effective_Writes_Enabled (State_Id),
28975 Constit => EW_Constit);
28977 -- When a refined state is not external, it should not have external
28978 -- constituents (SPARK RM 7.2.8(1)).
28980 elsif External_Constit_Seen then
28982 ("non-external state & cannot contain external constituents in "
28983 & "refinement", State, State_Id);
28986 -- Ensure that all Part_Of candidate constituents have been mentioned
28987 -- in the refinement clause.
28989 Report_Unused_Constituents (Part_Of_Constits);
28991 -- Avoid a cascading error reporting a missing refinement by adding a
28992 -- dummy constituent.
28994 if No (Refinement_Constituents (State_Id)) then
28995 Set_Refinement_Constituents (State_Id, New_Elmt_List (Any_Id));
28998 -- At this point the refinement might be dummy, but must be
28999 -- well-formed, to prevent cascaded errors.
29001 pragma Assert (Has_Null_Refinement (State_Id)
29003 Has_Non_Null_Refinement (State_Id));
29004 end Analyze_Refinement_Clause;
29006 -----------------------------
29007 -- Report_Unrefined_States --
29008 -----------------------------
29010 procedure Report_Unrefined_States (States : Elist_Id) is
29011 State_Elmt : Elmt_Id;
29014 if Present (States) then
29015 State_Elmt := First_Elmt (States);
29016 while Present (State_Elmt) loop
29018 ("abstract state & must be refined", Node (State_Elmt));
29020 Next_Elmt (State_Elmt);
29023 end Report_Unrefined_States;
29025 -- Local declarations
29027 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29030 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29033 -- Do not analyze the pragma multiple times
29035 if Is_Analyzed_Pragma (N) then
29039 -- Save the scenario for examination by the ABE Processing phase
29041 Record_Elaboration_Scenario (N);
29043 -- Replicate the abstract states declared by the package because the
29044 -- matching algorithm will consume states.
29046 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29048 -- Gather all abstract states and objects declared in the visible
29049 -- state space of the package body. These items must be utilized as
29050 -- constituents in a state refinement.
29052 Body_States := Collect_Body_States (Body_Id);
29054 -- Multiple non-null state refinements appear as an aggregate
29056 if Nkind (Clauses) = N_Aggregate then
29057 if Present (Expressions (Clauses)) then
29059 ("state refinements must appear as component associations",
29062 else pragma Assert (Present (Component_Associations (Clauses)));
29063 Clause := First (Component_Associations (Clauses));
29064 while Present (Clause) loop
29065 Analyze_Refinement_Clause (Clause);
29070 -- Various forms of a single state refinement. Note that these may
29071 -- include malformed refinements.
29074 Analyze_Refinement_Clause (Clauses);
29077 -- List all abstract states that were left unrefined
29079 Report_Unrefined_States (Available_States);
29081 Set_Is_Analyzed_Pragma (N);
29082 end Analyze_Refined_State_In_Decl_Part;
29084 ---------------------------------------------
29085 -- Analyze_Subprogram_Variant_In_Decl_Part --
29086 ---------------------------------------------
29088 -- WARNING: This routine manages Ghost regions. Return statements must be
29089 -- replaced by gotos which jump to the end of the routine and restore the
29092 procedure Analyze_Subprogram_Variant_In_Decl_Part
29094 Freeze_Id : Entity_Id := Empty)
29096 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29097 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29099 procedure Analyze_Variant (Variant : Node_Id);
29100 -- Verify the legality of a single contract case
29102 ---------------------
29103 -- Analyze_Variant --
29104 ---------------------
29106 procedure Analyze_Variant (Variant : Node_Id) is
29107 Direction : Node_Id;
29110 Extra_Direction : Node_Id;
29113 if Nkind (Variant) /= N_Component_Association then
29114 Error_Msg_N ("wrong syntax in subprogram variant", Variant);
29118 Direction := First (Choices (Variant));
29119 Expr := Expression (Variant);
29121 -- Each variant must have exactly one direction
29123 Extra_Direction := Next (Direction);
29125 if Present (Extra_Direction) then
29127 ("subprogram variant case must have exactly one direction",
29131 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
29133 if Nkind (Direction) = N_Identifier then
29134 if Chars (Direction) /= Name_Decreases
29136 Chars (Direction) /= Name_Increases
29138 Error_Msg_N ("wrong direction", Direction);
29141 Error_Msg_N ("wrong syntax", Direction);
29144 Errors := Serious_Errors_Detected;
29145 Preanalyze_Assert_Expression (Expr, Any_Discrete);
29147 -- Emit a clarification message when the variant expression
29148 -- contains at least one undefined reference, possibly due
29149 -- to contract freezing.
29151 if Errors /= Serious_Errors_Detected
29152 and then Present (Freeze_Id)
29153 and then Has_Undefined_Reference (Expr)
29155 Contract_Freeze_Error (Spec_Id, Freeze_Id);
29157 end Analyze_Variant;
29161 Variants : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29163 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
29164 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
29165 -- Save the Ghost-related attributes to restore on exit
29168 Restore_Scope : Boolean := False;
29170 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
29173 -- Do not analyze the pragma multiple times
29175 if Is_Analyzed_Pragma (N) then
29179 -- Set the Ghost mode in effect from the pragma. Due to the delayed
29180 -- analysis of the pragma, the Ghost mode at point of declaration and
29181 -- point of analysis may not necessarily be the same. Use the mode in
29182 -- effect at the point of declaration.
29184 Set_Ghost_Mode (N);
29186 -- Single and multiple contract cases must appear in aggregate form. If
29187 -- this is not the case, then either the parser of the analysis of the
29188 -- pragma failed to produce an aggregate, e.g. when the contract is
29189 -- "null" or a "(null record)".
29192 (if Nkind (Variants) = N_Aggregate
29193 then Null_Record_Present (Variants)
29194 xor (Present (Component_Associations (Variants))
29196 Present (Expressions (Variants)))
29197 else Nkind (Variants) = N_Null);
29199 -- Only "change_direction => discrete_expression" clauses are allowed
29201 if Nkind (Variants) = N_Aggregate
29202 and then Present (Component_Associations (Variants))
29203 and then No (Expressions (Variants))
29206 -- Check that the expression is a proper aggregate (no parentheses)
29208 if Paren_Count (Variants) /= 0 then
29209 Error_Msg -- CODEFIX
29210 ("redundant parentheses", First_Sloc (Variants));
29213 -- Ensure that the formal parameters are visible when analyzing all
29214 -- clauses. This falls out of the general rule of aspects pertaining
29215 -- to subprogram declarations.
29217 if not In_Open_Scopes (Spec_Id) then
29218 Restore_Scope := True;
29219 Push_Scope (Spec_Id);
29221 if Is_Generic_Subprogram (Spec_Id) then
29222 Install_Generic_Formals (Spec_Id);
29224 Install_Formals (Spec_Id);
29228 Variant := First (Component_Associations (Variants));
29229 while Present (Variant) loop
29230 Analyze_Variant (Variant);
29234 if Restore_Scope then
29238 -- Otherwise the pragma is illegal
29241 Error_Msg_N ("wrong syntax for subprogram variant", N);
29244 Set_Is_Analyzed_Pragma (N);
29246 Restore_Ghost_Region (Saved_GM, Saved_IGR);
29247 end Analyze_Subprogram_Variant_In_Decl_Part;
29249 ------------------------------------
29250 -- Analyze_Test_Case_In_Decl_Part --
29251 ------------------------------------
29253 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29254 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29255 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29257 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29258 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29259 -- denoted by Arg_Nam.
29261 ------------------------------
29262 -- Preanalyze_Test_Case_Arg --
29263 ------------------------------
29265 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29269 -- Preanalyze the original aspect argument for a generic subprogram
29270 -- to properly capture global references.
29272 if Is_Generic_Subprogram (Spec_Id) then
29276 Arg_Nam => Arg_Nam,
29277 From_Aspect => True);
29279 if Present (Arg) then
29280 Preanalyze_Assert_Expression
29281 (Expression (Arg), Standard_Boolean);
29285 Arg := Test_Case_Arg (N, Arg_Nam);
29287 if Present (Arg) then
29288 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29290 end Preanalyze_Test_Case_Arg;
29294 Restore_Scope : Boolean := False;
29296 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29299 -- Do not analyze the pragma multiple times
29301 if Is_Analyzed_Pragma (N) then
29305 -- Ensure that the formal parameters are visible when analyzing all
29306 -- clauses. This falls out of the general rule of aspects pertaining
29307 -- to subprogram declarations.
29309 if not In_Open_Scopes (Spec_Id) then
29310 Restore_Scope := True;
29311 Push_Scope (Spec_Id);
29313 if Is_Generic_Subprogram (Spec_Id) then
29314 Install_Generic_Formals (Spec_Id);
29316 Install_Formals (Spec_Id);
29320 Preanalyze_Test_Case_Arg (Name_Requires);
29321 Preanalyze_Test_Case_Arg (Name_Ensures);
29323 if Restore_Scope then
29327 -- Currently it is not possible to inline pre/postconditions on a
29328 -- subprogram subject to pragma Inline_Always.
29330 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29332 Set_Is_Analyzed_Pragma (N);
29333 end Analyze_Test_Case_In_Decl_Part;
29339 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29344 if Present (List) then
29345 Elmt := First_Elmt (List);
29346 while Present (Elmt) loop
29347 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29350 Id := Entity_Of (Node (Elmt));
29353 if Id = Item_Id then
29364 -----------------------------------
29365 -- Build_Pragma_Check_Equivalent --
29366 -----------------------------------
29368 function Build_Pragma_Check_Equivalent
29370 Subp_Id : Entity_Id := Empty;
29371 Inher_Id : Entity_Id := Empty;
29372 Keep_Pragma_Id : Boolean := False) return Node_Id
29374 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29375 -- Detect whether node N references a formal parameter subject to
29376 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29377 -- to False to suppress the generation of a reference when analyzing
29380 ------------------------
29381 -- Suppress_Reference --
29382 ------------------------
29384 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29385 Formal : Entity_Id;
29388 if Is_Entity_Name (N) and then Present (Entity (N)) then
29389 Formal := Entity (N);
29391 -- The formal parameter is subject to pragma Unreferenced. Prevent
29392 -- the generation of references by resetting the Comes_From_Source
29395 if Is_Formal (Formal)
29396 and then Has_Pragma_Unreferenced (Formal)
29398 Set_Comes_From_Source (N, False);
29403 end Suppress_Reference;
29405 procedure Suppress_References is
29406 new Traverse_Proc (Suppress_Reference);
29410 Loc : constant Source_Ptr := Sloc (Prag);
29411 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29412 Check_Prag : Node_Id;
29416 Needs_Wrapper : Boolean;
29417 pragma Unreferenced (Needs_Wrapper);
29419 -- Start of processing for Build_Pragma_Check_Equivalent
29422 -- When the pre- or postcondition is inherited, map the formals of the
29423 -- inherited subprogram to those of the current subprogram. In addition,
29424 -- map primitive operations of the parent type into the corresponding
29425 -- primitive operations of the descendant.
29427 if Present (Inher_Id) then
29428 pragma Assert (Present (Subp_Id));
29430 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29432 -- Use generic machinery to copy inherited pragma, as if it were an
29433 -- instantiation, resetting source locations appropriately, so that
29434 -- expressions inside the inherited pragma use chained locations.
29435 -- This is used in particular in GNATprove to locate precisely
29436 -- messages on a given inherited pragma.
29438 Set_Copied_Sloc_For_Inherited_Pragma
29439 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29440 Check_Prag := New_Copy_Tree (Source => Prag);
29442 -- Build the inherited class-wide condition
29444 Build_Class_Wide_Expression
29445 (Prag => Check_Prag,
29447 Par_Subp => Inher_Id,
29448 Adjust_Sloc => True,
29449 Needs_Wrapper => Needs_Wrapper);
29451 -- If not an inherited condition simply copy the original pragma
29454 Check_Prag := New_Copy_Tree (Source => Prag);
29457 -- Mark the pragma as being internally generated and reset the Analyzed
29460 Set_Analyzed (Check_Prag, False);
29461 Set_Comes_From_Source (Check_Prag, False);
29463 -- The tree of the original pragma may contain references to the
29464 -- formal parameters of the related subprogram. At the same time
29465 -- the corresponding body may mark the formals as unreferenced:
29467 -- procedure Proc (Formal : ...)
29468 -- with Pre => Formal ...;
29470 -- procedure Proc (Formal : ...) is
29471 -- pragma Unreferenced (Formal);
29474 -- This creates problems because all pragma Check equivalents are
29475 -- analyzed at the end of the body declarations. Since all source
29476 -- references have already been accounted for, reset any references
29477 -- to such formals in the generated pragma Check equivalent.
29479 Suppress_References (Check_Prag);
29481 if Present (Corresponding_Aspect (Prag)) then
29482 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29487 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29488 -- the copied pragma in the newly created pragma, convert the copy into
29489 -- pragma Check by correcting the name and adding a check_kind argument.
29491 if not Keep_Pragma_Id then
29492 Set_Class_Present (Check_Prag, False);
29494 Set_Pragma_Identifier
29495 (Check_Prag, Make_Identifier (Loc, Name_Check));
29497 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29498 Make_Pragma_Argument_Association (Loc,
29499 Expression => Make_Identifier (Loc, Nam)));
29502 -- Update the error message when the pragma is inherited
29504 if Present (Inher_Id) then
29505 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29507 if Chars (Msg_Arg) = Name_Message then
29508 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29510 -- Insert "inherited" to improve the error message
29512 if Name_Buffer (1 .. 8) = "failed p" then
29513 Insert_Str_In_Name_Buffer ("inherited ", 8);
29514 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29520 end Build_Pragma_Check_Equivalent;
29522 -----------------------------
29523 -- Check_Applicable_Policy --
29524 -----------------------------
29526 procedure Check_Applicable_Policy (N : Node_Id) is
29530 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29533 -- No effect if not valid assertion kind name
29535 if not Is_Valid_Assertion_Kind (Ename) then
29539 -- Loop through entries in check policy list
29541 PP := Opt.Check_Policy_List;
29542 while Present (PP) loop
29544 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29545 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29549 or else Pnm = Name_Assertion
29550 or else (Pnm = Name_Statement_Assertions
29551 and then Ename in Name_Assert
29552 | Name_Assert_And_Cut
29554 | Name_Loop_Invariant
29555 | Name_Loop_Variant)
29557 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29563 -- In CodePeer mode and GNATprove mode, we need to
29564 -- consider all assertions, unless they are disabled.
29565 -- Force Is_Checked on ignored assertions, in particular
29566 -- because transformations of the AST may depend on
29567 -- assertions being checked (e.g. the translation of
29568 -- attribute 'Loop_Entry).
29570 if CodePeer_Mode or GNATprove_Mode then
29571 Set_Is_Checked (N, True);
29572 Set_Is_Ignored (N, False);
29574 Set_Is_Checked (N, False);
29575 Set_Is_Ignored (N, True);
29581 Set_Is_Checked (N, True);
29582 Set_Is_Ignored (N, False);
29584 when Name_Disable =>
29585 Set_Is_Ignored (N, True);
29586 Set_Is_Checked (N, False);
29587 Set_Is_Disabled (N, True);
29589 -- That should be exhaustive, the null here is a defence
29590 -- against a malformed tree from previous errors.
29599 PP := Next_Pragma (PP);
29603 -- If there are no specific entries that matched, then we let the
29604 -- setting of assertions govern. Note that this provides the needed
29605 -- compatibility with the RM for the cases of assertion, invariant,
29606 -- precondition, predicate, and postcondition. Note also that
29607 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29609 if Assertions_Enabled then
29610 Set_Is_Checked (N, True);
29611 Set_Is_Ignored (N, False);
29613 Set_Is_Checked (N, False);
29614 Set_Is_Ignored (N, True);
29616 end Check_Applicable_Policy;
29618 -------------------------------
29619 -- Check_External_Properties --
29620 -------------------------------
29622 procedure Check_External_Properties
29629 type Properties is array (Positive range 1 .. 4) of Boolean;
29630 type Combinations is array (Positive range <>) of Properties;
29631 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
29632 -- Effective_Reads properties and their combinations, respectively.
29634 Specified : constant Properties := (AR, AW, EW, ER);
29635 -- External properties, as given by the Item pragma
29637 Allowed : constant Combinations :=
29638 (1 => (True, False, True, False),
29639 2 => (False, True, False, True),
29640 3 => (True, False, False, False),
29641 4 => (False, True, False, False),
29642 5 => (True, True, True, False),
29643 6 => (True, True, False, True),
29644 7 => (True, True, False, False),
29645 8 => (True, True, True, True));
29646 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
29649 -- Check if the specified properties match any of the allowed
29650 -- combination; if not, then emit an error.
29652 for J in Allowed'Range loop
29653 if Specified = Allowed (J) then
29659 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29661 end Check_External_Properties;
29667 function Check_Kind (Nam : Name_Id) return Name_Id is
29671 -- Loop through entries in check policy list
29673 PP := Opt.Check_Policy_List;
29674 while Present (PP) loop
29676 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29677 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29681 or else (Pnm = Name_Assertion
29682 and then Is_Valid_Assertion_Kind (Nam))
29683 or else (Pnm = Name_Statement_Assertions
29684 and then Nam in Name_Assert
29685 | Name_Assert_And_Cut
29687 | Name_Loop_Invariant
29688 | Name_Loop_Variant)
29690 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29699 return Name_Ignore;
29701 when Name_Disable =>
29702 return Name_Disable;
29705 raise Program_Error;
29709 PP := Next_Pragma (PP);
29714 -- If there are no specific entries that matched, then we let the
29715 -- setting of assertions govern. Note that this provides the needed
29716 -- compatibility with the RM for the cases of assertion, invariant,
29717 -- precondition, predicate, and postcondition.
29719 if Assertions_Enabled then
29722 return Name_Ignore;
29726 ---------------------------
29727 -- Check_Missing_Part_Of --
29728 ---------------------------
29730 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29731 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29732 -- Determine whether a package denoted by Pack_Id declares at least one
29735 -----------------------
29736 -- Has_Visible_State --
29737 -----------------------
29739 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29740 Item_Id : Entity_Id;
29743 -- Traverse the entity chain of the package trying to find at least
29744 -- one visible abstract state, variable or a package [instantiation]
29745 -- that declares a visible state.
29747 Item_Id := First_Entity (Pack_Id);
29748 while Present (Item_Id)
29749 and then not In_Private_Part (Item_Id)
29751 -- Do not consider internally generated items
29753 if not Comes_From_Source (Item_Id) then
29756 -- Do not consider generic formals or their corresponding actuals
29757 -- because they are not part of a visible state. Note that both
29758 -- entities are marked as hidden.
29760 elsif Is_Hidden (Item_Id) then
29763 -- A visible state has been found. Note that constants are not
29764 -- considered here because it is not possible to determine whether
29765 -- they depend on variable input. This check is left to the SPARK
29768 elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
29771 -- Recursively peek into nested packages and instantiations
29773 elsif Ekind (Item_Id) = E_Package
29774 and then Has_Visible_State (Item_Id)
29779 Next_Entity (Item_Id);
29783 end Has_Visible_State;
29787 Pack_Id : Entity_Id;
29788 Placement : State_Space_Kind;
29790 -- Start of processing for Check_Missing_Part_Of
29793 -- Do not consider abstract states, variables or package instantiations
29794 -- coming from an instance as those always inherit the Part_Of indicator
29795 -- of the instance itself.
29797 if In_Instance then
29800 -- Do not consider internally generated entities as these can never
29801 -- have a Part_Of indicator.
29803 elsif not Comes_From_Source (Item_Id) then
29806 -- Perform these checks only when SPARK_Mode is enabled as they will
29807 -- interfere with standard Ada rules and produce false positives.
29809 elsif SPARK_Mode /= On then
29812 -- Do not consider constants, because the compiler cannot accurately
29813 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29814 -- act as a hidden state of a package.
29816 elsif Ekind (Item_Id) = E_Constant then
29820 -- Find where the abstract state, variable or package instantiation
29821 -- lives with respect to the state space.
29823 Find_Placement_In_State_Space
29824 (Item_Id => Item_Id,
29825 Placement => Placement,
29826 Pack_Id => Pack_Id);
29828 -- Items that appear in a non-package construct (subprogram, block, etc)
29829 -- do not require a Part_Of indicator because they can never act as a
29832 if Placement = Not_In_Package then
29835 -- An item declared in the body state space of a package always act as a
29836 -- constituent and does not need explicit Part_Of indicator.
29838 elsif Placement = Body_State_Space then
29841 -- In general an item declared in the visible state space of a package
29842 -- does not require a Part_Of indicator. The only exception is when the
29843 -- related package is a nongeneric private child unit, in which case
29844 -- Part_Of must denote a state in the parent unit or in one of its
29847 elsif Placement = Visible_State_Space then
29848 if Is_Child_Unit (Pack_Id)
29849 and then not Is_Generic_Unit (Pack_Id)
29850 and then Is_Private_Descendant (Pack_Id)
29852 -- A package instantiation does not need a Part_Of indicator when
29853 -- the related generic template has no visible state.
29855 if Ekind (Item_Id) = E_Package
29856 and then Is_Generic_Instance (Item_Id)
29857 and then not Has_Visible_State (Item_Id)
29861 -- All other cases require Part_Of
29865 ("indicator Part_Of is required in this context "
29866 & "(SPARK RM 7.2.6(3))", Item_Id);
29867 Error_Msg_Name_1 := Chars (Pack_Id);
29869 ("\& is declared in the visible part of private child "
29870 & "unit %", Item_Id);
29874 -- When the item appears in the private state space of a package, it
29875 -- must be a part of some state declared by the said package.
29877 else pragma Assert (Placement = Private_State_Space);
29879 -- The related package does not declare a state, the item cannot act
29880 -- as a Part_Of constituent.
29882 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29885 -- A package instantiation does not need a Part_Of indicator when the
29886 -- related generic template has no visible state.
29888 elsif Ekind (Item_Id) = E_Package
29889 and then Is_Generic_Instance (Item_Id)
29890 and then not Has_Visible_State (Item_Id)
29894 -- All other cases require Part_Of
29898 ("indicator Part_Of is required in this context "
29899 & "(SPARK RM 7.2.6(2))", Item_Id);
29900 Error_Msg_Name_1 := Chars (Pack_Id);
29902 ("\& is declared in the private part of package %", Item_Id);
29905 end Check_Missing_Part_Of;
29907 ---------------------------------------------------
29908 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29909 ---------------------------------------------------
29911 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29913 Spec_Id : Entity_Id)
29916 if Warn_On_Redundant_Constructs
29917 and then Has_Pragma_Inline_Always (Spec_Id)
29918 and then Assertions_Enabled
29920 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29922 if From_Aspect_Specification (Prag) then
29924 ("aspect % not enforced on inlined subprogram &?r?",
29925 Corresponding_Aspect (Prag), Spec_Id);
29928 ("pragma % not enforced on inlined subprogram &?r?",
29932 end Check_Postcondition_Use_In_Inlined_Subprogram;
29934 -------------------------------------
29935 -- Check_State_And_Constituent_Use --
29936 -------------------------------------
29938 procedure Check_State_And_Constituent_Use
29939 (States : Elist_Id;
29940 Constits : Elist_Id;
29943 Constit_Elmt : Elmt_Id;
29944 Constit_Id : Entity_Id;
29945 State_Id : Entity_Id;
29948 -- Nothing to do if there are no states or constituents
29950 if No (States) or else No (Constits) then
29954 -- Inspect the list of constituents and try to determine whether its
29955 -- encapsulating state is in list States.
29957 Constit_Elmt := First_Elmt (Constits);
29958 while Present (Constit_Elmt) loop
29959 Constit_Id := Node (Constit_Elmt);
29961 -- Determine whether the constituent is part of an encapsulating
29962 -- state that appears in the same context and if this is the case,
29963 -- emit an error (SPARK RM 7.2.6(7)).
29965 State_Id := Find_Encapsulating_State (States, Constit_Id);
29967 if Present (State_Id) then
29968 Error_Msg_Name_1 := Chars (Constit_Id);
29970 ("cannot mention state & and its constituent % in the same "
29971 & "context", Context, State_Id);
29975 Next_Elmt (Constit_Elmt);
29977 end Check_State_And_Constituent_Use;
29979 ---------------------------------------------
29980 -- Collect_Inherited_Class_Wide_Conditions --
29981 ---------------------------------------------
29983 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29984 Parent_Subp : constant Entity_Id :=
29985 Ultimate_Alias (Overridden_Operation (Subp));
29986 -- The Overridden_Operation may itself be inherited and as such have no
29987 -- explicit contract.
29989 Prags : constant Node_Id := Contract (Parent_Subp);
29990 In_Spec_Expr : Boolean := In_Spec_Expression;
29991 Installed : Boolean;
29993 New_Prag : Node_Id;
29996 Installed := False;
29998 -- Iterate over the contract of the overridden subprogram to find all
29999 -- inherited class-wide pre- and postconditions.
30001 if Present (Prags) then
30002 Prag := Pre_Post_Conditions (Prags);
30004 while Present (Prag) loop
30005 if Pragma_Name_Unmapped (Prag)
30006 in Name_Precondition | Name_Postcondition
30007 and then Class_Present (Prag)
30009 -- The generated pragma must be analyzed in the context of
30010 -- the subprogram, to make its formals visible. In addition,
30011 -- we must inhibit freezing and full analysis because the
30012 -- controlling type of the subprogram is not frozen yet, and
30013 -- may have further primitives.
30015 if not Installed then
30018 Install_Formals (Subp);
30019 In_Spec_Expr := In_Spec_Expression;
30020 In_Spec_Expression := True;
30024 Build_Pragma_Check_Equivalent
30025 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
30027 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
30028 Preanalyze (New_Prag);
30030 -- Prevent further analysis in subsequent processing of the
30031 -- current list of declarations
30033 Set_Analyzed (New_Prag);
30036 Prag := Next_Pragma (Prag);
30040 In_Spec_Expression := In_Spec_Expr;
30044 end Collect_Inherited_Class_Wide_Conditions;
30046 ---------------------------------------
30047 -- Collect_Subprogram_Inputs_Outputs --
30048 ---------------------------------------
30050 procedure Collect_Subprogram_Inputs_Outputs
30051 (Subp_Id : Entity_Id;
30052 Synthesize : Boolean := False;
30053 Subp_Inputs : in out Elist_Id;
30054 Subp_Outputs : in out Elist_Id;
30055 Global_Seen : out Boolean)
30057 procedure Collect_Dependency_Clause (Clause : Node_Id);
30058 -- Collect all relevant items from a dependency clause
30060 procedure Collect_Global_List
30062 Mode : Name_Id := Name_Input);
30063 -- Collect all relevant items from a global list
30065 -------------------------------
30066 -- Collect_Dependency_Clause --
30067 -------------------------------
30069 procedure Collect_Dependency_Clause (Clause : Node_Id) is
30070 procedure Collect_Dependency_Item
30072 Is_Input : Boolean);
30073 -- Add an item to the proper subprogram input or output collection
30075 -----------------------------
30076 -- Collect_Dependency_Item --
30077 -----------------------------
30079 procedure Collect_Dependency_Item
30081 Is_Input : Boolean)
30086 -- Nothing to collect when the item is null
30088 if Nkind (Item) = N_Null then
30091 -- Ditto for attribute 'Result
30093 elsif Is_Attribute_Result (Item) then
30096 -- Multiple items appear as an aggregate
30098 elsif Nkind (Item) = N_Aggregate then
30099 Extra := First (Expressions (Item));
30100 while Present (Extra) loop
30101 Collect_Dependency_Item (Extra, Is_Input);
30105 -- Otherwise this is a solitary item
30109 Append_New_Elmt (Item, Subp_Inputs);
30111 Append_New_Elmt (Item, Subp_Outputs);
30114 end Collect_Dependency_Item;
30116 -- Start of processing for Collect_Dependency_Clause
30119 if Nkind (Clause) = N_Null then
30122 -- A dependency clause appears as component association
30124 elsif Nkind (Clause) = N_Component_Association then
30125 Collect_Dependency_Item
30126 (Item => Expression (Clause),
30129 Collect_Dependency_Item
30130 (Item => First (Choices (Clause)),
30131 Is_Input => False);
30133 -- To accommodate partial decoration of disabled SPARK features, this
30134 -- routine may be called with illegal input. If this is the case, do
30135 -- not raise Program_Error.
30140 end Collect_Dependency_Clause;
30142 -------------------------
30143 -- Collect_Global_List --
30144 -------------------------
30146 procedure Collect_Global_List
30148 Mode : Name_Id := Name_Input)
30150 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
30151 -- Add an item to the proper subprogram input or output collection
30153 -------------------------
30154 -- Collect_Global_Item --
30155 -------------------------
30157 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
30159 if Mode in Name_In_Out | Name_Input then
30160 Append_New_Elmt (Item, Subp_Inputs);
30163 if Mode in Name_In_Out | Name_Output then
30164 Append_New_Elmt (Item, Subp_Outputs);
30166 end Collect_Global_Item;
30173 -- Start of processing for Collect_Global_List
30176 if Nkind (List) = N_Null then
30179 -- Single global item declaration
30181 elsif Nkind (List) in N_Expanded_Name
30183 | N_Selected_Component
30185 Collect_Global_Item (List, Mode);
30187 -- Simple global list or moded global list declaration
30189 elsif Nkind (List) = N_Aggregate then
30190 if Present (Expressions (List)) then
30191 Item := First (Expressions (List));
30192 while Present (Item) loop
30193 Collect_Global_Item (Item, Mode);
30198 Assoc := First (Component_Associations (List));
30199 while Present (Assoc) loop
30200 Collect_Global_List
30201 (List => Expression (Assoc),
30202 Mode => Chars (First (Choices (Assoc))));
30207 -- To accommodate partial decoration of disabled SPARK features, this
30208 -- routine may be called with illegal input. If this is the case, do
30209 -- not raise Program_Error.
30214 end Collect_Global_List;
30221 Formal : Entity_Id;
30223 Spec_Id : Entity_Id := Empty;
30224 Subp_Decl : Node_Id;
30227 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30230 Global_Seen := False;
30232 -- Process all formal parameters of entries, [generic] subprograms, and
30235 if Ekind (Subp_Id) in E_Entry
30238 | E_Generic_Function
30239 | E_Generic_Procedure
30241 | E_Subprogram_Body
30243 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30244 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30246 -- Process all formal parameters
30248 Formal := First_Entity (Spec_Id);
30249 while Present (Formal) loop
30250 if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
30252 -- IN parameters can act as output when the related type is
30253 -- access-to-variable.
30255 if Ekind (Formal) = E_In_Parameter
30256 and then Is_Access_Variable (Etype (Formal))
30258 Append_New_Elmt (Formal, Subp_Outputs);
30261 Append_New_Elmt (Formal, Subp_Inputs);
30264 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
30265 Append_New_Elmt (Formal, Subp_Outputs);
30267 -- OUT parameters can act as inputs when the related type is
30268 -- tagged, unconstrained array, unconstrained record, or record
30269 -- with unconstrained components.
30271 if Ekind (Formal) = E_Out_Parameter
30272 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30274 Append_New_Elmt (Formal, Subp_Inputs);
30278 Next_Entity (Formal);
30281 -- Otherwise the input denotes a task type, a task body, or the
30282 -- anonymous object created for a single task type.
30284 elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
30285 or else Is_Single_Task_Object (Subp_Id)
30287 Subp_Decl := Declaration_Node (Subp_Id);
30288 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30291 -- When processing an entry, subprogram or task body, look for pragmas
30292 -- Refined_Depends and Refined_Global as they specify the inputs and
30295 if Is_Entry_Body (Subp_Id)
30296 or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
30298 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30299 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30301 -- Subprogram declaration or stand-alone body case, look for pragmas
30302 -- Depends and Global.
30305 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30306 Global := Get_Pragma (Spec_Id, Pragma_Global);
30309 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30310 -- because it provides finer granularity of inputs and outputs.
30312 if Present (Global) then
30313 Global_Seen := True;
30314 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30316 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30317 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30318 -- the inputs and outputs from [Refined_]Depends.
30320 elsif Synthesize and then Present (Depends) then
30321 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30323 -- Multiple dependency clauses appear as an aggregate
30325 if Nkind (Clauses) = N_Aggregate then
30326 Clause := First (Component_Associations (Clauses));
30327 while Present (Clause) loop
30328 Collect_Dependency_Clause (Clause);
30332 -- Otherwise this is a single dependency clause
30335 Collect_Dependency_Clause (Clauses);
30339 -- The current instance of a protected type acts as a formal parameter
30340 -- of mode IN for functions and IN OUT for entries and procedures
30341 -- (SPARK RM 6.1.4).
30343 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30344 Typ := Scope (Spec_Id);
30346 -- Use the anonymous object when the type is single protected
30348 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30349 Typ := Anonymous_Object (Typ);
30352 Append_New_Elmt (Typ, Subp_Inputs);
30354 if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
30355 Append_New_Elmt (Typ, Subp_Outputs);
30358 -- The current instance of a task type acts as a formal parameter of
30359 -- mode IN OUT (SPARK RM 6.1.4).
30361 elsif Ekind (Spec_Id) = E_Task_Type then
30364 -- Use the anonymous object when the type is single task
30366 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30367 Typ := Anonymous_Object (Typ);
30370 Append_New_Elmt (Typ, Subp_Inputs);
30371 Append_New_Elmt (Typ, Subp_Outputs);
30373 elsif Is_Single_Task_Object (Spec_Id) then
30374 Append_New_Elmt (Spec_Id, Subp_Inputs);
30375 Append_New_Elmt (Spec_Id, Subp_Outputs);
30377 end Collect_Subprogram_Inputs_Outputs;
30379 ---------------------------
30380 -- Contract_Freeze_Error --
30381 ---------------------------
30383 procedure Contract_Freeze_Error
30384 (Contract_Id : Entity_Id;
30385 Freeze_Id : Entity_Id)
30388 Error_Msg_Name_1 := Chars (Contract_Id);
30389 Error_Msg_Sloc := Sloc (Freeze_Id);
30392 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30394 ("\all contractual items must be declared before body #", Contract_Id);
30395 end Contract_Freeze_Error;
30397 ---------------------------------
30398 -- Delay_Config_Pragma_Analyze --
30399 ---------------------------------
30401 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30403 return Pragma_Name_Unmapped (N)
30404 in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
30405 end Delay_Config_Pragma_Analyze;
30407 -----------------------
30408 -- Duplication_Error --
30409 -----------------------
30411 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30412 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30413 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30416 Error_Msg_Sloc := Sloc (Prev);
30417 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30419 -- Emit a precise message to distinguish between source pragmas and
30420 -- pragmas generated from aspects. The ordering of the two pragmas is
30424 -- Prag -- duplicate
30426 -- No error is emitted when both pragmas come from aspects because this
30427 -- is already detected by the general aspect analysis mechanism.
30429 if Prag_From_Asp and Prev_From_Asp then
30431 elsif Prag_From_Asp then
30432 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30433 elsif Prev_From_Asp then
30434 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30436 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30438 end Duplication_Error;
30440 ------------------------------
30441 -- Find_Encapsulating_State --
30442 ------------------------------
30444 function Find_Encapsulating_State
30445 (States : Elist_Id;
30446 Constit_Id : Entity_Id) return Entity_Id
30448 State_Id : Entity_Id;
30451 -- Since a constituent may be part of a larger constituent set, climb
30452 -- the encapsulating state chain looking for a state that appears in
30455 State_Id := Encapsulating_State (Constit_Id);
30456 while Present (State_Id) loop
30457 if Contains (States, State_Id) then
30461 State_Id := Encapsulating_State (State_Id);
30465 end Find_Encapsulating_State;
30467 --------------------------
30468 -- Find_Related_Context --
30469 --------------------------
30471 function Find_Related_Context
30473 Do_Checks : Boolean := False) return Node_Id
30478 Stmt := Prev (Prag);
30479 while Present (Stmt) loop
30481 -- Skip prior pragmas, but check for duplicates
30483 if Nkind (Stmt) = N_Pragma then
30485 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30492 -- Skip internally generated code
30494 elsif not Comes_From_Source (Stmt)
30495 and then not Comes_From_Source (Original_Node (Stmt))
30498 -- The anonymous object created for a single concurrent type is a
30499 -- suitable context.
30501 if Nkind (Stmt) = N_Object_Declaration
30502 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30507 -- Return the current source construct
30517 end Find_Related_Context;
30519 --------------------------------------
30520 -- Find_Related_Declaration_Or_Body --
30521 --------------------------------------
30523 function Find_Related_Declaration_Or_Body
30525 Do_Checks : Boolean := False) return Node_Id
30527 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30529 procedure Expression_Function_Error;
30530 -- Emit an error concerning pragma Prag that illegaly applies to an
30531 -- expression function.
30533 -------------------------------
30534 -- Expression_Function_Error --
30535 -------------------------------
30537 procedure Expression_Function_Error is
30539 Error_Msg_Name_1 := Prag_Nam;
30541 -- Emit a precise message to distinguish between source pragmas and
30542 -- pragmas generated from aspects.
30544 if From_Aspect_Specification (Prag) then
30546 ("aspect % cannot apply to a stand alone expression function",
30550 ("pragma % cannot apply to a stand alone expression function",
30553 end Expression_Function_Error;
30557 Context : constant Node_Id := Parent (Prag);
30560 Look_For_Body : constant Boolean :=
30561 Prag_Nam in Name_Refined_Depends
30562 | Name_Refined_Global
30563 | Name_Refined_Post
30564 | Name_Refined_State;
30565 -- Refinement pragmas must be associated with a subprogram body [stub]
30567 -- Start of processing for Find_Related_Declaration_Or_Body
30570 Stmt := Prev (Prag);
30571 while Present (Stmt) loop
30573 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30574 -- by splitting a complex pre/postcondition are not considered to
30577 if Nkind (Stmt) = N_Pragma then
30579 and then not Split_PPC (Stmt)
30580 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30587 -- Emit an error when a refinement pragma appears on an expression
30588 -- function without a completion.
30591 and then Look_For_Body
30592 and then Nkind (Stmt) = N_Subprogram_Declaration
30593 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30594 and then not Has_Completion (Defining_Entity (Stmt))
30596 Expression_Function_Error;
30599 -- The refinement pragma applies to a subprogram body stub
30601 elsif Look_For_Body
30602 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30606 -- Skip internally generated code
30608 elsif not Comes_From_Source (Stmt) then
30610 -- The anonymous object created for a single concurrent type is a
30611 -- suitable context.
30613 if Nkind (Stmt) = N_Object_Declaration
30614 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30618 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30620 -- The subprogram declaration is an internally generated spec
30621 -- for an expression function.
30623 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30626 -- The subprogram declaration is an internally generated spec
30627 -- for a stand-alone subrogram body declared inside a protected
30630 elsif Present (Corresponding_Body (Stmt))
30631 and then Comes_From_Source (Corresponding_Body (Stmt))
30632 and then Is_Protected_Type (Current_Scope)
30636 -- The subprogram is actually an instance housed within an
30637 -- anonymous wrapper package.
30639 elsif Present (Generic_Parent (Specification (Stmt))) then
30642 -- Ada 2020: contract on formal subprogram or on generated
30643 -- Access_Subprogram_Wrapper, which appears after the related
30644 -- Access_Subprogram declaration.
30646 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30647 and then Ada_Version >= Ada_2020
30651 elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
30652 and then Ada_Version >= Ada_2020
30658 -- Return the current construct which is either a subprogram body,
30659 -- a subprogram declaration or is illegal.
30668 -- If we fall through, then the pragma was either the first declaration
30669 -- or it was preceded by other pragmas and no source constructs.
30671 -- The pragma is associated with a library-level subprogram
30673 if Nkind (Context) = N_Compilation_Unit_Aux then
30674 return Unit (Parent (Context));
30676 -- The pragma appears inside the declarations of an entry body
30678 elsif Nkind (Context) = N_Entry_Body then
30681 -- The pragma appears inside the statements of a subprogram body. This
30682 -- placement is the result of subprogram contract expansion.
30684 elsif Is_Statement (Context)
30685 and then Present (Enclosing_HSS (Context))
30687 return Parent (Enclosing_HSS (Context));
30689 -- The pragma appears inside the declarative part of a package body
30691 elsif Nkind (Context) = N_Package_Body then
30694 -- The pragma appears inside the declarative part of a subprogram body
30696 elsif Nkind (Context) = N_Subprogram_Body then
30699 -- The pragma appears inside the declarative part of a task body
30701 elsif Nkind (Context) = N_Task_Body then
30704 -- The pragma appears inside the visible part of a package specification
30706 elsif Nkind (Context) = N_Package_Specification then
30707 return Parent (Context);
30709 -- The pragma is a byproduct of aspect expansion, return the related
30710 -- context of the original aspect. This case has a lower priority as
30711 -- the above circuitry pinpoints precisely the related context.
30713 elsif Present (Corresponding_Aspect (Prag)) then
30714 return Parent (Corresponding_Aspect (Prag));
30716 -- No candidate subprogram [body] found
30721 end Find_Related_Declaration_Or_Body;
30723 ----------------------------------
30724 -- Find_Related_Package_Or_Body --
30725 ----------------------------------
30727 function Find_Related_Package_Or_Body
30729 Do_Checks : Boolean := False) return Node_Id
30731 Context : constant Node_Id := Parent (Prag);
30732 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30736 Stmt := Prev (Prag);
30737 while Present (Stmt) loop
30739 -- Skip prior pragmas, but check for duplicates
30741 if Nkind (Stmt) = N_Pragma then
30742 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30748 -- Skip internally generated code
30750 elsif not Comes_From_Source (Stmt) then
30751 if Nkind (Stmt) = N_Subprogram_Declaration then
30753 -- The subprogram declaration is an internally generated spec
30754 -- for an expression function.
30756 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30759 -- The subprogram is actually an instance housed within an
30760 -- anonymous wrapper package.
30762 elsif Present (Generic_Parent (Specification (Stmt))) then
30767 -- Return the current source construct which is illegal
30776 -- If we fall through, then the pragma was either the first declaration
30777 -- or it was preceded by other pragmas and no source constructs.
30779 -- The pragma is associated with a package. The immediate context in
30780 -- this case is the specification of the package.
30782 if Nkind (Context) = N_Package_Specification then
30783 return Parent (Context);
30785 -- The pragma appears in the declarations of a package body
30787 elsif Nkind (Context) = N_Package_Body then
30790 -- The pragma appears in the statements of a package body
30792 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30793 and then Nkind (Parent (Context)) = N_Package_Body
30795 return Parent (Context);
30797 -- The pragma is a byproduct of aspect expansion, return the related
30798 -- context of the original aspect. This case has a lower priority as
30799 -- the above circuitry pinpoints precisely the related context.
30801 elsif Present (Corresponding_Aspect (Prag)) then
30802 return Parent (Corresponding_Aspect (Prag));
30804 -- No candidate package [body] found
30809 end Find_Related_Package_Or_Body;
30815 function Get_Argument
30817 Context_Id : Entity_Id := Empty) return Node_Id
30819 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30822 -- Use the expression of the original aspect when analyzing the template
30823 -- of a generic unit. In both cases the aspect's tree must be decorated
30824 -- to save the global references in the generic context.
30826 if From_Aspect_Specification (Prag)
30827 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30829 return Corresponding_Aspect (Prag);
30831 -- Otherwise use the expression of the pragma
30833 elsif Present (Args) then
30834 return First (Args);
30841 -------------------------
30842 -- Get_Base_Subprogram --
30843 -------------------------
30845 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30847 -- Follow subprogram renaming chain
30849 if Is_Subprogram (Def_Id)
30850 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30851 N_Subprogram_Renaming_Declaration
30852 and then Present (Alias (Def_Id))
30854 return Alias (Def_Id);
30858 end Get_Base_Subprogram;
30860 -----------------------
30861 -- Get_SPARK_Mode_Type --
30862 -----------------------
30864 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30866 if N = Name_On then
30868 elsif N = Name_Off then
30871 -- Any other argument is illegal. Assume that no SPARK mode applies to
30872 -- avoid potential cascaded errors.
30877 end Get_SPARK_Mode_Type;
30879 ------------------------------------
30880 -- Get_SPARK_Mode_From_Annotation --
30881 ------------------------------------
30883 function Get_SPARK_Mode_From_Annotation
30884 (N : Node_Id) return SPARK_Mode_Type
30889 if Nkind (N) = N_Aspect_Specification then
30890 Mode := Expression (N);
30892 else pragma Assert (Nkind (N) = N_Pragma);
30893 Mode := First (Pragma_Argument_Associations (N));
30895 if Present (Mode) then
30896 Mode := Get_Pragma_Arg (Mode);
30900 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30902 if Present (Mode) then
30903 if Nkind (Mode) = N_Identifier then
30904 return Get_SPARK_Mode_Type (Chars (Mode));
30906 -- In case of a malformed aspect or pragma, return the default None
30912 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30917 end Get_SPARK_Mode_From_Annotation;
30919 ---------------------------
30920 -- Has_Extra_Parentheses --
30921 ---------------------------
30923 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30927 -- The aggregate should not have an expression list because a clause
30928 -- is always interpreted as a component association. The only way an
30929 -- expression list can sneak in is by adding extra parentheses around
30930 -- the individual clauses:
30932 -- Depends (Output => Input) -- proper form
30933 -- Depends ((Output => Input)) -- extra parentheses
30935 -- Since the extra parentheses are not allowed by the syntax of the
30936 -- pragma, flag them now to avoid emitting misleading errors down the
30939 if Nkind (Clause) = N_Aggregate
30940 and then Present (Expressions (Clause))
30942 Expr := First (Expressions (Clause));
30943 while Present (Expr) loop
30945 -- A dependency clause surrounded by extra parentheses appears
30946 -- as an aggregate of component associations with an optional
30947 -- Paren_Count set.
30949 if Nkind (Expr) = N_Aggregate
30950 and then Present (Component_Associations (Expr))
30953 ("dependency clause contains extra parentheses", Expr);
30955 -- Otherwise the expression is a malformed construct
30958 SPARK_Msg_N ("malformed dependency clause", Expr);
30968 end Has_Extra_Parentheses;
30974 procedure Initialize is
30977 Compile_Time_Warnings_Errors.Init;
30986 Dummy := Dummy + 1;
30989 -----------------------------
30990 -- Is_Config_Static_String --
30991 -----------------------------
30993 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30995 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30996 -- This is an internal recursive function that is just like the outer
30997 -- function except that it adds the string to the name buffer rather
30998 -- than placing the string in the name buffer.
31000 ------------------------------
31001 -- Add_Config_Static_String --
31002 ------------------------------
31004 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
31011 if Nkind (N) = N_Op_Concat then
31012 if Add_Config_Static_String (Left_Opnd (N)) then
31013 N := Right_Opnd (N);
31019 if Nkind (N) /= N_String_Literal then
31020 Error_Msg_N ("string literal expected for pragma argument", N);
31024 for J in 1 .. String_Length (Strval (N)) loop
31025 C := Get_String_Char (Strval (N), J);
31027 if not In_Character_Range (C) then
31029 ("string literal contains invalid wide character",
31030 Sloc (N) + 1 + Source_Ptr (J));
31034 Add_Char_To_Name_Buffer (Get_Character (C));
31039 end Add_Config_Static_String;
31041 -- Start of processing for Is_Config_Static_String
31046 return Add_Config_Static_String (Arg);
31047 end Is_Config_Static_String;
31049 -------------------------------
31050 -- Is_Elaboration_SPARK_Mode --
31051 -------------------------------
31053 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
31056 (Nkind (N) = N_Pragma
31057 and then Pragma_Name (N) = Name_SPARK_Mode
31058 and then Is_List_Member (N));
31060 -- Pragma SPARK_Mode affects the elaboration of a package body when it
31061 -- appears in the statement part of the body.
31064 Present (Parent (N))
31065 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
31066 and then List_Containing (N) = Statements (Parent (N))
31067 and then Present (Parent (Parent (N)))
31068 and then Nkind (Parent (Parent (N))) = N_Package_Body;
31069 end Is_Elaboration_SPARK_Mode;
31071 -----------------------
31072 -- Is_Enabled_Pragma --
31073 -----------------------
31075 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
31079 if Present (Prag) then
31080 Arg := First (Pragma_Argument_Associations (Prag));
31082 if Present (Arg) then
31083 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
31085 -- The lack of a Boolean argument automatically enables the pragma
31091 -- The pragma is missing, therefore it is not enabled
31096 end Is_Enabled_Pragma;
31098 -----------------------------------------
31099 -- Is_Non_Significant_Pragma_Reference --
31100 -----------------------------------------
31102 -- This function makes use of the following static table which indicates
31103 -- whether appearance of some name in a given pragma is to be considered
31104 -- as a reference for the purposes of warnings about unreferenced objects.
31106 -- -1 indicates that appearence in any argument is significant
31107 -- 0 indicates that appearance in any argument is not significant
31108 -- +n indicates that appearance as argument n is significant, but all
31109 -- other arguments are not significant
31110 -- 9n arguments from n on are significant, before n insignificant
31112 Sig_Flags : constant array (Pragma_Id) of Int :=
31113 (Pragma_Abort_Defer => -1,
31114 Pragma_Abstract_State => -1,
31115 Pragma_Ada_83 => -1,
31116 Pragma_Ada_95 => -1,
31117 Pragma_Ada_05 => -1,
31118 Pragma_Ada_2005 => -1,
31119 Pragma_Ada_12 => -1,
31120 Pragma_Ada_2012 => -1,
31121 Pragma_Ada_2020 => -1,
31122 Pragma_Aggregate_Individually_Assign => 0,
31123 Pragma_All_Calls_Remote => -1,
31124 Pragma_Allow_Integer_Address => -1,
31125 Pragma_Annotate => 93,
31126 Pragma_Assert => -1,
31127 Pragma_Assert_And_Cut => -1,
31128 Pragma_Assertion_Policy => 0,
31129 Pragma_Assume => -1,
31130 Pragma_Assume_No_Invalid_Values => 0,
31131 Pragma_Async_Readers => 0,
31132 Pragma_Async_Writers => 0,
31133 Pragma_Asynchronous => 0,
31134 Pragma_Atomic => 0,
31135 Pragma_Atomic_Components => 0,
31136 Pragma_Attach_Handler => -1,
31137 Pragma_Attribute_Definition => 92,
31138 Pragma_Check => -1,
31139 Pragma_Check_Float_Overflow => 0,
31140 Pragma_Check_Name => 0,
31141 Pragma_Check_Policy => 0,
31142 Pragma_CPP_Class => 0,
31143 Pragma_CPP_Constructor => 0,
31144 Pragma_CPP_Virtual => 0,
31145 Pragma_CPP_Vtable => 0,
31147 Pragma_C_Pass_By_Copy => 0,
31148 Pragma_Comment => -1,
31149 Pragma_Common_Object => 0,
31150 Pragma_CUDA_Execute => -1,
31151 Pragma_CUDA_Global => -1,
31152 Pragma_Compile_Time_Error => -1,
31153 Pragma_Compile_Time_Warning => -1,
31154 Pragma_Compiler_Unit => -1,
31155 Pragma_Compiler_Unit_Warning => -1,
31156 Pragma_Complete_Representation => 0,
31157 Pragma_Complex_Representation => 0,
31158 Pragma_Component_Alignment => 0,
31159 Pragma_Constant_After_Elaboration => 0,
31160 Pragma_Contract_Cases => -1,
31161 Pragma_Controlled => 0,
31162 Pragma_Convention => 0,
31163 Pragma_Convention_Identifier => 0,
31164 Pragma_Deadline_Floor => -1,
31165 Pragma_Debug => -1,
31166 Pragma_Debug_Policy => 0,
31167 Pragma_Default_Initial_Condition => -1,
31168 Pragma_Default_Scalar_Storage_Order => 0,
31169 Pragma_Default_Storage_Pool => 0,
31170 Pragma_Depends => -1,
31171 Pragma_Detect_Blocking => 0,
31172 Pragma_Disable_Atomic_Synchronization => 0,
31173 Pragma_Discard_Names => 0,
31174 Pragma_Dispatching_Domain => -1,
31175 Pragma_Effective_Reads => 0,
31176 Pragma_Effective_Writes => 0,
31177 Pragma_Elaborate => 0,
31178 Pragma_Elaborate_All => 0,
31179 Pragma_Elaborate_Body => 0,
31180 Pragma_Elaboration_Checks => 0,
31181 Pragma_Eliminate => 0,
31182 Pragma_Enable_Atomic_Synchronization => 0,
31183 Pragma_Export => -1,
31184 Pragma_Export_Function => -1,
31185 Pragma_Export_Object => -1,
31186 Pragma_Export_Procedure => -1,
31187 Pragma_Export_Value => -1,
31188 Pragma_Export_Valued_Procedure => -1,
31189 Pragma_Extend_System => -1,
31190 Pragma_Extensions_Allowed => 0,
31191 Pragma_Extensions_Visible => 0,
31192 Pragma_External => -1,
31193 Pragma_External_Name_Casing => 0,
31194 Pragma_Fast_Math => 0,
31195 Pragma_Favor_Top_Level => 0,
31196 Pragma_Finalize_Storage_Only => 0,
31198 Pragma_Global => -1,
31199 Pragma_Ident => -1,
31200 Pragma_Ignore_Pragma => 0,
31201 Pragma_Implementation_Defined => -1,
31202 Pragma_Implemented => -1,
31203 Pragma_Implicit_Packing => 0,
31204 Pragma_Import => 93,
31205 Pragma_Import_Function => 0,
31206 Pragma_Import_Object => 0,
31207 Pragma_Import_Procedure => 0,
31208 Pragma_Import_Valued_Procedure => 0,
31209 Pragma_Independent => 0,
31210 Pragma_Independent_Components => 0,
31211 Pragma_Initial_Condition => -1,
31212 Pragma_Initialize_Scalars => 0,
31213 Pragma_Initializes => -1,
31214 Pragma_Inline => 0,
31215 Pragma_Inline_Always => 0,
31216 Pragma_Inline_Generic => 0,
31217 Pragma_Inspection_Point => -1,
31218 Pragma_Interface => 92,
31219 Pragma_Interface_Name => 0,
31220 Pragma_Interrupt_Handler => -1,
31221 Pragma_Interrupt_Priority => -1,
31222 Pragma_Interrupt_State => -1,
31223 Pragma_Invariant => -1,
31224 Pragma_Keep_Names => 0,
31225 Pragma_License => 0,
31226 Pragma_Link_With => -1,
31227 Pragma_Linker_Alias => -1,
31228 Pragma_Linker_Constructor => -1,
31229 Pragma_Linker_Destructor => -1,
31230 Pragma_Linker_Options => -1,
31231 Pragma_Linker_Section => -1,
31233 Pragma_Lock_Free => 0,
31234 Pragma_Locking_Policy => 0,
31235 Pragma_Loop_Invariant => -1,
31236 Pragma_Loop_Optimize => 0,
31237 Pragma_Loop_Variant => -1,
31238 Pragma_Machine_Attribute => -1,
31240 Pragma_Main_Storage => -1,
31241 Pragma_Max_Entry_Queue_Depth => 0,
31242 Pragma_Max_Entry_Queue_Length => 0,
31243 Pragma_Max_Queue_Length => 0,
31244 Pragma_Memory_Size => 0,
31245 Pragma_No_Body => 0,
31246 Pragma_No_Caching => 0,
31247 Pragma_No_Component_Reordering => -1,
31248 Pragma_No_Elaboration_Code_All => 0,
31249 Pragma_No_Heap_Finalization => 0,
31250 Pragma_No_Inline => 0,
31251 Pragma_No_Return => 0,
31252 Pragma_No_Run_Time => -1,
31253 Pragma_No_Strict_Aliasing => -1,
31254 Pragma_No_Tagged_Streams => 0,
31255 Pragma_Normalize_Scalars => 0,
31256 Pragma_Obsolescent => 0,
31257 Pragma_Optimize => 0,
31258 Pragma_Optimize_Alignment => 0,
31259 Pragma_Ordered => 0,
31260 Pragma_Overflow_Mode => 0,
31261 Pragma_Overriding_Renamings => 0,
31264 Pragma_Part_Of => 0,
31265 Pragma_Partition_Elaboration_Policy => 0,
31266 Pragma_Passive => 0,
31267 Pragma_Persistent_BSS => 0,
31269 Pragma_Postcondition => -1,
31270 Pragma_Post_Class => -1,
31272 Pragma_Precondition => -1,
31273 Pragma_Predicate => -1,
31274 Pragma_Predicate_Failure => -1,
31275 Pragma_Preelaborable_Initialization => -1,
31276 Pragma_Preelaborate => 0,
31277 Pragma_Prefix_Exception_Messages => 0,
31278 Pragma_Pre_Class => -1,
31279 Pragma_Priority => -1,
31280 Pragma_Priority_Specific_Dispatching => 0,
31281 Pragma_Profile => 0,
31282 Pragma_Profile_Warnings => 0,
31283 Pragma_Propagate_Exceptions => 0,
31284 Pragma_Provide_Shift_Operators => 0,
31285 Pragma_Psect_Object => 0,
31287 Pragma_Pure_Function => 0,
31288 Pragma_Queuing_Policy => 0,
31289 Pragma_Rational => 0,
31290 Pragma_Ravenscar => 0,
31291 Pragma_Refined_Depends => -1,
31292 Pragma_Refined_Global => -1,
31293 Pragma_Refined_Post => -1,
31294 Pragma_Refined_State => -1,
31295 Pragma_Relative_Deadline => 0,
31296 Pragma_Remote_Access_Type => -1,
31297 Pragma_Remote_Call_Interface => -1,
31298 Pragma_Remote_Types => -1,
31299 Pragma_Rename_Pragma => 0,
31300 Pragma_Restricted_Run_Time => 0,
31301 Pragma_Restriction_Warnings => 0,
31302 Pragma_Restrictions => 0,
31303 Pragma_Reviewable => -1,
31304 Pragma_Secondary_Stack_Size => -1,
31305 Pragma_Share_Generic => 0,
31306 Pragma_Shared => 0,
31307 Pragma_Shared_Passive => 0,
31308 Pragma_Short_Circuit_And_Or => 0,
31309 Pragma_Short_Descriptors => 0,
31310 Pragma_Simple_Storage_Pool_Type => 0,
31311 Pragma_Source_File_Name => 0,
31312 Pragma_Source_File_Name_Project => 0,
31313 Pragma_Source_Reference => 0,
31314 Pragma_SPARK_Mode => 0,
31315 Pragma_Static_Elaboration_Desired => 0,
31316 Pragma_Storage_Size => -1,
31317 Pragma_Storage_Unit => 0,
31318 Pragma_Stream_Convert => 0,
31319 Pragma_Style_Checks => 0,
31320 Pragma_Subprogram_Variant => -1,
31321 Pragma_Subtitle => 0,
31322 Pragma_Suppress => 0,
31323 Pragma_Suppress_All => 0,
31324 Pragma_Suppress_Debug_Info => 0,
31325 Pragma_Suppress_Exception_Locations => 0,
31326 Pragma_Suppress_Initialization => 0,
31327 Pragma_System_Name => 0,
31328 Pragma_Task_Dispatching_Policy => 0,
31329 Pragma_Task_Info => -1,
31330 Pragma_Task_Name => -1,
31331 Pragma_Task_Storage => -1,
31332 Pragma_Test_Case => -1,
31333 Pragma_Thread_Local_Storage => -1,
31334 Pragma_Time_Slice => -1,
31336 Pragma_Type_Invariant => -1,
31337 Pragma_Type_Invariant_Class => -1,
31338 Pragma_Unchecked_Union => 0,
31339 Pragma_Unevaluated_Use_Of_Old => 0,
31340 Pragma_Unimplemented_Unit => 0,
31341 Pragma_Universal_Aliasing => 0,
31342 Pragma_Universal_Data => 0,
31343 Pragma_Unmodified => 0,
31344 Pragma_Unreferenced => 0,
31345 Pragma_Unreferenced_Objects => 0,
31346 Pragma_Unreserve_All_Interrupts => 0,
31347 Pragma_Unsuppress => 0,
31348 Pragma_Unused => 0,
31349 Pragma_Use_VADS_Size => 0,
31350 Pragma_Validity_Checks => 0,
31351 Pragma_Volatile => 0,
31352 Pragma_Volatile_Components => 0,
31353 Pragma_Volatile_Full_Access => 0,
31354 Pragma_Volatile_Function => 0,
31355 Pragma_Warning_As_Error => 0,
31356 Pragma_Warnings => 0,
31357 Pragma_Weak_External => 0,
31358 Pragma_Wide_Character_Encoding => 0,
31359 Unknown_Pragma => 0);
31361 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31367 function Arg_No return Nat;
31368 -- Returns an integer showing what argument we are in. A value of
31369 -- zero means we are not in any of the arguments.
31375 function Arg_No return Nat is
31380 A := First (Pragma_Argument_Associations (Parent (P)));
31394 -- Start of processing for Non_Significant_Pragma_Reference
31399 if Nkind (P) /= N_Pragma_Argument_Association then
31403 Id := Get_Pragma_Id (Parent (P));
31404 C := Sig_Flags (Id);
31419 return AN < (C - 90);
31425 end Is_Non_Significant_Pragma_Reference;
31427 ------------------------------
31428 -- Is_Pragma_String_Literal --
31429 ------------------------------
31431 -- This function returns true if the corresponding pragma argument is a
31432 -- static string expression. These are the only cases in which string
31433 -- literals can appear as pragma arguments. We also allow a string literal
31434 -- as the first argument to pragma Assert (although it will of course
31435 -- always generate a type error).
31437 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31438 Pragn : constant Node_Id := Parent (Par);
31439 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31440 Pname : constant Name_Id := Pragma_Name (Pragn);
31446 N := First (Assoc);
31453 if Pname = Name_Assert then
31456 elsif Pname = Name_Export then
31459 elsif Pname = Name_Ident then
31462 elsif Pname = Name_Import then
31465 elsif Pname = Name_Interface_Name then
31468 elsif Pname = Name_Linker_Alias then
31471 elsif Pname = Name_Linker_Section then
31474 elsif Pname = Name_Machine_Attribute then
31477 elsif Pname = Name_Source_File_Name then
31480 elsif Pname = Name_Source_Reference then
31483 elsif Pname = Name_Title then
31486 elsif Pname = Name_Subtitle then
31492 end Is_Pragma_String_Literal;
31494 ---------------------------
31495 -- Is_Private_SPARK_Mode --
31496 ---------------------------
31498 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31501 (Nkind (N) = N_Pragma
31502 and then Pragma_Name (N) = Name_SPARK_Mode
31503 and then Is_List_Member (N));
31505 -- For pragma SPARK_Mode to be private, it has to appear in the private
31506 -- declarations of a package.
31509 Present (Parent (N))
31510 and then Nkind (Parent (N)) = N_Package_Specification
31511 and then List_Containing (N) = Private_Declarations (Parent (N));
31512 end Is_Private_SPARK_Mode;
31514 -------------------------------------
31515 -- Is_Unconstrained_Or_Tagged_Item --
31516 -------------------------------------
31518 function Is_Unconstrained_Or_Tagged_Item
31519 (Item : Entity_Id) return Boolean
31521 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31522 -- Determine whether record type Typ has at least one unconstrained
31525 ---------------------------------
31526 -- Has_Unconstrained_Component --
31527 ---------------------------------
31529 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31533 Comp := First_Component (Typ);
31534 while Present (Comp) loop
31535 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31539 Next_Component (Comp);
31543 end Has_Unconstrained_Component;
31547 Typ : constant Entity_Id := Etype (Item);
31549 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31552 if Is_Tagged_Type (Typ) then
31555 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31558 elsif Is_Record_Type (Typ) then
31559 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31562 return Has_Unconstrained_Component (Typ);
31565 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31571 end Is_Unconstrained_Or_Tagged_Item;
31573 -----------------------------
31574 -- Is_Valid_Assertion_Kind --
31575 -----------------------------
31577 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31584 | Name_Static_Predicate
31585 | Name_Dynamic_Predicate
31590 | Name_Type_Invariant
31591 | Name_uType_Invariant
31595 | Name_Assert_And_Cut
31597 | Name_Contract_Cases
31599 | Name_Default_Initial_Condition
31601 | Name_Initial_Condition
31604 | Name_Loop_Invariant
31605 | Name_Loop_Variant
31606 | Name_Postcondition
31607 | Name_Precondition
31609 | Name_Refined_Post
31610 | Name_Statement_Assertions
31611 | Name_Subprogram_Variant
31618 end Is_Valid_Assertion_Kind;
31620 --------------------------------------
31621 -- Process_Compilation_Unit_Pragmas --
31622 --------------------------------------
31624 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31626 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31627 -- strange because it comes at the end of the unit. Rational has the
31628 -- same name for a pragma, but treats it as a program unit pragma, In
31629 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31630 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31631 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31632 -- the context clause to ensure the correct processing.
31634 if Has_Pragma_Suppress_All (N) then
31635 Prepend_To (Context_Items (N),
31636 Make_Pragma (Sloc (N),
31637 Chars => Name_Suppress,
31638 Pragma_Argument_Associations => New_List (
31639 Make_Pragma_Argument_Association (Sloc (N),
31640 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31643 -- Nothing else to do at the current time
31645 end Process_Compilation_Unit_Pragmas;
31647 --------------------------------------------
31648 -- Validate_Compile_Time_Warning_Or_Error --
31649 --------------------------------------------
31651 procedure Validate_Compile_Time_Warning_Or_Error
31655 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31656 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31657 Arg2 : constant Node_Id := Next (Arg1);
31659 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31660 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31663 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31665 if Compile_Time_Known_Value (Arg1x) then
31666 if Is_True (Expr_Value (Arg1x)) then
31668 -- We have already verified that the second argument is a static
31669 -- string expression. Its string value must be retrieved
31670 -- explicitly if it is a declared constant, otherwise it has
31671 -- been constant-folded previously.
31674 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31675 Str : constant String_Id :=
31676 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31677 Str_Len : constant Nat := String_Length (Str);
31679 Force : constant Boolean :=
31680 Prag_Id = Pragma_Compile_Time_Warning
31681 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31682 and then (Ekind (Cent) /= E_Package
31683 or else not In_Private_Part (Cent));
31684 -- Set True if this is the warning case, and we are in the
31685 -- visible part of a package spec, or in a subprogram spec,
31686 -- in which case we want to force the client to see the
31687 -- warning, even though it is not in the main unit.
31695 -- Loop through segments of message separated by line feeds.
31696 -- We output these segments as separate messages with
31697 -- continuation marks for all but the first.
31702 Error_Msg_Strlen := 0;
31704 -- Loop to copy characters from argument to error message
31708 exit when Ptr > Str_Len;
31709 CC := Get_String_Char (Str, Ptr);
31712 -- Ignore wide chars ??? else store character
31714 if In_Character_Range (CC) then
31715 C := Get_Character (CC);
31716 exit when C = ASCII.LF;
31717 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31718 Error_Msg_String (Error_Msg_Strlen) := C;
31722 -- Here with one line ready to go
31724 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31726 -- If this is a warning in a spec, then we want clients
31727 -- to see the warning, so mark the message with the
31728 -- special sequence !! to force the warning. In the case
31729 -- of a package spec, we do not force this if we are in
31730 -- the private part of the spec.
31733 if Cont = False then
31735 ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31739 ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31742 -- Error, rather than warning, or in a body, so we do not
31743 -- need to force visibility for client (error will be
31744 -- output in any case, and this is the situation in which
31745 -- we do not want a client to get a warning, since the
31746 -- warning is in the body or the spec private part).
31749 if Cont = False then
31751 ("<<~", Eloc, Is_Compile_Time_Pragma => True);
31755 ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
31759 exit when Ptr > Str_Len;
31764 -- Arg1x is not known at compile time, so possibly issue an error
31765 -- or warning. This can happen only if the pragma's processing
31766 -- was deferred until after the back end is run (see
31767 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31768 -- control switch applies to only the warning case.
31770 elsif Prag_Id = Pragma_Compile_Time_Error then
31771 Error_Msg_N ("condition is not known at compile time", Arg1x);
31773 elsif Warn_On_Unknown_Compile_Time_Warning then
31774 Error_Msg_N ("??condition is not known at compile time", Arg1x);
31776 end Validate_Compile_Time_Warning_Or_Error;
31778 ------------------------------------
31779 -- Record_Possible_Body_Reference --
31780 ------------------------------------
31782 procedure Record_Possible_Body_Reference
31783 (State_Id : Entity_Id;
31787 Spec_Id : Entity_Id;
31790 -- Ensure that we are dealing with a reference to a state
31792 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31794 -- Climb the tree starting from the reference looking for a package body
31795 -- whose spec declares the referenced state. This criteria automatically
31796 -- excludes references in package specs which are legal. Note that it is
31797 -- not wise to emit an error now as the package body may lack pragma
31798 -- Refined_State or the referenced state may not be mentioned in the
31799 -- refinement. This approach avoids the generation of misleading errors.
31802 while Present (Context) loop
31803 if Nkind (Context) = N_Package_Body then
31804 Spec_Id := Corresponding_Spec (Context);
31806 if Present (Abstract_States (Spec_Id))
31807 and then Contains (Abstract_States (Spec_Id), State_Id)
31809 if No (Body_References (State_Id)) then
31810 Set_Body_References (State_Id, New_Elmt_List);
31813 Append_Elmt (Ref, To => Body_References (State_Id));
31818 Context := Parent (Context);
31820 end Record_Possible_Body_Reference;
31822 ------------------------------------------
31823 -- Relocate_Pragmas_To_Anonymous_Object --
31824 ------------------------------------------
31826 procedure Relocate_Pragmas_To_Anonymous_Object
31827 (Typ_Decl : Node_Id;
31828 Obj_Decl : Node_Id)
31832 Next_Decl : Node_Id;
31835 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31836 Def := Protected_Definition (Typ_Decl);
31838 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31839 Def := Task_Definition (Typ_Decl);
31842 -- The concurrent definition has a visible declaration list. Inspect it
31843 -- and relocate all canidate pragmas.
31845 if Present (Def) and then Present (Visible_Declarations (Def)) then
31846 Decl := First (Visible_Declarations (Def));
31847 while Present (Decl) loop
31849 -- Preserve the following declaration for iteration purposes due
31850 -- to possible relocation of a pragma.
31852 Next_Decl := Next (Decl);
31854 if Nkind (Decl) = N_Pragma
31855 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31858 Insert_After (Obj_Decl, Decl);
31860 -- Skip internally generated code
31862 elsif not Comes_From_Source (Decl) then
31865 -- No candidate pragmas are available for relocation
31874 end Relocate_Pragmas_To_Anonymous_Object;
31876 ------------------------------
31877 -- Relocate_Pragmas_To_Body --
31878 ------------------------------
31880 procedure Relocate_Pragmas_To_Body
31881 (Subp_Body : Node_Id;
31882 Target_Body : Node_Id := Empty)
31884 procedure Relocate_Pragma (Prag : Node_Id);
31885 -- Remove a single pragma from its current list and add it to the
31886 -- declarations of the proper body (either Subp_Body or Target_Body).
31888 ---------------------
31889 -- Relocate_Pragma --
31890 ---------------------
31892 procedure Relocate_Pragma (Prag : Node_Id) is
31897 -- When subprogram stubs or expression functions are involves, the
31898 -- destination declaration list belongs to the proper body.
31900 if Present (Target_Body) then
31901 Target := Target_Body;
31903 Target := Subp_Body;
31906 Decls := Declarations (Target);
31910 Set_Declarations (Target, Decls);
31913 -- Unhook the pragma from its current list
31916 Prepend (Prag, Decls);
31917 end Relocate_Pragma;
31921 Body_Id : constant Entity_Id :=
31922 Defining_Unit_Name (Specification (Subp_Body));
31923 Next_Stmt : Node_Id;
31926 -- Start of processing for Relocate_Pragmas_To_Body
31929 -- Do not process a body that comes from a separate unit as no construct
31930 -- can possibly follow it.
31932 if not Is_List_Member (Subp_Body) then
31935 -- Do not relocate pragmas that follow a stub if the stub does not have
31938 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31939 and then No (Target_Body)
31943 -- Do not process internally generated routine _Postconditions
31945 elsif Ekind (Body_Id) = E_Procedure
31946 and then Chars (Body_Id) = Name_uPostconditions
31951 -- Look at what is following the body. We are interested in certain kind
31952 -- of pragmas (either from source or byproducts of expansion) that can
31953 -- apply to a body [stub].
31955 Stmt := Next (Subp_Body);
31956 while Present (Stmt) loop
31958 -- Preserve the following statement for iteration purposes due to a
31959 -- possible relocation of a pragma.
31961 Next_Stmt := Next (Stmt);
31963 -- Move a candidate pragma following the body to the declarations of
31966 if Nkind (Stmt) = N_Pragma
31967 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31970 -- If a source pragma Warnings follows the body, it applies to
31971 -- following statements and does not belong in the body.
31973 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31974 and then Comes_From_Source (Stmt)
31978 Relocate_Pragma (Stmt);
31981 -- Skip internally generated code
31983 elsif not Comes_From_Source (Stmt) then
31986 -- No candidate pragmas are available for relocation
31994 end Relocate_Pragmas_To_Body;
31996 -------------------
31997 -- Resolve_State --
31998 -------------------
32000 procedure Resolve_State (N : Node_Id) is
32005 if Is_Entity_Name (N) and then Present (Entity (N)) then
32006 Func := Entity (N);
32008 -- Handle overloading of state names by functions. Traverse the
32009 -- homonym chain looking for an abstract state.
32011 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
32012 pragma Assert (Is_Overloaded (N));
32014 State := Homonym (Func);
32015 while Present (State) loop
32016 if Ekind (State) = E_Abstract_State then
32018 -- Resolve the overloading by setting the proper entity of
32019 -- the reference to that of the state.
32021 Set_Etype (N, Standard_Void_Type);
32022 Set_Entity (N, State);
32023 Set_Is_Overloaded (N, False);
32025 Generate_Reference (State, N);
32029 State := Homonym (State);
32032 -- A function can never act as a state. If the homonym chain does
32033 -- not contain a corresponding state, then something went wrong in
32034 -- the overloading mechanism.
32036 raise Program_Error;
32041 ----------------------------
32042 -- Rewrite_Assertion_Kind --
32043 ----------------------------
32045 procedure Rewrite_Assertion_Kind
32047 From_Policy : Boolean := False)
32053 if Nkind (N) = N_Attribute_Reference
32054 and then Attribute_Name (N) = Name_Class
32055 and then Nkind (Prefix (N)) = N_Identifier
32057 case Chars (Prefix (N)) is
32064 when Name_Type_Invariant =>
32065 Nam := Name_uType_Invariant;
32067 when Name_Invariant =>
32068 Nam := Name_uInvariant;
32074 -- Recommend standard use of aspect names Pre/Post
32076 elsif Nkind (N) = N_Identifier
32077 and then From_Policy
32078 and then Serious_Errors_Detected = 0
32080 if Chars (N) = Name_Precondition
32081 or else Chars (N) = Name_Postcondition
32083 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
32085 ("\use Assertion_Policy and aspect names Pre/Post for "
32086 & "Ada2012 conformance?", N);
32092 if Nam /= No_Name then
32093 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
32095 end Rewrite_Assertion_Kind;
32103 Dummy := Dummy + 1;
32106 --------------------------------
32107 -- Set_Encoded_Interface_Name --
32108 --------------------------------
32110 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
32111 Str : constant String_Id := Strval (S);
32112 Len : constant Nat := String_Length (Str);
32117 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
32120 -- Stores encoded value of character code CC. The encoding we use an
32121 -- underscore followed by four lower case hex digits.
32127 procedure Encode is
32129 Store_String_Char (Get_Char_Code ('_'));
32131 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
32133 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
32135 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
32137 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
32140 -- Start of processing for Set_Encoded_Interface_Name
32143 -- If first character is asterisk, this is a link name, and we leave it
32144 -- completely unmodified. We also ignore null strings (the latter case
32145 -- happens only in error cases).
32148 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
32150 Set_Interface_Name (E, S);
32155 CC := Get_String_Char (Str, J);
32157 exit when not In_Character_Range (CC);
32159 C := Get_Character (CC);
32161 exit when C /= '_' and then C /= '$'
32162 and then C not in '0' .. '9'
32163 and then C not in 'a' .. 'z'
32164 and then C not in 'A' .. 'Z';
32167 Set_Interface_Name (E, S);
32175 -- Here we need to encode. The encoding we use as follows:
32176 -- three underscores + four hex digits (lower case)
32180 for J in 1 .. String_Length (Str) loop
32181 CC := Get_String_Char (Str, J);
32183 if not In_Character_Range (CC) then
32186 C := Get_Character (CC);
32188 if C = '_' or else C = '$'
32189 or else C in '0' .. '9'
32190 or else C in 'a' .. 'z'
32191 or else C in 'A' .. 'Z'
32193 Store_String_Char (CC);
32200 Set_Interface_Name (E,
32201 Make_String_Literal (Sloc (S),
32202 Strval => End_String));
32204 end Set_Encoded_Interface_Name;
32206 ------------------------
32207 -- Set_Elab_Unit_Name --
32208 ------------------------
32210 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32215 if Nkind (N) = N_Identifier
32216 and then Nkind (With_Item) = N_Identifier
32218 Set_Entity (N, Entity (With_Item));
32220 elsif Nkind (N) = N_Selected_Component then
32221 Change_Selected_Component_To_Expanded_Name (N);
32222 Set_Entity (N, Entity (With_Item));
32223 Set_Entity (Selector_Name (N), Entity (N));
32225 Pref := Prefix (N);
32226 Scop := Scope (Entity (N));
32227 while Nkind (Pref) = N_Selected_Component loop
32228 Change_Selected_Component_To_Expanded_Name (Pref);
32229 Set_Entity (Selector_Name (Pref), Scop);
32230 Set_Entity (Pref, Scop);
32231 Pref := Prefix (Pref);
32232 Scop := Scope (Scop);
32235 Set_Entity (Pref, Scop);
32238 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32239 end Set_Elab_Unit_Name;
32241 -----------------------
32242 -- Set_Overflow_Mode --
32243 -----------------------
32245 procedure Set_Overflow_Mode (N : Node_Id) is
32247 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
32248 -- Function to process one pragma argument, Arg
32250 -----------------------
32251 -- Get_Overflow_Mode --
32252 -----------------------
32254 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
32255 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
32258 if Chars (Argx) = Name_Strict then
32261 elsif Chars (Argx) = Name_Minimized then
32264 elsif Chars (Argx) = Name_Eliminated then
32268 raise Program_Error;
32270 end Get_Overflow_Mode;
32274 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32275 Arg2 : constant Node_Id := Next (Arg1);
32277 -- Start of processing for Set_Overflow_Mode
32280 -- Process first argument
32282 Scope_Suppress.Overflow_Mode_General :=
32283 Get_Overflow_Mode (Arg1);
32285 -- Case of only one argument
32288 Scope_Suppress.Overflow_Mode_Assertions :=
32289 Scope_Suppress.Overflow_Mode_General;
32291 -- Case of two arguments present
32294 Scope_Suppress.Overflow_Mode_Assertions :=
32295 Get_Overflow_Mode (Arg2);
32297 end Set_Overflow_Mode;
32299 -------------------
32300 -- Test_Case_Arg --
32301 -------------------
32303 function Test_Case_Arg
32306 From_Aspect : Boolean := False) return Node_Id
32308 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32314 (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
32316 -- The caller requests the aspect argument
32318 if From_Aspect then
32319 if Present (Aspect)
32320 and then Nkind (Expression (Aspect)) = N_Aggregate
32322 Args := Expression (Aspect);
32324 -- "Name" and "Mode" may appear without an identifier as a
32325 -- positional association.
32327 if Present (Expressions (Args)) then
32328 Arg := First (Expressions (Args));
32330 if Present (Arg) and then Arg_Nam = Name_Name then
32338 if Present (Arg) and then Arg_Nam = Name_Mode then
32343 -- Some or all arguments may appear as component associatons
32345 if Present (Component_Associations (Args)) then
32346 Arg := First (Component_Associations (Args));
32347 while Present (Arg) loop
32348 if Chars (First (Choices (Arg))) = Arg_Nam then
32357 -- Otherwise retrieve the argument directly from the pragma
32360 Arg := First (Pragma_Argument_Associations (Prag));
32362 if Present (Arg) and then Arg_Nam = Name_Name then
32366 -- Skip argument "Name"
32370 if Present (Arg) and then Arg_Nam = Name_Mode then
32374 -- Skip argument "Mode"
32378 -- Arguments "Requires" and "Ensures" are optional and may not be
32381 while Present (Arg) loop
32382 if Chars (Arg) = Arg_Nam then
32393 --------------------------------------------
32394 -- Defer_Compile_Time_Warning_Error_To_BE --
32395 --------------------------------------------
32397 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32398 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32400 Compile_Time_Warnings_Errors.Append
32401 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32402 Scope => Current_Scope,
32405 -- If the Boolean expression contains T'Size, and we're not in the main
32406 -- unit being compiled, then we need to copy the pragma into the main
32407 -- unit, because otherwise T'Size might never be computed, leaving it
32410 if not In_Extended_Main_Code_Unit (N) then
32411 Insert_Library_Level_Action (New_Copy_Tree (N));
32413 end Defer_Compile_Time_Warning_Error_To_BE;
32415 ------------------------------------------
32416 -- Validate_Compile_Time_Warning_Errors --
32417 ------------------------------------------
32419 procedure Validate_Compile_Time_Warning_Errors is
32420 procedure Set_Scope (S : Entity_Id);
32421 -- Install all enclosing scopes of S along with S itself
32423 procedure Unset_Scope (S : Entity_Id);
32424 -- Uninstall all enclosing scopes of S along with S itself
32430 procedure Set_Scope (S : Entity_Id) is
32432 if S /= Standard_Standard then
32433 Set_Scope (Scope (S));
32443 procedure Unset_Scope (S : Entity_Id) is
32445 if S /= Standard_Standard then
32446 Unset_Scope (Scope (S));
32452 -- Start of processing for Validate_Compile_Time_Warning_Errors
32455 Expander_Mode_Save_And_Set (False);
32456 In_Compile_Time_Warning_Or_Error := True;
32458 for N in Compile_Time_Warnings_Errors.First ..
32459 Compile_Time_Warnings_Errors.Last
32462 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32465 Set_Scope (T.Scope);
32466 Reset_Analyzed_Flags (T.Prag);
32467 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32468 Unset_Scope (T.Scope);
32472 In_Compile_Time_Warning_Or_Error := False;
32473 Expander_Mode_Restore;
32474 end Validate_Compile_Time_Warning_Errors;