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 of the analysis of the
548 -- pragma failed to produce an aggregate.
550 pragma Assert (Nkind (CCases) = N_Aggregate);
552 if Present (Component_Associations (CCases)) then
554 -- Ensure that the formal parameters are visible when analyzing all
555 -- clauses. This falls out of the general rule of aspects pertaining
556 -- to subprogram declarations.
558 if not In_Open_Scopes (Spec_Id) then
559 Restore_Scope := True;
560 Push_Scope (Spec_Id);
562 if Is_Generic_Subprogram (Spec_Id) then
563 Install_Generic_Formals (Spec_Id);
565 Install_Formals (Spec_Id);
569 CCase := First (Component_Associations (CCases));
570 while Present (CCase) loop
571 Analyze_Contract_Case (CCase);
575 if Restore_Scope then
579 -- Currently it is not possible to inline pre/postconditions on a
580 -- subprogram subject to pragma Inline_Always.
582 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
584 -- Otherwise the pragma is illegal
587 Error_Msg_N ("wrong syntax for contract cases", N);
590 Set_Is_Analyzed_Pragma (N);
592 Restore_Ghost_Region (Saved_GM, Saved_IGR);
593 end Analyze_Contract_Cases_In_Decl_Part;
595 ----------------------------------
596 -- Analyze_Depends_In_Decl_Part --
597 ----------------------------------
599 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
600 Loc : constant Source_Ptr := Sloc (N);
601 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
602 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
604 All_Inputs_Seen : Elist_Id := No_Elist;
605 -- A list containing the entities of all the inputs processed so far.
606 -- The list is populated with unique entities because the same input
607 -- may appear in multiple input lists.
609 All_Outputs_Seen : Elist_Id := No_Elist;
610 -- A list containing the entities of all the outputs processed so far.
611 -- The list is populated with unique entities because output items are
612 -- unique in a dependence relation.
614 Constits_Seen : Elist_Id := No_Elist;
615 -- A list containing the entities of all constituents processed so far.
616 -- It aids in detecting illegal usage of a state and a corresponding
617 -- constituent in pragma [Refinde_]Depends.
619 Global_Seen : Boolean := False;
620 -- A flag set when pragma Global has been processed
622 Null_Output_Seen : Boolean := False;
623 -- A flag used to track the legality of a null output
625 Result_Seen : Boolean := False;
626 -- A flag set when Spec_Id'Result is processed
628 States_Seen : Elist_Id := No_Elist;
629 -- A list containing the entities of all states processed so far. It
630 -- helps in detecting illegal usage of a state and a corresponding
631 -- constituent in pragma [Refined_]Depends.
633 Subp_Inputs : Elist_Id := No_Elist;
634 Subp_Outputs : Elist_Id := No_Elist;
635 -- Two lists containing the full set of inputs and output of the related
636 -- subprograms. Note that these lists contain both nodes and entities.
638 Task_Input_Seen : Boolean := False;
639 Task_Output_Seen : Boolean := False;
640 -- Flags used to track the implicit dependence of a task unit on itself
642 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
643 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
644 -- to the name buffer. The individual kinds are as follows:
645 -- E_Abstract_State - "state"
646 -- E_Constant - "constant"
647 -- E_Generic_In_Out_Parameter - "generic parameter"
648 -- E_Generic_In_Parameter - "generic parameter"
649 -- E_In_Parameter - "parameter"
650 -- E_In_Out_Parameter - "parameter"
651 -- E_Loop_Parameter - "loop parameter"
652 -- E_Out_Parameter - "parameter"
653 -- E_Protected_Type - "current instance of protected type"
654 -- E_Task_Type - "current instance of task type"
655 -- E_Variable - "global"
657 procedure Analyze_Dependency_Clause
660 -- Verify the legality of a single dependency clause. Flag Is_Last
661 -- denotes whether Clause is the last clause in the relation.
663 procedure Check_Function_Return;
664 -- Verify that Funtion'Result appears as one of the outputs
665 -- (SPARK RM 6.1.5(10)).
672 -- Ensure that an item fulfills its designated input and/or output role
673 -- as specified by pragma Global (if any) or the enclosing context. If
674 -- this is not the case, emit an error. Item and Item_Id denote the
675 -- attributes of an item. Flag Is_Input should be set when item comes
676 -- from an input list. Flag Self_Ref should be set when the item is an
677 -- output and the dependency clause has operator "+".
679 procedure Check_Usage
680 (Subp_Items : Elist_Id;
681 Used_Items : Elist_Id;
683 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
684 -- error if this is not the case.
686 procedure Normalize_Clause (Clause : Node_Id);
687 -- Remove a self-dependency "+" from the input list of a clause
689 -----------------------------
690 -- Add_Item_To_Name_Buffer --
691 -----------------------------
693 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
695 if Ekind (Item_Id) = E_Abstract_State then
696 Add_Str_To_Name_Buffer ("state");
698 elsif Ekind (Item_Id) = E_Constant then
699 Add_Str_To_Name_Buffer ("constant");
701 elsif Ekind (Item_Id) in
702 E_Generic_In_Out_Parameter | E_Generic_In_Parameter
704 Add_Str_To_Name_Buffer ("generic parameter");
706 elsif Is_Formal (Item_Id) then
707 Add_Str_To_Name_Buffer ("parameter");
709 elsif Ekind (Item_Id) = E_Loop_Parameter then
710 Add_Str_To_Name_Buffer ("loop parameter");
712 elsif Ekind (Item_Id) = E_Protected_Type
713 or else Is_Single_Protected_Object (Item_Id)
715 Add_Str_To_Name_Buffer ("current instance of protected type");
717 elsif Ekind (Item_Id) = E_Task_Type
718 or else Is_Single_Task_Object (Item_Id)
720 Add_Str_To_Name_Buffer ("current instance of task type");
722 elsif Ekind (Item_Id) = E_Variable then
723 Add_Str_To_Name_Buffer ("global");
725 -- The routine should not be called with non-SPARK items
730 end Add_Item_To_Name_Buffer;
732 -------------------------------
733 -- Analyze_Dependency_Clause --
734 -------------------------------
736 procedure Analyze_Dependency_Clause
740 procedure Analyze_Input_List (Inputs : Node_Id);
741 -- Verify the legality of a single input list
743 procedure Analyze_Input_Output
748 Seen : in out Elist_Id;
749 Null_Seen : in out Boolean;
750 Non_Null_Seen : in out Boolean);
751 -- Verify the legality of a single input or output item. Flag
752 -- Is_Input should be set whenever Item is an input, False when it
753 -- denotes an output. Flag Self_Ref should be set when the item is an
754 -- output and the dependency clause has a "+". Flag Top_Level should
755 -- be set whenever Item appears immediately within an input or output
756 -- list. Seen is a collection of all abstract states, objects and
757 -- formals processed so far. Flag Null_Seen denotes whether a null
758 -- input or output has been encountered. Flag Non_Null_Seen denotes
759 -- whether a non-null input or output has been encountered.
761 ------------------------
762 -- Analyze_Input_List --
763 ------------------------
765 procedure Analyze_Input_List (Inputs : Node_Id) is
766 Inputs_Seen : Elist_Id := No_Elist;
767 -- A list containing the entities of all inputs that appear in the
768 -- current input list.
770 Non_Null_Input_Seen : Boolean := False;
771 Null_Input_Seen : Boolean := False;
772 -- Flags used to check the legality of an input list
777 -- Multiple inputs appear as an aggregate
779 if Nkind (Inputs) = N_Aggregate then
780 if Present (Component_Associations (Inputs)) then
782 ("nested dependency relations not allowed", Inputs);
784 elsif Present (Expressions (Inputs)) then
785 Input := First (Expressions (Inputs));
786 while Present (Input) loop
793 Null_Seen => Null_Input_Seen,
794 Non_Null_Seen => Non_Null_Input_Seen);
799 -- Syntax error, always report
802 Error_Msg_N ("malformed input dependency list", Inputs);
805 -- Process a solitary input
814 Null_Seen => Null_Input_Seen,
815 Non_Null_Seen => Non_Null_Input_Seen);
818 -- Detect an illegal dependency clause of the form
822 if Null_Output_Seen and then Null_Input_Seen then
824 ("null dependency clause cannot have a null input list",
827 end Analyze_Input_List;
829 --------------------------
830 -- Analyze_Input_Output --
831 --------------------------
833 procedure Analyze_Input_Output
838 Seen : in out Elist_Id;
839 Null_Seen : in out Boolean;
840 Non_Null_Seen : in out Boolean)
842 procedure Current_Task_Instance_Seen;
843 -- Set the appropriate global flag when the current instance of a
844 -- task unit is encountered.
846 --------------------------------
847 -- Current_Task_Instance_Seen --
848 --------------------------------
850 procedure Current_Task_Instance_Seen is
853 Task_Input_Seen := True;
855 Task_Output_Seen := True;
857 end Current_Task_Instance_Seen;
861 Is_Output : constant Boolean := not Is_Input;
865 -- Start of processing for Analyze_Input_Output
868 -- Multiple input or output items appear as an aggregate
870 if Nkind (Item) = N_Aggregate then
871 if not Top_Level then
872 SPARK_Msg_N ("nested grouping of items not allowed", Item);
874 elsif Present (Component_Associations (Item)) then
876 ("nested dependency relations not allowed", Item);
878 -- Recursively analyze the grouped items
880 elsif Present (Expressions (Item)) then
881 Grouped := First (Expressions (Item));
882 while Present (Grouped) loop
885 Is_Input => Is_Input,
886 Self_Ref => Self_Ref,
889 Null_Seen => Null_Seen,
890 Non_Null_Seen => Non_Null_Seen);
895 -- Syntax error, always report
898 Error_Msg_N ("malformed dependency list", Item);
901 -- Process attribute 'Result in the context of a dependency clause
903 elsif Is_Attribute_Result (Item) then
904 Non_Null_Seen := True;
908 -- Attribute 'Result is allowed to appear on the output side of
909 -- a dependency clause (SPARK RM 6.1.5(6)).
912 SPARK_Msg_N ("function result cannot act as input", Item);
916 ("cannot mix null and non-null dependency items", Item);
922 -- Detect multiple uses of null in a single dependency list or
923 -- throughout the whole relation. Verify the placement of a null
924 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
926 elsif Nkind (Item) = N_Null then
929 ("multiple null dependency relations not allowed", Item);
931 elsif Non_Null_Seen then
933 ("cannot mix null and non-null dependency items", Item);
941 ("null output list must be the last clause in a "
942 & "dependency relation", Item);
944 -- Catch a useless dependence of the form:
949 ("useless dependence, null depends on itself", Item);
957 Non_Null_Seen := True;
960 SPARK_Msg_N ("cannot mix null and non-null items", Item);
964 Resolve_State (Item);
966 -- Find the entity of the item. If this is a renaming, climb
967 -- the renaming chain to reach the root object. Renamings of
968 -- non-entire objects do not yield an entity (Empty).
970 Item_Id := Entity_Of (Item);
972 if Present (Item_Id) then
976 if Ekind (Item_Id) in E_Constant | E_Loop_Parameter
979 -- Current instances of concurrent types
981 Ekind (Item_Id) in E_Protected_Type | E_Task_Type
986 Ekind (Item_Id) in E_Generic_In_Out_Parameter
987 | E_Generic_In_Parameter
995 Ekind (Item_Id) in E_Abstract_State | E_Variable
997 -- A [generic] function is not allowed to have Output
998 -- items in its dependency relations. Note that "null"
999 -- and attribute 'Result are still valid items.
1001 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1002 and then not Is_Input
1005 ("output item is not applicable to function", Item);
1008 -- The item denotes a concurrent type. Note that single
1009 -- protected/task types are not considered here because
1010 -- they behave as objects in the context of pragma
1011 -- [Refined_]Depends.
1013 if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
1015 -- This use is legal as long as the concurrent type is
1016 -- the current instance of an enclosing type.
1018 if Is_CCT_Instance (Item_Id, Spec_Id) then
1020 -- The dependence of a task unit on itself is
1021 -- implicit and may or may not be explicitly
1022 -- specified (SPARK RM 6.1.4).
1024 if Ekind (Item_Id) = E_Task_Type then
1025 Current_Task_Instance_Seen;
1028 -- Otherwise this is not the current instance
1032 ("invalid use of subtype mark in dependency "
1033 & "relation", Item);
1036 -- The dependency of a task unit on itself is implicit
1037 -- and may or may not be explicitly specified
1038 -- (SPARK RM 6.1.4).
1040 elsif Is_Single_Task_Object (Item_Id)
1041 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1043 Current_Task_Instance_Seen;
1046 -- Ensure that the item fulfills its role as input and/or
1047 -- output as specified by pragma Global or the enclosing
1050 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1052 -- Detect multiple uses of the same state, variable or
1053 -- formal parameter. If this is not the case, add the
1054 -- item to the list of processed relations.
1056 if Contains (Seen, Item_Id) then
1058 ("duplicate use of item &", Item, Item_Id);
1060 Append_New_Elmt (Item_Id, Seen);
1063 -- Detect illegal use of an input related to a null
1064 -- output. Such input items cannot appear in other
1065 -- input lists (SPARK RM 6.1.5(13)).
1068 and then Null_Output_Seen
1069 and then Contains (All_Inputs_Seen, Item_Id)
1072 ("input of a null output list cannot appear in "
1073 & "multiple input lists", Item);
1076 -- Add an input or a self-referential output to the list
1077 -- of all processed inputs.
1079 if Is_Input or else Self_Ref then
1080 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1083 -- State related checks (SPARK RM 6.1.5(3))
1085 if Ekind (Item_Id) = E_Abstract_State then
1087 -- Package and subprogram bodies are instantiated
1088 -- individually in a separate compiler pass. Due to
1089 -- this mode of instantiation, the refinement of a
1090 -- state may no longer be visible when a subprogram
1091 -- body contract is instantiated. Since the generic
1092 -- template is legal, do not perform this check in
1093 -- the instance to circumvent this oddity.
1098 -- An abstract state with visible refinement cannot
1099 -- appear in pragma [Refined_]Depends as its place
1100 -- must be taken by some of its constituents
1101 -- (SPARK RM 6.1.4(7)).
1103 elsif Has_Visible_Refinement (Item_Id) then
1105 ("cannot mention state & in dependence relation",
1107 SPARK_Msg_N ("\use its constituents instead", Item);
1110 -- If the reference to the abstract state appears in
1111 -- an enclosing package body that will eventually
1112 -- refine the state, record the reference for future
1116 Record_Possible_Body_Reference
1117 (State_Id => Item_Id,
1122 -- When the item renames an entire object, replace the
1123 -- item with a reference to the object.
1125 if Entity (Item) /= Item_Id then
1127 New_Occurrence_Of (Item_Id, Sloc (Item)));
1131 -- Add the entity of the current item to the list of
1134 if Ekind (Item_Id) = E_Abstract_State then
1135 Append_New_Elmt (Item_Id, States_Seen);
1137 -- The variable may eventually become a constituent of a
1138 -- single protected/task type. Record the reference now
1139 -- and verify its legality when analyzing the contract of
1140 -- the variable (SPARK RM 9.3).
1142 elsif Ekind (Item_Id) = E_Variable then
1143 Record_Possible_Part_Of_Reference
1148 if Ekind (Item_Id) in E_Abstract_State
1151 and then Present (Encapsulating_State (Item_Id))
1153 Append_New_Elmt (Item_Id, Constits_Seen);
1156 -- All other input/output items are illegal
1157 -- (SPARK RM 6.1.5(1)).
1161 ("item must denote parameter, variable, state or "
1162 & "current instance of concurrent type", Item);
1165 -- All other input/output items are illegal
1166 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1170 ("item must denote parameter, variable, state or current "
1171 & "instance of concurrent type", Item);
1174 end Analyze_Input_Output;
1182 Non_Null_Output_Seen : Boolean := False;
1183 -- Flag used to check the legality of an output list
1185 -- Start of processing for Analyze_Dependency_Clause
1188 Inputs := Expression (Clause);
1191 -- An input list with a self-dependency appears as operator "+" where
1192 -- the actuals inputs are the right operand.
1194 if Nkind (Inputs) = N_Op_Plus then
1195 Inputs := Right_Opnd (Inputs);
1199 -- Process the output_list of a dependency_clause
1201 Output := First (Choices (Clause));
1202 while Present (Output) loop
1203 Analyze_Input_Output
1206 Self_Ref => Self_Ref,
1208 Seen => All_Outputs_Seen,
1209 Null_Seen => Null_Output_Seen,
1210 Non_Null_Seen => Non_Null_Output_Seen);
1215 -- Process the input_list of a dependency_clause
1217 Analyze_Input_List (Inputs);
1218 end Analyze_Dependency_Clause;
1220 ---------------------------
1221 -- Check_Function_Return --
1222 ---------------------------
1224 procedure Check_Function_Return is
1226 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1227 and then not Result_Seen
1230 ("result of & must appear in exactly one output list",
1233 end Check_Function_Return;
1239 procedure Check_Role
1241 Item_Id : Entity_Id;
1246 (Item_Is_Input : out Boolean;
1247 Item_Is_Output : out Boolean);
1248 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1249 -- Item_Is_Output are set depending on the role.
1251 procedure Role_Error
1252 (Item_Is_Input : Boolean;
1253 Item_Is_Output : Boolean);
1254 -- Emit an error message concerning the incorrect use of Item in
1255 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1256 -- denote whether the item is an input and/or an output.
1263 (Item_Is_Input : out Boolean;
1264 Item_Is_Output : out Boolean)
1266 -- A constant or IN parameter of access type should be handled
1267 -- like a variable, as the underlying memory pointed-to can be
1268 -- modified. Use Adjusted_Kind to do this adjustment.
1270 Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
1273 if Ekind (Item_Id) in E_Constant
1274 | E_Generic_In_Parameter
1276 and then Is_Access_Type (Etype (Item_Id))
1278 Adjusted_Kind := E_Variable;
1281 case Adjusted_Kind is
1285 when E_Abstract_State =>
1287 -- When pragma Global is present it determines the mode of
1288 -- the abstract state.
1291 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1292 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1294 -- Otherwise the state has a default IN OUT mode, because it
1295 -- behaves as a variable.
1298 Item_Is_Input := True;
1299 Item_Is_Output := True;
1302 -- Constants and IN parameters
1305 | E_Generic_In_Parameter
1309 -- When pragma Global is present it determines the mode
1310 -- of constant objects as inputs (and such objects cannot
1311 -- appear as outputs in the Global contract).
1314 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1316 Item_Is_Input := True;
1319 Item_Is_Output := False;
1321 -- Variables and IN OUT parameters, as well as constants and
1322 -- IN parameters of access type which are handled like
1325 when E_Generic_In_Out_Parameter
1326 | E_In_Out_Parameter
1329 -- When pragma Global is present it determines the mode of
1334 -- A variable has mode IN when its type is unconstrained
1335 -- or tagged because array bounds, discriminants or tags
1339 Appears_In (Subp_Inputs, Item_Id)
1340 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1342 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1344 -- Otherwise the variable has a default IN OUT mode
1347 Item_Is_Input := True;
1348 Item_Is_Output := True;
1351 when E_Out_Parameter =>
1353 -- An OUT parameter of the related subprogram; it cannot
1354 -- appear in Global.
1356 if Scope (Item_Id) = Spec_Id then
1358 -- The parameter has mode IN if its type is unconstrained
1359 -- or tagged because array bounds, discriminants or tags
1363 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1365 Item_Is_Output := True;
1367 -- An OUT parameter of an enclosing subprogram; it can
1368 -- appear in Global and behaves as a read-write variable.
1371 -- When pragma Global is present it determines the mode
1376 -- A variable has mode IN when its type is
1377 -- unconstrained or tagged because array
1378 -- bounds, discriminants or tags can be read.
1381 Appears_In (Subp_Inputs, Item_Id)
1382 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1384 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1386 -- Otherwise the variable has a default IN OUT mode
1389 Item_Is_Input := True;
1390 Item_Is_Output := True;
1396 when E_Protected_Type =>
1399 -- A variable has mode IN when its type is unconstrained
1400 -- or tagged because array bounds, discriminants or tags
1404 Appears_In (Subp_Inputs, Item_Id)
1405 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1407 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1410 -- A protected type acts as a formal parameter of mode IN
1411 -- when it applies to a protected function.
1413 if Ekind (Spec_Id) = E_Function then
1414 Item_Is_Input := True;
1415 Item_Is_Output := False;
1417 -- Otherwise the protected type acts as a formal of mode
1421 Item_Is_Input := True;
1422 Item_Is_Output := True;
1430 -- When pragma Global is present it determines the mode of
1435 Appears_In (Subp_Inputs, Item_Id)
1436 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1438 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1440 -- Otherwise task types act as IN OUT parameters
1443 Item_Is_Input := True;
1444 Item_Is_Output := True;
1448 raise Program_Error;
1456 procedure Role_Error
1457 (Item_Is_Input : Boolean;
1458 Item_Is_Output : Boolean)
1460 Error_Msg : Name_Id;
1465 -- When the item is not part of the input and the output set of
1466 -- the related subprogram, then it appears as extra in pragma
1467 -- [Refined_]Depends.
1469 if not Item_Is_Input and then not Item_Is_Output then
1470 Add_Item_To_Name_Buffer (Item_Id);
1471 Add_Str_To_Name_Buffer
1472 (" & cannot appear in dependence relation");
1474 Error_Msg := Name_Find;
1475 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1477 Error_Msg_Name_1 := Chars (Spec_Id);
1479 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1480 & "set of subprogram %"), Item, Item_Id);
1482 -- The mode of the item and its role in pragma [Refined_]Depends
1483 -- are in conflict. Construct a detailed message explaining the
1484 -- illegality (SPARK RM 6.1.5(5-6)).
1487 if Item_Is_Input then
1488 Add_Str_To_Name_Buffer ("read-only");
1490 Add_Str_To_Name_Buffer ("write-only");
1493 Add_Char_To_Name_Buffer (' ');
1494 Add_Item_To_Name_Buffer (Item_Id);
1495 Add_Str_To_Name_Buffer (" & cannot appear as ");
1497 if Item_Is_Input then
1498 Add_Str_To_Name_Buffer ("output");
1500 Add_Str_To_Name_Buffer ("input");
1503 Add_Str_To_Name_Buffer (" in dependence relation");
1504 Error_Msg := Name_Find;
1505 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1511 Item_Is_Input : Boolean;
1512 Item_Is_Output : Boolean;
1514 -- Start of processing for Check_Role
1517 Find_Role (Item_Is_Input, Item_Is_Output);
1522 if not Item_Is_Input then
1523 Role_Error (Item_Is_Input, Item_Is_Output);
1526 -- Self-referential item
1529 if not Item_Is_Input or else not Item_Is_Output then
1530 Role_Error (Item_Is_Input, Item_Is_Output);
1535 elsif not Item_Is_Output then
1536 Role_Error (Item_Is_Input, Item_Is_Output);
1544 procedure Check_Usage
1545 (Subp_Items : Elist_Id;
1546 Used_Items : Elist_Id;
1549 procedure Usage_Error (Item_Id : Entity_Id);
1550 -- Emit an error concerning the illegal usage of an item
1556 procedure Usage_Error (Item_Id : Entity_Id) is
1557 Error_Msg : Name_Id;
1564 -- Unconstrained and tagged items are not part of the explicit
1565 -- input set of the related subprogram, they do not have to be
1566 -- present in a dependence relation and should not be flagged
1567 -- (SPARK RM 6.1.5(5)).
1569 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1572 Add_Item_To_Name_Buffer (Item_Id);
1573 Add_Str_To_Name_Buffer
1574 (" & is missing from input dependence list");
1576 Error_Msg := Name_Find;
1577 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1579 ("\add `null ='> &` dependency to ignore this input",
1583 -- Output case (SPARK RM 6.1.5(10))
1588 Add_Item_To_Name_Buffer (Item_Id);
1589 Add_Str_To_Name_Buffer
1590 (" & is missing from output dependence list");
1592 Error_Msg := Name_Find;
1593 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1601 Item_Id : Entity_Id;
1603 -- Start of processing for Check_Usage
1606 if No (Subp_Items) then
1610 -- Each input or output of the subprogram must appear in a dependency
1613 Elmt := First_Elmt (Subp_Items);
1614 while Present (Elmt) loop
1615 Item := Node (Elmt);
1617 if Nkind (Item) = N_Defining_Identifier then
1620 Item_Id := Entity_Of (Item);
1623 -- The item does not appear in a dependency
1625 if Present (Item_Id)
1626 and then not Contains (Used_Items, Item_Id)
1628 if Is_Formal (Item_Id) then
1629 Usage_Error (Item_Id);
1631 -- The current instance of a protected type behaves as a formal
1632 -- parameter (SPARK RM 6.1.4).
1634 elsif Ekind (Item_Id) = E_Protected_Type
1635 or else Is_Single_Protected_Object (Item_Id)
1637 Usage_Error (Item_Id);
1639 -- The current instance of a task type behaves as a formal
1640 -- parameter (SPARK RM 6.1.4).
1642 elsif Ekind (Item_Id) = E_Task_Type
1643 or else Is_Single_Task_Object (Item_Id)
1645 -- The dependence of a task unit on itself is implicit and
1646 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1647 -- Emit an error if only one input/output is present.
1649 if Task_Input_Seen /= Task_Output_Seen then
1650 Usage_Error (Item_Id);
1653 -- States and global objects are not used properly only when
1654 -- the subprogram is subject to pragma Global.
1656 elsif Global_Seen then
1657 Usage_Error (Item_Id);
1665 ----------------------
1666 -- Normalize_Clause --
1667 ----------------------
1669 procedure Normalize_Clause (Clause : Node_Id) is
1670 procedure Create_Or_Modify_Clause
1676 Multiple : Boolean);
1677 -- Create a brand new clause to represent the self-reference or
1678 -- modify the input and/or output lists of an existing clause. Output
1679 -- denotes a self-referencial output. Outputs is the output list of a
1680 -- clause. Inputs is the input list of a clause. After denotes the
1681 -- clause after which the new clause is to be inserted. Flag In_Place
1682 -- should be set when normalizing the last output of an output list.
1683 -- Flag Multiple should be set when Output comes from a list with
1686 -----------------------------
1687 -- Create_Or_Modify_Clause --
1688 -----------------------------
1690 procedure Create_Or_Modify_Clause
1698 procedure Propagate_Output
1701 -- Handle the various cases of output propagation to the input
1702 -- list. Output denotes a self-referencial output item. Inputs
1703 -- is the input list of a clause.
1705 ----------------------
1706 -- Propagate_Output --
1707 ----------------------
1709 procedure Propagate_Output
1713 function In_Input_List
1715 Inputs : List_Id) return Boolean;
1716 -- Determine whether a particulat item appears in the input
1717 -- list of a clause.
1723 function In_Input_List
1725 Inputs : List_Id) return Boolean
1730 Elmt := First (Inputs);
1731 while Present (Elmt) loop
1732 if Entity_Of (Elmt) = Item then
1744 Output_Id : constant Entity_Id := Entity_Of (Output);
1747 -- Start of processing for Propagate_Output
1750 -- The clause is of the form:
1752 -- (Output =>+ null)
1754 -- Remove null input and replace it with a copy of the output:
1756 -- (Output => Output)
1758 if Nkind (Inputs) = N_Null then
1759 Rewrite (Inputs, New_Copy_Tree (Output));
1761 -- The clause is of the form:
1763 -- (Output =>+ (Input1, ..., InputN))
1765 -- Determine whether the output is not already mentioned in the
1766 -- input list and if not, add it to the list of inputs:
1768 -- (Output => (Output, Input1, ..., InputN))
1770 elsif Nkind (Inputs) = N_Aggregate then
1771 Grouped := Expressions (Inputs);
1773 if not In_Input_List
1777 Prepend_To (Grouped, New_Copy_Tree (Output));
1780 -- The clause is of the form:
1782 -- (Output =>+ Input)
1784 -- If the input does not mention the output, group the two
1787 -- (Output => (Output, Input))
1789 elsif Entity_Of (Inputs) /= Output_Id then
1791 Make_Aggregate (Loc,
1792 Expressions => New_List (
1793 New_Copy_Tree (Output),
1794 New_Copy_Tree (Inputs))));
1796 end Propagate_Output;
1800 Loc : constant Source_Ptr := Sloc (Clause);
1801 New_Clause : Node_Id;
1803 -- Start of processing for Create_Or_Modify_Clause
1806 -- A null output depending on itself does not require any
1809 if Nkind (Output) = N_Null then
1812 -- A function result cannot depend on itself because it cannot
1813 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1815 elsif Is_Attribute_Result (Output) then
1816 SPARK_Msg_N ("function result cannot depend on itself", Output);
1820 -- When performing the transformation in place, simply add the
1821 -- output to the list of inputs (if not already there). This
1822 -- case arises when dealing with the last output of an output
1823 -- list. Perform the normalization in place to avoid generating
1824 -- a malformed tree.
1827 Propagate_Output (Output, Inputs);
1829 -- A list with multiple outputs is slowly trimmed until only
1830 -- one element remains. When this happens, replace aggregate
1831 -- with the element itself.
1835 Rewrite (Outputs, Output);
1841 -- Unchain the output from its output list as it will appear in
1842 -- a new clause. Note that we cannot simply rewrite the output
1843 -- as null because this will violate the semantics of pragma
1848 -- Generate a new clause of the form:
1849 -- (Output => Inputs)
1852 Make_Component_Association (Loc,
1853 Choices => New_List (Output),
1854 Expression => New_Copy_Tree (Inputs));
1856 -- The new clause contains replicated content that has already
1857 -- been analyzed. There is not need to reanalyze or renormalize
1860 Set_Analyzed (New_Clause);
1863 (Output => First (Choices (New_Clause)),
1864 Inputs => Expression (New_Clause));
1866 Insert_After (After, New_Clause);
1868 end Create_Or_Modify_Clause;
1872 Outputs : constant Node_Id := First (Choices (Clause));
1874 Last_Output : Node_Id;
1875 Next_Output : Node_Id;
1878 -- Start of processing for Normalize_Clause
1881 -- A self-dependency appears as operator "+". Remove the "+" from the
1882 -- tree by moving the real inputs to their proper place.
1884 if Nkind (Expression (Clause)) = N_Op_Plus then
1885 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1886 Inputs := Expression (Clause);
1888 -- Multiple outputs appear as an aggregate
1890 if Nkind (Outputs) = N_Aggregate then
1891 Last_Output := Last (Expressions (Outputs));
1893 Output := First (Expressions (Outputs));
1894 while Present (Output) loop
1896 -- Normalization may remove an output from its list,
1897 -- preserve the subsequent output now.
1899 Next_Output := Next (Output);
1901 Create_Or_Modify_Clause
1906 In_Place => Output = Last_Output,
1909 Output := Next_Output;
1915 Create_Or_Modify_Clause
1924 end Normalize_Clause;
1928 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1929 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1933 Last_Clause : Node_Id;
1934 Restore_Scope : Boolean := False;
1936 -- Start of processing for Analyze_Depends_In_Decl_Part
1939 -- Do not analyze the pragma multiple times
1941 if Is_Analyzed_Pragma (N) then
1945 -- Empty dependency list
1947 if Nkind (Deps) = N_Null then
1949 -- Gather all states, objects and formal parameters that the
1950 -- subprogram may depend on. These items are obtained from the
1951 -- parameter profile or pragma [Refined_]Global (if available).
1953 Collect_Subprogram_Inputs_Outputs
1954 (Subp_Id => Subp_Id,
1955 Subp_Inputs => Subp_Inputs,
1956 Subp_Outputs => Subp_Outputs,
1957 Global_Seen => Global_Seen);
1959 -- Verify that every input or output of the subprogram appear in a
1962 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1963 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1964 Check_Function_Return;
1966 -- Dependency clauses appear as component associations of an aggregate
1968 elsif Nkind (Deps) = N_Aggregate then
1970 -- Do not attempt to perform analysis of a syntactically illegal
1971 -- clause as this will lead to misleading errors.
1973 if Has_Extra_Parentheses (Deps) then
1977 if Present (Component_Associations (Deps)) then
1978 Last_Clause := Last (Component_Associations (Deps));
1980 -- Gather all states, objects and formal parameters that the
1981 -- subprogram may depend on. These items are obtained from the
1982 -- parameter profile or pragma [Refined_]Global (if available).
1984 Collect_Subprogram_Inputs_Outputs
1985 (Subp_Id => Subp_Id,
1986 Subp_Inputs => Subp_Inputs,
1987 Subp_Outputs => Subp_Outputs,
1988 Global_Seen => Global_Seen);
1990 -- When pragma [Refined_]Depends appears on a single concurrent
1991 -- type, it is relocated to the anonymous object.
1993 if Is_Single_Concurrent_Object (Spec_Id) then
1996 -- Ensure that the formal parameters are visible when analyzing
1997 -- all clauses. This falls out of the general rule of aspects
1998 -- pertaining to subprogram declarations.
2000 elsif not In_Open_Scopes (Spec_Id) then
2001 Restore_Scope := True;
2002 Push_Scope (Spec_Id);
2004 if Ekind (Spec_Id) = E_Task_Type then
2006 -- Task discriminants cannot appear in the [Refined_]Depends
2007 -- contract, but must be present for the analysis so that we
2008 -- can reject them with an informative error message.
2010 if Has_Discriminants (Spec_Id) then
2011 Install_Discriminants (Spec_Id);
2014 elsif Is_Generic_Subprogram (Spec_Id) then
2015 Install_Generic_Formals (Spec_Id);
2018 Install_Formals (Spec_Id);
2022 Clause := First (Component_Associations (Deps));
2023 while Present (Clause) loop
2024 Errors := Serious_Errors_Detected;
2026 -- The normalization mechanism may create extra clauses that
2027 -- contain replicated input and output names. There is no need
2028 -- to reanalyze them.
2030 if not Analyzed (Clause) then
2031 Set_Analyzed (Clause);
2033 Analyze_Dependency_Clause
2035 Is_Last => Clause = Last_Clause);
2038 -- Do not normalize a clause if errors were detected (count
2039 -- of Serious_Errors has increased) because the inputs and/or
2040 -- outputs may denote illegal items.
2042 if Serious_Errors_Detected = Errors then
2043 Normalize_Clause (Clause);
2049 if Restore_Scope then
2053 -- Verify that every input or output of the subprogram appear in a
2056 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2057 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2058 Check_Function_Return;
2060 -- The dependency list is malformed. This is a syntax error, always
2064 Error_Msg_N ("malformed dependency relation", Deps);
2068 -- The top level dependency relation is malformed. This is a syntax
2069 -- error, always report.
2072 Error_Msg_N ("malformed dependency relation", Deps);
2076 -- Ensure that a state and a corresponding constituent do not appear
2077 -- together in pragma [Refined_]Depends.
2079 Check_State_And_Constituent_Use
2080 (States => States_Seen,
2081 Constits => Constits_Seen,
2085 Set_Is_Analyzed_Pragma (N);
2086 end Analyze_Depends_In_Decl_Part;
2088 --------------------------------------------
2089 -- Analyze_External_Property_In_Decl_Part --
2090 --------------------------------------------
2092 procedure Analyze_External_Property_In_Decl_Part
2094 Expr_Val : out Boolean)
2096 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2097 Arg1 : constant Node_Id :=
2098 First (Pragma_Argument_Associations (N));
2099 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2100 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2106 -- Do not analyze the pragma multiple times
2108 if Is_Analyzed_Pragma (N) then
2112 Error_Msg_Name_1 := Pragma_Name (N);
2114 -- An external property pragma must apply to an effectively volatile
2115 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2116 -- The check is performed at the end of the declarative region due to a
2117 -- possible out-of-order arrangement of pragmas:
2120 -- pragma Async_Readers (Obj);
2121 -- pragma Volatile (Obj);
2123 if Prag_Id /= Pragma_No_Caching
2124 and then not Is_Effectively_Volatile (Obj_Id)
2126 if Ekind (Obj_Id) = E_Variable
2127 and then No_Caching_Enabled (Obj_Id)
2130 ("illegal combination of external property % and property "
2131 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2134 ("external property % must apply to a volatile type or object",
2138 -- Pragma No_Caching should only apply to volatile variables of
2139 -- a non-effectively volatile type (SPARK RM 7.1.2).
2141 elsif Prag_Id = Pragma_No_Caching then
2142 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2143 SPARK_Msg_N ("property % must not apply to an object of "
2144 & "an effectively volatile type", N);
2145 elsif not Is_Volatile (Obj_Id) then
2146 SPARK_Msg_N ("property % must apply to a volatile object", N);
2150 -- Ensure that the Boolean expression (if present) is static. A missing
2151 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2155 if Present (Arg1) then
2156 Expr := Get_Pragma_Arg (Arg1);
2158 if Is_OK_Static_Expression (Expr) then
2159 Expr_Val := Is_True (Expr_Value (Expr));
2163 Set_Is_Analyzed_Pragma (N);
2164 end Analyze_External_Property_In_Decl_Part;
2166 ---------------------------------
2167 -- Analyze_Global_In_Decl_Part --
2168 ---------------------------------
2170 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2171 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2172 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2173 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2175 Constits_Seen : Elist_Id := No_Elist;
2176 -- A list containing the entities of all constituents processed so far.
2177 -- It aids in detecting illegal usage of a state and a corresponding
2178 -- constituent in pragma [Refinde_]Global.
2180 Seen : Elist_Id := No_Elist;
2181 -- A list containing the entities of all the items processed so far. It
2182 -- plays a role in detecting distinct entities.
2184 States_Seen : Elist_Id := No_Elist;
2185 -- A list containing the entities of all states processed so far. It
2186 -- helps in detecting illegal usage of a state and a corresponding
2187 -- constituent in pragma [Refined_]Global.
2189 In_Out_Seen : Boolean := False;
2190 Input_Seen : Boolean := False;
2191 Output_Seen : Boolean := False;
2192 Proof_Seen : Boolean := False;
2193 -- Flags used to verify the consistency of modes
2195 procedure Analyze_Global_List
2197 Global_Mode : Name_Id := Name_Input);
2198 -- Verify the legality of a single global list declaration. Global_Mode
2199 -- denotes the current mode in effect.
2201 -------------------------
2202 -- Analyze_Global_List --
2203 -------------------------
2205 procedure Analyze_Global_List
2207 Global_Mode : Name_Id := Name_Input)
2209 procedure Analyze_Global_Item
2211 Global_Mode : Name_Id);
2212 -- Verify the legality of a single global item declaration denoted by
2213 -- Item. Global_Mode denotes the current mode in effect.
2215 procedure Check_Duplicate_Mode
2217 Status : in out Boolean);
2218 -- Flag Status denotes whether a particular mode has been seen while
2219 -- processing a global list. This routine verifies that Mode is not a
2220 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2222 procedure Check_Mode_Restriction_In_Enclosing_Context
2224 Item_Id : Entity_Id);
2225 -- Verify that an item of mode In_Out or Output does not appear as
2226 -- an input in the Global aspect of an enclosing subprogram or task
2227 -- unit. If this is the case, emit an error. Item and Item_Id are
2228 -- respectively the item and its entity.
2230 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2231 -- Mode denotes either In_Out or Output. Depending on the kind of the
2232 -- related subprogram, emit an error if those two modes apply to a
2233 -- function (SPARK RM 6.1.4(10)).
2235 -------------------------
2236 -- Analyze_Global_Item --
2237 -------------------------
2239 procedure Analyze_Global_Item
2241 Global_Mode : Name_Id)
2243 Item_Id : Entity_Id;
2246 -- Detect one of the following cases
2248 -- with Global => (null, Name)
2249 -- with Global => (Name_1, null, Name_2)
2250 -- with Global => (Name, null)
2252 if Nkind (Item) = N_Null then
2253 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2258 Resolve_State (Item);
2260 -- Find the entity of the item. If this is a renaming, climb the
2261 -- renaming chain to reach the root object. Renamings of non-
2262 -- entire objects do not yield an entity (Empty).
2264 Item_Id := Entity_Of (Item);
2266 if Present (Item_Id) then
2268 -- A global item may denote a formal parameter of an enclosing
2269 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2270 -- provide a better error diagnostic.
2272 if Is_Formal (Item_Id) then
2273 if Scope (Item_Id) = Spec_Id then
2275 (Fix_Msg (Spec_Id, "global item cannot reference "
2276 & "parameter of subprogram &"), Item, Spec_Id);
2280 -- A global item may denote a concurrent type as long as it is
2281 -- the current instance of an enclosing protected or task type
2282 -- (SPARK RM 6.1.4).
2284 elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
2285 if Is_CCT_Instance (Item_Id, Spec_Id) then
2287 -- Pragma [Refined_]Global associated with a protected
2288 -- subprogram cannot mention the current instance of a
2289 -- protected type because the instance behaves as a
2290 -- formal parameter.
2292 if Ekind (Item_Id) = E_Protected_Type then
2293 if Scope (Spec_Id) = Item_Id then
2294 Error_Msg_Name_1 := Chars (Item_Id);
2296 (Fix_Msg (Spec_Id, "global item of subprogram & "
2297 & "cannot reference current instance of "
2298 & "protected type %"), Item, Spec_Id);
2302 -- Pragma [Refined_]Global associated with a task type
2303 -- cannot mention the current instance of a task type
2304 -- because the instance behaves as a formal parameter.
2306 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2307 if Spec_Id = Item_Id then
2308 Error_Msg_Name_1 := Chars (Item_Id);
2310 (Fix_Msg (Spec_Id, "global item of subprogram & "
2311 & "cannot reference current instance of task "
2312 & "type %"), Item, Spec_Id);
2317 -- Otherwise the global item denotes a subtype mark that is
2318 -- not a current instance.
2322 ("invalid use of subtype mark in global list", Item);
2326 -- A global item may denote the anonymous object created for a
2327 -- single protected/task type as long as the current instance
2328 -- is the same single type (SPARK RM 6.1.4).
2330 elsif Is_Single_Concurrent_Object (Item_Id)
2331 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2333 -- Pragma [Refined_]Global associated with a protected
2334 -- subprogram cannot mention the current instance of a
2335 -- protected type because the instance behaves as a formal
2338 if Is_Single_Protected_Object (Item_Id) then
2339 if Scope (Spec_Id) = Etype (Item_Id) then
2340 Error_Msg_Name_1 := Chars (Item_Id);
2342 (Fix_Msg (Spec_Id, "global item of subprogram & "
2343 & "cannot reference current instance of protected "
2344 & "type %"), Item, Spec_Id);
2348 -- Pragma [Refined_]Global associated with a task type
2349 -- cannot mention the current instance of a task type
2350 -- because the instance behaves as a formal parameter.
2352 else pragma Assert (Is_Single_Task_Object (Item_Id));
2353 if Spec_Id = Item_Id then
2354 Error_Msg_Name_1 := Chars (Item_Id);
2356 (Fix_Msg (Spec_Id, "global item of subprogram & "
2357 & "cannot reference current instance of task "
2358 & "type %"), Item, Spec_Id);
2363 -- A formal object may act as a global item inside a generic
2365 elsif Is_Formal_Object (Item_Id) then
2368 -- The only legal references are those to abstract states,
2369 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2371 elsif Ekind (Item_Id) not in E_Abstract_State
2377 ("global item must denote object, state or current "
2378 & "instance of concurrent type", Item);
2380 if Ekind (Item_Id) in Named_Kind then
2382 ("\named number & is not an object", Item, Item);
2388 -- State related checks
2390 if Ekind (Item_Id) = E_Abstract_State then
2392 -- Package and subprogram bodies are instantiated
2393 -- individually in a separate compiler pass. Due to this
2394 -- mode of instantiation, the refinement of a state may
2395 -- no longer be visible when a subprogram body contract
2396 -- is instantiated. Since the generic template is legal,
2397 -- do not perform this check in the instance to circumvent
2403 -- An abstract state with visible refinement cannot appear
2404 -- in pragma [Refined_]Global as its place must be taken by
2405 -- some of its constituents (SPARK RM 6.1.4(7)).
2407 elsif Has_Visible_Refinement (Item_Id) then
2409 ("cannot mention state & in global refinement",
2411 SPARK_Msg_N ("\use its constituents instead", Item);
2414 -- An external state cannot appear as a global item of a
2415 -- nonvolatile function (SPARK RM 7.1.3(8)).
2417 elsif Is_External_State (Item_Id)
2418 and then Ekind (Spec_Id) in E_Function | E_Generic_Function
2419 and then not Is_Volatile_Function (Spec_Id)
2422 ("external state & cannot act as global item of "
2423 & "nonvolatile function", Item, Item_Id);
2426 -- If the reference to the abstract state appears in an
2427 -- enclosing package body that will eventually refine the
2428 -- state, record the reference for future checks.
2431 Record_Possible_Body_Reference
2432 (State_Id => Item_Id,
2436 -- Constant related checks
2438 elsif Ekind (Item_Id) = E_Constant
2439 and then not Is_Access_Type (Etype (Item_Id))
2442 -- Unless it is of an access type, a constant is a read-only
2443 -- item, therefore it cannot act as an output.
2445 if Global_Mode in Name_In_Out | Name_Output then
2447 ("constant & cannot act as output", Item, Item_Id);
2451 -- Loop parameter related checks
2453 elsif Ekind (Item_Id) = E_Loop_Parameter then
2455 -- A loop parameter is a read-only item, therefore it cannot
2456 -- act as an output.
2458 if Global_Mode in Name_In_Out | Name_Output then
2460 ("loop parameter & cannot act as output",
2465 -- Variable related checks. These are only relevant when
2466 -- SPARK_Mode is on as they are not standard Ada legality
2469 elsif SPARK_Mode = On
2470 and then Ekind (Item_Id) = E_Variable
2471 and then Is_Effectively_Volatile_For_Reading (Item_Id)
2473 -- An effectively volatile object for reading cannot appear
2474 -- as a global item of a nonvolatile function (SPARK RM
2477 if Ekind (Spec_Id) in E_Function | E_Generic_Function
2478 and then not Is_Volatile_Function (Spec_Id)
2481 ("volatile object & cannot act as global item of a "
2482 & "function", Item, Item_Id);
2485 -- An effectively volatile object with external property
2486 -- Effective_Reads set to True must have mode Output or
2487 -- In_Out (SPARK RM 7.1.3(10)).
2489 elsif Effective_Reads_Enabled (Item_Id)
2490 and then Global_Mode = Name_Input
2493 ("volatile object & with property Effective_Reads must "
2494 & "have mode In_Out or Output", Item, Item_Id);
2499 -- When the item renames an entire object, replace the item
2500 -- with a reference to the object.
2502 if Entity (Item) /= Item_Id then
2503 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2507 -- Some form of illegal construct masquerading as a name
2508 -- (SPARK RM 6.1.4(4)).
2512 ("global item must denote object, state or current instance "
2513 & "of concurrent type", Item);
2517 -- Verify that an output does not appear as an input in an
2518 -- enclosing subprogram.
2520 if Global_Mode in Name_In_Out | Name_Output then
2521 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2524 -- The same entity might be referenced through various way.
2525 -- Check the entity of the item rather than the item itself
2526 -- (SPARK RM 6.1.4(10)).
2528 if Contains (Seen, Item_Id) then
2529 SPARK_Msg_N ("duplicate global item", Item);
2531 -- Add the entity of the current item to the list of processed
2535 Append_New_Elmt (Item_Id, Seen);
2537 if Ekind (Item_Id) = E_Abstract_State then
2538 Append_New_Elmt (Item_Id, States_Seen);
2540 -- The variable may eventually become a constituent of a single
2541 -- protected/task type. Record the reference now and verify its
2542 -- legality when analyzing the contract of the variable
2545 elsif Ekind (Item_Id) = E_Variable then
2546 Record_Possible_Part_Of_Reference
2551 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
2552 and then Present (Encapsulating_State (Item_Id))
2554 Append_New_Elmt (Item_Id, Constits_Seen);
2557 end Analyze_Global_Item;
2559 --------------------------
2560 -- Check_Duplicate_Mode --
2561 --------------------------
2563 procedure Check_Duplicate_Mode
2565 Status : in out Boolean)
2569 SPARK_Msg_N ("duplicate global mode", Mode);
2573 end Check_Duplicate_Mode;
2575 -------------------------------------------------
2576 -- Check_Mode_Restriction_In_Enclosing_Context --
2577 -------------------------------------------------
2579 procedure Check_Mode_Restriction_In_Enclosing_Context
2581 Item_Id : Entity_Id)
2583 Context : Entity_Id;
2585 Inputs : Elist_Id := No_Elist;
2586 Outputs : Elist_Id := No_Elist;
2589 -- Traverse the scope stack looking for enclosing subprograms or
2590 -- tasks subject to pragma [Refined_]Global.
2592 Context := Scope (Subp_Id);
2593 while Present (Context) and then Context /= Standard_Standard loop
2595 -- For a single task type, retrieve the corresponding object to
2596 -- which pragma [Refined_]Global is attached.
2598 if Ekind (Context) = E_Task_Type
2599 and then Is_Single_Concurrent_Type (Context)
2601 Context := Anonymous_Object (Context);
2604 if (Is_Subprogram (Context)
2605 or else Ekind (Context) = E_Task_Type
2606 or else Is_Single_Task_Object (Context))
2608 (Present (Get_Pragma (Context, Pragma_Global))
2610 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2612 Collect_Subprogram_Inputs_Outputs
2613 (Subp_Id => Context,
2614 Subp_Inputs => Inputs,
2615 Subp_Outputs => Outputs,
2616 Global_Seen => Dummy);
2618 -- The item is classified as In_Out or Output but appears as
2619 -- an Input in an enclosing subprogram or task unit (SPARK
2622 if Appears_In (Inputs, Item_Id)
2623 and then not Appears_In (Outputs, Item_Id)
2626 ("global item & cannot have mode In_Out or Output",
2629 if Is_Subprogram (Context) then
2631 (Fix_Msg (Subp_Id, "\item already appears as input "
2632 & "of subprogram &"), Item, Context);
2635 (Fix_Msg (Subp_Id, "\item already appears as input "
2636 & "of task &"), Item, Context);
2639 -- Stop the traversal once an error has been detected
2645 Context := Scope (Context);
2647 end Check_Mode_Restriction_In_Enclosing_Context;
2649 ----------------------------------------
2650 -- Check_Mode_Restriction_In_Function --
2651 ----------------------------------------
2653 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2655 if Ekind (Spec_Id) in E_Function | E_Generic_Function then
2657 ("global mode & is not applicable to functions", Mode);
2659 end Check_Mode_Restriction_In_Function;
2667 -- Start of processing for Analyze_Global_List
2670 if Nkind (List) = N_Null then
2671 Set_Analyzed (List);
2673 -- Single global item declaration
2675 elsif Nkind (List) in N_Expanded_Name
2677 | N_Selected_Component
2679 Analyze_Global_Item (List, Global_Mode);
2681 -- Simple global list or moded global list declaration
2683 elsif Nkind (List) = N_Aggregate then
2684 Set_Analyzed (List);
2686 -- The declaration of a simple global list appear as a collection
2689 if Present (Expressions (List)) then
2690 if Present (Component_Associations (List)) then
2692 ("cannot mix moded and non-moded global lists", List);
2695 Item := First (Expressions (List));
2696 while Present (Item) loop
2697 Analyze_Global_Item (Item, Global_Mode);
2701 -- The declaration of a moded global list appears as a collection
2702 -- of component associations where individual choices denote
2705 elsif Present (Component_Associations (List)) then
2706 if Present (Expressions (List)) then
2708 ("cannot mix moded and non-moded global lists", List);
2711 Assoc := First (Component_Associations (List));
2712 while Present (Assoc) loop
2713 Mode := First (Choices (Assoc));
2715 if Nkind (Mode) = N_Identifier then
2716 if Chars (Mode) = Name_In_Out then
2717 Check_Duplicate_Mode (Mode, In_Out_Seen);
2718 Check_Mode_Restriction_In_Function (Mode);
2720 elsif Chars (Mode) = Name_Input then
2721 Check_Duplicate_Mode (Mode, Input_Seen);
2723 elsif Chars (Mode) = Name_Output then
2724 Check_Duplicate_Mode (Mode, Output_Seen);
2725 Check_Mode_Restriction_In_Function (Mode);
2727 elsif Chars (Mode) = Name_Proof_In then
2728 Check_Duplicate_Mode (Mode, Proof_Seen);
2731 SPARK_Msg_N ("invalid mode selector", Mode);
2735 SPARK_Msg_N ("invalid mode selector", Mode);
2738 -- Items in a moded list appear as a collection of
2739 -- expressions. Reuse the existing machinery to analyze
2743 (List => Expression (Assoc),
2744 Global_Mode => Chars (Mode));
2752 raise Program_Error;
2755 -- Any other attempt to declare a global item is illegal. This is a
2756 -- syntax error, always report.
2759 Error_Msg_N ("malformed global list", List);
2761 end Analyze_Global_List;
2765 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2767 Restore_Scope : Boolean := False;
2769 -- Start of processing for Analyze_Global_In_Decl_Part
2772 -- Do not analyze the pragma multiple times
2774 if Is_Analyzed_Pragma (N) then
2778 -- There is nothing to be done for a null global list
2780 if Nkind (Items) = N_Null then
2781 Set_Analyzed (Items);
2783 -- Analyze the various forms of global lists and items. Note that some
2784 -- of these may be malformed in which case the analysis emits error
2788 -- When pragma [Refined_]Global appears on a single concurrent type,
2789 -- it is relocated to the anonymous object.
2791 if Is_Single_Concurrent_Object (Spec_Id) then
2794 -- Ensure that the formal parameters are visible when processing an
2795 -- item. This falls out of the general rule of aspects pertaining to
2796 -- subprogram declarations.
2798 elsif not In_Open_Scopes (Spec_Id) then
2799 Restore_Scope := True;
2800 Push_Scope (Spec_Id);
2802 if Ekind (Spec_Id) = E_Task_Type then
2804 -- Task discriminants cannot appear in the [Refined_]Global
2805 -- contract, but must be present for the analysis so that we
2806 -- can reject them with an informative error message.
2808 if Has_Discriminants (Spec_Id) then
2809 Install_Discriminants (Spec_Id);
2812 elsif Is_Generic_Subprogram (Spec_Id) then
2813 Install_Generic_Formals (Spec_Id);
2816 Install_Formals (Spec_Id);
2820 Analyze_Global_List (Items);
2822 if Restore_Scope then
2827 -- Ensure that a state and a corresponding constituent do not appear
2828 -- together in pragma [Refined_]Global.
2830 Check_State_And_Constituent_Use
2831 (States => States_Seen,
2832 Constits => Constits_Seen,
2835 Set_Is_Analyzed_Pragma (N);
2836 end Analyze_Global_In_Decl_Part;
2838 --------------------------------------------
2839 -- Analyze_Initial_Condition_In_Decl_Part --
2840 --------------------------------------------
2842 -- WARNING: This routine manages Ghost regions. Return statements must be
2843 -- replaced by gotos which jump to the end of the routine and restore the
2846 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2847 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2848 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2849 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2851 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2852 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2853 -- Save the Ghost-related attributes to restore on exit
2856 -- Do not analyze the pragma multiple times
2858 if Is_Analyzed_Pragma (N) then
2862 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2863 -- analysis of the pragma, the Ghost mode at point of declaration and
2864 -- point of analysis may not necessarily be the same. Use the mode in
2865 -- effect at the point of declaration.
2869 -- The expression is preanalyzed because it has not been moved to its
2870 -- final place yet. A direct analysis may generate side effects and this
2871 -- is not desired at this point.
2873 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2874 Set_Is_Analyzed_Pragma (N);
2876 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2877 end Analyze_Initial_Condition_In_Decl_Part;
2879 --------------------------------------
2880 -- Analyze_Initializes_In_Decl_Part --
2881 --------------------------------------
2883 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2884 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2885 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2887 Constits_Seen : Elist_Id := No_Elist;
2888 -- A list containing the entities of all constituents processed so far.
2889 -- It aids in detecting illegal usage of a state and a corresponding
2890 -- constituent in pragma Initializes.
2892 Items_Seen : Elist_Id := No_Elist;
2893 -- A list of all initialization items processed so far. This list is
2894 -- used to detect duplicate items.
2896 States_And_Objs : Elist_Id := No_Elist;
2897 -- A list of all abstract states and objects declared in the visible
2898 -- declarations of the related package. This list is used to detect the
2899 -- legality of initialization items.
2901 States_Seen : Elist_Id := No_Elist;
2902 -- A list containing the entities of all states processed so far. It
2903 -- helps in detecting illegal usage of a state and a corresponding
2904 -- constituent in pragma Initializes.
2906 procedure Analyze_Initialization_Item (Item : Node_Id);
2907 -- Verify the legality of a single initialization item
2909 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2910 -- Verify the legality of a single initialization item followed by a
2911 -- list of input items.
2913 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
2914 -- Inspect the visible declarations of the related package and gather
2915 -- the entities of all abstract states and objects in States_And_Objs.
2917 ---------------------------------
2918 -- Analyze_Initialization_Item --
2919 ---------------------------------
2921 procedure Analyze_Initialization_Item (Item : Node_Id) is
2922 Item_Id : Entity_Id;
2926 Resolve_State (Item);
2928 if Is_Entity_Name (Item) then
2929 Item_Id := Entity_Of (Item);
2931 if Present (Item_Id)
2932 and then Ekind (Item_Id) in
2933 E_Abstract_State | E_Constant | E_Variable
2935 -- When the initialization item is undefined, it appears as
2936 -- Any_Id. Do not continue with the analysis of the item.
2938 if Item_Id = Any_Id then
2941 -- The state or variable must be declared in the visible
2942 -- declarations of the package (SPARK RM 7.1.5(7)).
2944 elsif not Contains (States_And_Objs, Item_Id) then
2945 Error_Msg_Name_1 := Chars (Pack_Id);
2947 ("initialization item & must appear in the visible "
2948 & "declarations of package %", Item, Item_Id);
2950 -- Detect a duplicate use of the same initialization item
2951 -- (SPARK RM 7.1.5(5)).
2953 elsif Contains (Items_Seen, Item_Id) then
2954 SPARK_Msg_N ("duplicate initialization item", Item);
2956 -- The item is legal, add it to the list of processed states
2960 Append_New_Elmt (Item_Id, Items_Seen);
2962 if Ekind (Item_Id) = E_Abstract_State then
2963 Append_New_Elmt (Item_Id, States_Seen);
2966 if Present (Encapsulating_State (Item_Id)) then
2967 Append_New_Elmt (Item_Id, Constits_Seen);
2971 -- The item references something that is not a state or object
2972 -- (SPARK RM 7.1.5(3)).
2976 ("initialization item must denote object or state", Item);
2979 -- Some form of illegal construct masquerading as a name
2980 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2984 ("initialization item must denote object or state", Item);
2986 end Analyze_Initialization_Item;
2988 ---------------------------------------------
2989 -- Analyze_Initialization_Item_With_Inputs --
2990 ---------------------------------------------
2992 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2993 Inputs_Seen : Elist_Id := No_Elist;
2994 -- A list of all inputs processed so far. This list is used to detect
2995 -- duplicate uses of an input.
2997 Non_Null_Seen : Boolean := False;
2998 Null_Seen : Boolean := False;
2999 -- Flags used to check the legality of an input list
3001 procedure Analyze_Input_Item (Input : Node_Id);
3002 -- Verify the legality of a single input item
3004 ------------------------
3005 -- Analyze_Input_Item --
3006 ------------------------
3008 procedure Analyze_Input_Item (Input : Node_Id) is
3009 Input_Id : Entity_Id;
3014 if Nkind (Input) = N_Null then
3017 ("multiple null initializations not allowed", Item);
3019 elsif Non_Null_Seen then
3021 ("cannot mix null and non-null initialization item", Item);
3029 Non_Null_Seen := True;
3033 ("cannot mix null and non-null initialization item", Item);
3037 Resolve_State (Input);
3039 if Is_Entity_Name (Input) then
3040 Input_Id := Entity_Of (Input);
3042 if Present (Input_Id)
3043 and then Ekind (Input_Id) in E_Abstract_State
3045 | E_Generic_In_Out_Parameter
3046 | E_Generic_In_Parameter
3048 | E_In_Out_Parameter
3054 -- The input cannot denote states or objects declared
3055 -- within the related package (SPARK RM 7.1.5(4)).
3057 if Within_Scope (Input_Id, Current_Scope) then
3059 -- Do not consider generic formal parameters or their
3060 -- respective mappings to generic formals. Even though
3061 -- the formals appear within the scope of the package,
3062 -- it is allowed for an initialization item to depend
3063 -- on an input item.
3065 if Ekind (Input_Id) in E_Generic_In_Out_Parameter
3066 | E_Generic_In_Parameter
3070 elsif Ekind (Input_Id) in E_Constant | E_Variable
3071 and then Present (Corresponding_Generic_Association
3072 (Declaration_Node (Input_Id)))
3077 Error_Msg_Name_1 := Chars (Pack_Id);
3079 ("input item & cannot denote a visible object or "
3080 & "state of package %", Input, Input_Id);
3085 -- Detect a duplicate use of the same input item
3086 -- (SPARK RM 7.1.5(5)).
3088 if Contains (Inputs_Seen, Input_Id) then
3089 SPARK_Msg_N ("duplicate input item", Input);
3093 -- At this point it is known that the input is legal. Add
3094 -- it to the list of processed inputs.
3096 Append_New_Elmt (Input_Id, Inputs_Seen);
3098 if Ekind (Input_Id) = E_Abstract_State then
3099 Append_New_Elmt (Input_Id, States_Seen);
3102 if Ekind (Input_Id) in E_Abstract_State
3105 and then Present (Encapsulating_State (Input_Id))
3107 Append_New_Elmt (Input_Id, Constits_Seen);
3110 -- The input references something that is not a state or an
3111 -- object (SPARK RM 7.1.5(3)).
3115 ("input item must denote object or state", Input);
3118 -- Some form of illegal construct masquerading as a name
3119 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3123 ("input item must denote object or state", Input);
3126 end Analyze_Input_Item;
3130 Inputs : constant Node_Id := Expression (Item);
3134 Name_Seen : Boolean := False;
3135 -- A flag used to detect multiple item names
3137 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3140 -- Inspect the name of an item with inputs
3142 Elmt := First (Choices (Item));
3143 while Present (Elmt) loop
3145 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3148 Analyze_Initialization_Item (Elmt);
3154 -- Multiple input items appear as an aggregate
3156 if Nkind (Inputs) = N_Aggregate then
3157 if Present (Expressions (Inputs)) then
3158 Input := First (Expressions (Inputs));
3159 while Present (Input) loop
3160 Analyze_Input_Item (Input);
3165 if Present (Component_Associations (Inputs)) then
3167 ("inputs must appear in named association form", Inputs);
3170 -- Single input item
3173 Analyze_Input_Item (Inputs);
3175 end Analyze_Initialization_Item_With_Inputs;
3177 --------------------------------
3178 -- Collect_States_And_Objects --
3179 --------------------------------
3181 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3182 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3183 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3185 State_Elmt : Elmt_Id;
3188 -- Collect the abstract states defined in the package (if any)
3190 if Has_Non_Null_Abstract_State (Pack_Id) then
3191 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3192 while Present (State_Elmt) loop
3193 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3194 Next_Elmt (State_Elmt);
3198 -- Collect all objects that appear in the visible declarations of the
3201 if Present (Visible_Declarations (Pack_Spec)) then
3202 Decl := First (Visible_Declarations (Pack_Spec));
3203 while Present (Decl) loop
3204 if Comes_From_Source (Decl)
3205 and then Nkind (Decl) in N_Object_Declaration
3206 | N_Object_Renaming_Declaration
3208 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3210 elsif Nkind (Decl) = N_Package_Declaration then
3211 Collect_States_And_Objects (Decl);
3213 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3215 (Anonymous_Object (Defining_Entity (Decl)),
3222 end Collect_States_And_Objects;
3226 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3229 -- Start of processing for Analyze_Initializes_In_Decl_Part
3232 -- Do not analyze the pragma multiple times
3234 if Is_Analyzed_Pragma (N) then
3238 -- Nothing to do when the initialization list is empty
3240 if Nkind (Inits) = N_Null then
3244 -- Single and multiple initialization clauses appear as an aggregate. If
3245 -- this is not the case, then either the parser or the analysis of the
3246 -- pragma failed to produce an aggregate.
3248 pragma Assert (Nkind (Inits) = N_Aggregate);
3250 -- Initialize the various lists used during analysis
3252 Collect_States_And_Objects (Pack_Decl);
3254 if Present (Expressions (Inits)) then
3255 Init := First (Expressions (Inits));
3256 while Present (Init) loop
3257 Analyze_Initialization_Item (Init);
3262 if Present (Component_Associations (Inits)) then
3263 Init := First (Component_Associations (Inits));
3264 while Present (Init) loop
3265 Analyze_Initialization_Item_With_Inputs (Init);
3270 -- Ensure that a state and a corresponding constituent do not appear
3271 -- together in pragma Initializes.
3273 Check_State_And_Constituent_Use
3274 (States => States_Seen,
3275 Constits => Constits_Seen,
3278 Set_Is_Analyzed_Pragma (N);
3279 end Analyze_Initializes_In_Decl_Part;
3281 ---------------------
3282 -- Analyze_Part_Of --
3283 ---------------------
3285 procedure Analyze_Part_Of
3287 Item_Id : Entity_Id;
3289 Encap_Id : out Entity_Id;
3290 Legal : out Boolean)
3292 procedure Check_Part_Of_Abstract_State;
3293 pragma Inline (Check_Part_Of_Abstract_State);
3294 -- Verify the legality of indicator Part_Of when the encapsulator is an
3297 procedure Check_Part_Of_Concurrent_Type;
3298 pragma Inline (Check_Part_Of_Concurrent_Type);
3299 -- Verify the legality of indicator Part_Of when the encapsulator is a
3300 -- single concurrent type.
3302 ----------------------------------
3303 -- Check_Part_Of_Abstract_State --
3304 ----------------------------------
3306 procedure Check_Part_Of_Abstract_State is
3307 Pack_Id : Entity_Id;
3308 Placement : State_Space_Kind;
3309 Parent_Unit : Entity_Id;
3312 -- Determine where the object, package instantiation or state lives
3313 -- with respect to the enclosing packages or package bodies.
3315 Find_Placement_In_State_Space
3316 (Item_Id => Item_Id,
3317 Placement => Placement,
3318 Pack_Id => Pack_Id);
3320 -- The item appears in a non-package construct with a declarative
3321 -- part (subprogram, block, etc). As such, the item is not allowed
3322 -- to be a part of an encapsulating state because the item is not
3325 if Placement = Not_In_Package then
3327 ("indicator Part_Of cannot appear in this context "
3328 & "(SPARK RM 7.2.6(5))", Indic);
3330 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3332 ("\& is not part of the hidden state of package %",
3336 -- The item appears in the visible state space of some package. In
3337 -- general this scenario does not warrant Part_Of except when the
3338 -- package is a nongeneric private child unit and the encapsulating
3339 -- state is declared in a parent unit or a public descendant of that
3342 elsif Placement = Visible_State_Space then
3343 if Is_Child_Unit (Pack_Id)
3344 and then not Is_Generic_Unit (Pack_Id)
3345 and then Is_Private_Descendant (Pack_Id)
3347 -- A variable or state abstraction which is part of the visible
3348 -- state of a nongeneric private child unit or its public
3349 -- descendants must have its Part_Of indicator specified. The
3350 -- Part_Of indicator must denote a state declared by either the
3351 -- parent unit of the private unit or by a public descendant of
3352 -- that parent unit.
3354 -- Find the nearest private ancestor (which can be the current
3357 Parent_Unit := Pack_Id;
3358 while Present (Parent_Unit) loop
3361 (Parent (Unit_Declaration_Node (Parent_Unit)));
3362 Parent_Unit := Scope (Parent_Unit);
3365 Parent_Unit := Scope (Parent_Unit);
3367 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3369 ("indicator Part_Of must denote abstract state of & or of "
3370 & "its public descendant (SPARK RM 7.2.6(3))",
3371 Indic, Parent_Unit);
3374 elsif Scope (Encap_Id) = Parent_Unit
3376 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3377 and then not Is_Private_Descendant (Scope (Encap_Id)))
3383 ("indicator Part_Of must denote abstract state of & or of "
3384 & "its public descendant (SPARK RM 7.2.6(3))",
3385 Indic, Parent_Unit);
3389 -- Indicator Part_Of is not needed when the related package is
3390 -- not a nongeneric private child unit or a public descendant
3395 ("indicator Part_Of cannot appear in this context "
3396 & "(SPARK RM 7.2.6(5))", Indic);
3398 Error_Msg_Name_1 := Chars (Pack_Id);
3400 ("\& is declared in the visible part of package %",
3405 -- When the item appears in the private state space of a package, the
3406 -- encapsulating state must be declared in the same package.
3408 elsif Placement = Private_State_Space then
3409 if Scope (Encap_Id) /= Pack_Id then
3411 ("indicator Part_Of must denote an abstract state of "
3412 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3414 Error_Msg_Name_1 := Chars (Pack_Id);
3416 ("\& is declared in the private part of package %",
3421 -- Items declared in the body state space of a package do not need
3422 -- Part_Of indicators as the refinement has already been seen.
3426 ("indicator Part_Of cannot appear in this context "
3427 & "(SPARK RM 7.2.6(5))", Indic);
3429 if Scope (Encap_Id) = Pack_Id then
3430 Error_Msg_Name_1 := Chars (Pack_Id);
3432 ("\& is declared in the body of package %", Indic, Item_Id);
3438 -- At this point it is known that the Part_Of indicator is legal
3441 end Check_Part_Of_Abstract_State;
3443 -----------------------------------
3444 -- Check_Part_Of_Concurrent_Type --
3445 -----------------------------------
3447 procedure Check_Part_Of_Concurrent_Type is
3448 function In_Proper_Order
3450 Second : Node_Id) return Boolean;
3451 pragma Inline (In_Proper_Order);
3452 -- Determine whether node First precedes node Second
3454 procedure Placement_Error;
3455 pragma Inline (Placement_Error);
3456 -- Emit an error concerning the illegal placement of the item with
3457 -- respect to the single concurrent type.
3459 ---------------------
3460 -- In_Proper_Order --
3461 ---------------------
3463 function In_Proper_Order
3465 Second : Node_Id) return Boolean
3470 if List_Containing (First) = List_Containing (Second) then
3472 while Present (N) loop
3482 end In_Proper_Order;
3484 ---------------------
3485 -- Placement_Error --
3486 ---------------------
3488 procedure Placement_Error is
3491 ("indicator Part_Of must denote a previously declared single "
3492 & "protected type or single task type", Encap);
3493 end Placement_Error;
3497 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3498 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3499 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3501 Item_Context : Node_Id;
3502 Item_Decl : Node_Id;
3503 Prv_Decls : List_Id;
3504 Vis_Decls : List_Id;
3506 -- Start of processing for Check_Part_Of_Concurrent_Type
3509 -- Only abstract states and variables can act as constituents of an
3510 -- encapsulating single concurrent type.
3512 if Ekind (Item_Id) in E_Abstract_State | E_Variable then
3515 -- The constituent is a constant
3517 elsif Ekind (Item_Id) = E_Constant then
3518 Error_Msg_Name_1 := Chars (Encap_Id);
3520 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3521 & "single protected type %"), Indic, Item_Id);
3524 -- The constituent is a package instantiation
3527 Error_Msg_Name_1 := Chars (Encap_Id);
3529 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3530 & "constituent of single protected type %"), Indic, Item_Id);
3534 -- When the item denotes an abstract state of a nested package, use
3535 -- the declaration of the package to detect proper placement.
3540 -- with Abstract_State => (State with Part_Of => T)
3542 if Ekind (Item_Id) = E_Abstract_State then
3543 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3545 Item_Decl := Declaration_Node (Item_Id);
3548 Item_Context := Parent (Item_Decl);
3550 -- The item and the single concurrent type must appear in the same
3551 -- declarative region, with the item following the declaration of
3552 -- the single concurrent type (SPARK RM 9(3)).
3554 if Item_Context = Encap_Context then
3555 if Nkind (Item_Context) in N_Package_Specification
3556 | N_Protected_Definition
3559 Prv_Decls := Private_Declarations (Item_Context);
3560 Vis_Decls := Visible_Declarations (Item_Context);
3562 -- The placement is OK when the single concurrent type appears
3563 -- within the visible declarations and the item in the private
3569 -- Constit : ... with Part_Of => PO;
3572 if List_Containing (Encap_Decl) = Vis_Decls
3573 and then List_Containing (Item_Decl) = Prv_Decls
3577 -- The placement is illegal when the item appears within the
3578 -- visible declarations and the single concurrent type is in
3579 -- the private declarations.
3582 -- Constit : ... with Part_Of => PO;
3587 elsif List_Containing (Item_Decl) = Vis_Decls
3588 and then List_Containing (Encap_Decl) = Prv_Decls
3593 -- Otherwise both the item and the single concurrent type are
3594 -- in the same list. Ensure that the declaration of the single
3595 -- concurrent type precedes that of the item.
3597 elsif not In_Proper_Order
3598 (First => Encap_Decl,
3599 Second => Item_Decl)
3605 -- Otherwise both the item and the single concurrent type are
3606 -- in the same list. Ensure that the declaration of the single
3607 -- concurrent type precedes that of the item.
3609 elsif not In_Proper_Order
3610 (First => Encap_Decl,
3611 Second => Item_Decl)
3617 -- Otherwise the item and the single concurrent type reside within
3618 -- unrelated regions.
3621 Error_Msg_Name_1 := Chars (Encap_Id);
3623 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3624 & "immediately within the same region as single protected "
3625 & "type %"), Indic, Item_Id);
3629 -- At this point it is known that the Part_Of indicator is legal
3632 end Check_Part_Of_Concurrent_Type;
3634 -- Start of processing for Analyze_Part_Of
3637 -- Assume that the indicator is illegal
3643 N_Expanded_Name | N_Identifier | N_Selected_Component
3646 Resolve_State (Encap);
3648 Encap_Id := Entity (Encap);
3650 -- The encapsulator is an abstract state
3652 if Ekind (Encap_Id) = E_Abstract_State then
3655 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3657 elsif Is_Single_Concurrent_Object (Encap_Id) then
3660 -- Otherwise the encapsulator is not a legal choice
3664 ("indicator Part_Of must denote abstract state, single "
3665 & "protected type or single task type", Encap);
3669 -- This is a syntax error, always report
3673 ("indicator Part_Of must denote abstract state, single protected "
3674 & "type or single task type", Encap);
3678 -- Catch a case where indicator Part_Of denotes the abstract view of a
3679 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3681 if From_Limited_With (Encap_Id)
3682 and then Present (Non_Limited_View (Encap_Id))
3683 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3685 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3686 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3690 -- The encapsulator is an abstract state
3692 if Ekind (Encap_Id) = E_Abstract_State then
3693 Check_Part_Of_Abstract_State;
3695 -- The encapsulator is a single concurrent type
3698 Check_Part_Of_Concurrent_Type;
3700 end Analyze_Part_Of;
3702 ----------------------------------
3703 -- Analyze_Part_Of_In_Decl_Part --
3704 ----------------------------------
3706 procedure Analyze_Part_Of_In_Decl_Part
3708 Freeze_Id : Entity_Id := Empty)
3710 Encap : constant Node_Id :=
3711 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3712 Errors : constant Nat := Serious_Errors_Detected;
3713 Var_Decl : constant Node_Id := Find_Related_Context (N);
3714 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3715 Constits : Elist_Id;
3716 Encap_Id : Entity_Id;
3720 -- Detect any discrepancies between the placement of the variable with
3721 -- respect to general state space and the encapsulating state or single
3728 Encap_Id => Encap_Id,
3731 -- The Part_Of indicator turns the variable into a constituent of the
3732 -- encapsulating state or single concurrent type.
3735 pragma Assert (Present (Encap_Id));
3736 Constits := Part_Of_Constituents (Encap_Id);
3738 if No (Constits) then
3739 Constits := New_Elmt_List;
3740 Set_Part_Of_Constituents (Encap_Id, Constits);
3743 Append_Elmt (Var_Id, Constits);
3744 Set_Encapsulating_State (Var_Id, Encap_Id);
3746 -- A Part_Of constituent partially refines an abstract state. This
3747 -- property does not apply to protected or task units.
3749 if Ekind (Encap_Id) = E_Abstract_State then
3750 Set_Has_Partial_Visible_Refinement (Encap_Id);
3754 -- Emit a clarification message when the encapsulator is undefined,
3755 -- possibly due to contract freezing.
3757 if Errors /= Serious_Errors_Detected
3758 and then Present (Freeze_Id)
3759 and then Has_Undefined_Reference (Encap)
3761 Contract_Freeze_Error (Var_Id, Freeze_Id);
3763 end Analyze_Part_Of_In_Decl_Part;
3765 --------------------
3766 -- Analyze_Pragma --
3767 --------------------
3769 procedure Analyze_Pragma (N : Node_Id) is
3770 Loc : constant Source_Ptr := Sloc (N);
3772 Pname : Name_Id := Pragma_Name (N);
3773 -- Name of the source pragma, or name of the corresponding aspect for
3774 -- pragmas which originate in a source aspect. In the latter case, the
3775 -- name may be different from the pragma name.
3777 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3779 Pragma_Exit : exception;
3780 -- This exception is used to exit pragma processing completely. It
3781 -- is used when an error is detected, and no further processing is
3782 -- required. It is also used if an earlier error has left the tree in
3783 -- a state where the pragma should not be processed.
3786 -- Number of pragma argument associations
3793 -- First five pragma arguments (pragma argument association nodes, or
3794 -- Empty if the corresponding argument does not exist).
3796 type Name_List is array (Natural range <>) of Name_Id;
3797 type Args_List is array (Natural range <>) of Node_Id;
3798 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3800 -----------------------
3801 -- Local Subprograms --
3802 -----------------------
3804 procedure Ada_2005_Pragma;
3805 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3806 -- Ada 95 mode, these are implementation defined pragmas, so should be
3807 -- caught by the No_Implementation_Pragmas restriction.
3809 procedure Ada_2012_Pragma;
3810 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3811 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3812 -- should be caught by the No_Implementation_Pragmas restriction.
3814 procedure Analyze_Depends_Global
3815 (Spec_Id : out Entity_Id;
3816 Subp_Decl : out Node_Id;
3817 Legal : out Boolean);
3818 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3819 -- legality of the placement and related context of the pragma. Spec_Id
3820 -- is the entity of the related subprogram. Subp_Decl is the declaration
3821 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3823 procedure Analyze_If_Present (Id : Pragma_Id);
3824 -- Inspect the remainder of the list containing pragma N and look for
3825 -- a pragma that matches Id. If found, analyze the pragma.
3827 procedure Analyze_Pre_Post_Condition;
3828 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3830 procedure Analyze_Refined_Depends_Global_Post
3831 (Spec_Id : out Entity_Id;
3832 Body_Id : out Entity_Id;
3833 Legal : out Boolean);
3834 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3835 -- Refined_Global and Refined_Post. Verify the legality of the placement
3836 -- and related context of the pragma. Spec_Id is the entity of the
3837 -- related subprogram. Body_Id is the entity of the subprogram body.
3838 -- Flag Legal is set when the pragma is legal.
3840 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3841 -- Perform full analysis of pragma Unmodified and the write aspect of
3842 -- pragma Unused. Flag Is_Unused should be set when verifying the
3843 -- semantics of pragma Unused.
3845 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3846 -- Perform full analysis of pragma Unreferenced and the read aspect of
3847 -- pragma Unused. Flag Is_Unused should be set when verifying the
3848 -- semantics of pragma Unused.
3850 procedure Check_Ada_83_Warning;
3851 -- Issues a warning message for the current pragma if operating in Ada
3852 -- 83 mode (used for language pragmas that are not a standard part of
3853 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3856 procedure Check_Arg_Count (Required : Nat);
3857 -- Check argument count for pragma is equal to given parameter. If not,
3858 -- then issue an error message and raise Pragma_Exit.
3860 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3861 -- Arg which can either be a pragma argument association, in which case
3862 -- the check is applied to the expression of the association or an
3863 -- expression directly.
3865 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3866 -- Check that an argument has the right form for an EXTERNAL_NAME
3867 -- parameter of an extended import/export pragma. The rule is that the
3868 -- name must be an identifier or string literal (in Ada 83 mode) or a
3869 -- static string expression (in Ada 95 mode).
3871 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3872 -- Check the specified argument Arg to make sure that it is an
3873 -- identifier. If not give error and raise Pragma_Exit.
3875 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3876 -- Check the specified argument Arg to make sure that it is an integer
3877 -- literal. If not give error and raise Pragma_Exit.
3879 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3880 -- Check the specified argument Arg to make sure that it has the proper
3881 -- syntactic form for a local name and meets the semantic requirements
3882 -- for a local name. The local name is analyzed as part of the
3883 -- processing for this call. In addition, the local name is required
3884 -- to represent an entity at the library level.
3886 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3887 -- Check the specified argument Arg to make sure that it has the proper
3888 -- syntactic form for a local name and meets the semantic requirements
3889 -- for a local name. The local name is analyzed as part of the
3890 -- processing for this call.
3892 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3893 -- Check the specified argument Arg to make sure that it is a valid
3894 -- locking policy name. If not give error and raise Pragma_Exit.
3896 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3897 -- Check the specified argument Arg to make sure that it is a valid
3898 -- elaboration policy name. If not give error and raise Pragma_Exit.
3900 procedure Check_Arg_Is_One_Of
3903 procedure Check_Arg_Is_One_Of
3905 N1, N2, N3 : Name_Id);
3906 procedure Check_Arg_Is_One_Of
3908 N1, N2, N3, N4 : Name_Id);
3909 procedure Check_Arg_Is_One_Of
3911 N1, N2, N3, N4, N5 : Name_Id);
3912 -- Check the specified argument Arg to make sure that it is an
3913 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3914 -- present). If not then give error and raise Pragma_Exit.
3916 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3917 -- Check the specified argument Arg to make sure that it is a valid
3918 -- queuing policy name. If not give error and raise Pragma_Exit.
3920 procedure Check_Arg_Is_OK_Static_Expression
3922 Typ : Entity_Id := Empty);
3923 -- Check the specified argument Arg to make sure that it is a static
3924 -- expression of the given type (i.e. it will be analyzed and resolved
3925 -- using this type, which can be any valid argument to Resolve, e.g.
3926 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3927 -- Typ is left Empty, then any static expression is allowed. Includes
3928 -- checking that the argument does not raise Constraint_Error.
3930 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3931 -- Check the specified argument Arg to make sure that it is a valid task
3932 -- dispatching policy name. If not give error and raise Pragma_Exit.
3934 procedure Check_Arg_Order (Names : Name_List);
3935 -- Checks for an instance of two arguments with identifiers for the
3936 -- current pragma which are not in the sequence indicated by Names,
3937 -- and if so, generates a fatal message about bad order of arguments.
3939 procedure Check_At_Least_N_Arguments (N : Nat);
3940 -- Check there are at least N arguments present
3942 procedure Check_At_Most_N_Arguments (N : Nat);
3943 -- Check there are no more than N arguments present
3945 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean);
3946 -- Apply legality checks to type or object E subject to an Atomic aspect
3947 -- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect.
3949 procedure Check_Component
3952 In_Variant_Part : Boolean := False);
3953 -- Examine an Unchecked_Union component for correct use of per-object
3954 -- constrained subtypes, and for restrictions on finalizable components.
3955 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3956 -- should be set when Comp comes from a record variant.
3958 procedure Check_Duplicate_Pragma (E : Entity_Id);
3959 -- Check if a rep item of the same name as the current pragma is already
3960 -- chained as a rep pragma to the given entity. If so give a message
3961 -- about the duplicate, and then raise Pragma_Exit so does not return.
3962 -- Note that if E is a type, then this routine avoids flagging a pragma
3963 -- which applies to a parent type from which E is derived.
3965 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3966 -- Nam is an N_String_Literal node containing the external name set by
3967 -- an Import or Export pragma (or extended Import or Export pragma).
3968 -- This procedure checks for possible duplications if this is the export
3969 -- case, and if found, issues an appropriate error message.
3971 procedure Check_Expr_Is_OK_Static_Expression
3973 Typ : Entity_Id := Empty);
3974 -- Check the specified expression Expr to make sure that it is a static
3975 -- expression of the given type (i.e. it will be analyzed and resolved
3976 -- using this type, which can be any valid argument to Resolve, e.g.
3977 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3978 -- Typ is left Empty, then any static expression is allowed. Includes
3979 -- checking that the expression does not raise Constraint_Error.
3981 procedure Check_First_Subtype (Arg : Node_Id);
3982 -- Checks that Arg, whose expression is an entity name, references a
3985 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3986 -- Checks that the given argument has an identifier, and if so, requires
3987 -- it to match the given identifier name. If there is no identifier, or
3988 -- a non-matching identifier, then an error message is given and
3989 -- Pragma_Exit is raised.
3991 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3992 -- Checks that the given argument has an identifier, and if so, requires
3993 -- it to match one of the given identifier names. If there is no
3994 -- identifier, or a non-matching identifier, then an error message is
3995 -- given and Pragma_Exit is raised.
3997 procedure Check_In_Main_Program;
3998 -- Common checks for pragmas that appear within a main program
3999 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4001 procedure Check_Interrupt_Or_Attach_Handler;
4002 -- Common processing for first argument of pragma Interrupt_Handler or
4003 -- pragma Attach_Handler.
4005 procedure Check_Loop_Pragma_Placement;
4006 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4007 -- appear immediately within a construct restricted to loops, and that
4008 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4010 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
4011 -- Check that pragma appears in a declarative part, or in a package
4012 -- specification, i.e. that it does not occur in a statement sequence
4015 procedure Check_No_Identifier (Arg : Node_Id);
4016 -- Checks that the given argument does not have an identifier. If
4017 -- an identifier is present, then an error message is issued, and
4018 -- Pragma_Exit is raised.
4020 procedure Check_No_Identifiers;
4021 -- Checks that none of the arguments to the pragma has an identifier.
4022 -- If any argument has an identifier, then an error message is issued,
4023 -- and Pragma_Exit is raised.
4025 procedure Check_No_Link_Name;
4026 -- Checks that no link name is specified
4028 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4029 -- Checks if the given argument has an identifier, and if so, requires
4030 -- it to match the given identifier name. If there is a non-matching
4031 -- identifier, then an error message is given and Pragma_Exit is raised.
4033 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4034 -- Checks if the given argument has an identifier, and if so, requires
4035 -- it to match the given identifier name. If there is a non-matching
4036 -- identifier, then an error message is given and Pragma_Exit is raised.
4037 -- In this version of the procedure, the identifier name is given as
4038 -- a string with lower case letters.
4040 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4041 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4042 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4043 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4044 -- is an OK static boolean expression. Emit an error if this is not the
4047 procedure Check_Static_Constraint (Constr : Node_Id);
4048 -- Constr is a constraint from an N_Subtype_Indication node from a
4049 -- component constraint in an Unchecked_Union type. This routine checks
4050 -- that the constraint is static as required by the restrictions for
4053 procedure Check_Valid_Configuration_Pragma;
4054 -- Legality checks for placement of a configuration pragma
4056 procedure Check_Valid_Library_Unit_Pragma;
4057 -- Legality checks for library unit pragmas. A special case arises for
4058 -- pragmas in generic instances that come from copies of the original
4059 -- library unit pragmas in the generic templates. In the case of other
4060 -- than library level instantiations these can appear in contexts which
4061 -- would normally be invalid (they only apply to the original template
4062 -- and to library level instantiations), and they are simply ignored,
4063 -- which is implemented by rewriting them as null statements.
4065 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4066 -- Check an Unchecked_Union variant for lack of nested variants and
4067 -- presence of at least one component. UU_Typ is the related Unchecked_
4070 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4071 -- Subsidiary routine to the processing of pragmas Abstract_State,
4072 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4073 -- Refined_Global, Refined_State and Subprogram_Variant. Transform
4074 -- argument Arg into an aggregate if not one already. N_Null is never
4075 -- transformed. Arg may denote an aspect specification or a pragma
4076 -- argument association.
4078 procedure Error_Pragma (Msg : String);
4079 pragma No_Return (Error_Pragma);
4080 -- Outputs error message for current pragma. The message contains a %
4081 -- that will be replaced with the pragma name, and the flag is placed
4082 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4083 -- calls Fix_Error (see spec of that procedure for details).
4085 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4086 pragma No_Return (Error_Pragma_Arg);
4087 -- Outputs error message for current pragma. The message may contain
4088 -- a % that will be replaced with the pragma name. The parameter Arg
4089 -- may either be a pragma argument association, in which case the flag
4090 -- is placed on the expression of this association, or an expression,
4091 -- in which case the flag is placed directly on the expression. The
4092 -- message is placed using Error_Msg_N, so the message may also contain
4093 -- an & insertion character which will reference the given Arg value.
4094 -- After placing the message, Pragma_Exit is raised. Note: this routine
4095 -- calls Fix_Error (see spec of that procedure for details).
4097 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4098 pragma No_Return (Error_Pragma_Arg);
4099 -- Similar to above form of Error_Pragma_Arg except that two messages
4100 -- are provided, the second is a continuation comment starting with \.
4102 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4103 pragma No_Return (Error_Pragma_Arg_Ident);
4104 -- Outputs error message for current pragma. The message may contain a %
4105 -- that will be replaced with the pragma name. The parameter Arg must be
4106 -- a pragma argument association with a non-empty identifier (i.e. its
4107 -- Chars field must be set), and the error message is placed on the
4108 -- identifier. The message is placed using Error_Msg_N so the message
4109 -- may also contain an & insertion character which will reference
4110 -- the identifier. After placing the message, Pragma_Exit is raised.
4111 -- Note: this routine calls Fix_Error (see spec of that procedure for
4114 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4115 pragma No_Return (Error_Pragma_Ref);
4116 -- Outputs error message for current pragma. The message may contain
4117 -- a % that will be replaced with the pragma name. The parameter Ref
4118 -- must be an entity whose name can be referenced by & and sloc by #.
4119 -- After placing the message, Pragma_Exit is raised. Note: this routine
4120 -- calls Fix_Error (see spec of that procedure for details).
4122 function Find_Lib_Unit_Name return Entity_Id;
4123 -- Used for a library unit pragma to find the entity to which the
4124 -- library unit pragma applies, returns the entity found.
4126 procedure Find_Program_Unit_Name (Id : Node_Id);
4127 -- If the pragma is a compilation unit pragma, the id must denote the
4128 -- compilation unit in the same compilation, and the pragma must appear
4129 -- in the list of preceding or trailing pragmas. If it is a program
4130 -- unit pragma that is not a compilation unit pragma, then the
4131 -- identifier must be visible.
4133 function Find_Unique_Parameterless_Procedure
4135 Arg : Node_Id) return Entity_Id;
4136 -- Used for a procedure pragma to find the unique parameterless
4137 -- procedure identified by Name, returns it if it exists, otherwise
4138 -- errors out and uses Arg as the pragma argument for the message.
4140 function Fix_Error (Msg : String) return String;
4141 -- This is called prior to issuing an error message. Msg is the normal
4142 -- error message issued in the pragma case. This routine checks for the
4143 -- case of a pragma coming from an aspect in the source, and returns a
4144 -- message suitable for the aspect case as follows:
4146 -- Each substring "pragma" is replaced by "aspect"
4148 -- If "argument of" is at the start of the error message text, it is
4149 -- replaced by "entity for".
4151 -- If "argument" is at the start of the error message text, it is
4152 -- replaced by "entity".
4154 -- So for example, "argument of pragma X must be discrete type"
4155 -- returns "entity for aspect X must be a discrete type".
4157 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4158 -- be different from the pragma name). If the current pragma results
4159 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4160 -- original pragma name.
4162 procedure Gather_Associations
4164 Args : out Args_List);
4165 -- This procedure is used to gather the arguments for a pragma that
4166 -- permits arbitrary ordering of parameters using the normal rules
4167 -- for named and positional parameters. The Names argument is a list
4168 -- of Name_Id values that corresponds to the allowed pragma argument
4169 -- association identifiers in order. The result returned in Args is
4170 -- a list of corresponding expressions that are the pragma arguments.
4171 -- Note that this is a list of expressions, not of pragma argument
4172 -- associations (Gather_Associations has completely checked all the
4173 -- optional identifiers when it returns). An entry in Args is Empty
4174 -- on return if the corresponding argument is not present.
4176 procedure GNAT_Pragma;
4177 -- Called for all GNAT defined pragmas to check the relevant restriction
4178 -- (No_Implementation_Pragmas).
4180 function Is_Before_First_Decl
4181 (Pragma_Node : Node_Id;
4182 Decls : List_Id) return Boolean;
4183 -- Return True if Pragma_Node is before the first declarative item in
4184 -- Decls where Decls is the list of declarative items.
4186 function Is_Configuration_Pragma return Boolean;
4187 -- Determines if the placement of the current pragma is appropriate
4188 -- for a configuration pragma.
4190 function Is_In_Context_Clause return Boolean;
4191 -- Returns True if pragma appears within the context clause of a unit,
4192 -- and False for any other placement (does not generate any messages).
4194 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4195 -- Analyzes the argument, and determines if it is a static string
4196 -- expression, returns True if so, False if non-static or not String.
4197 -- A special case is that a string literal returns True in Ada 83 mode
4198 -- (which has no such thing as static string expressions). Note that
4199 -- the call analyzes its argument, so this cannot be used for the case
4200 -- where an identifier might not be declared.
4202 procedure Pragma_Misplaced;
4203 pragma No_Return (Pragma_Misplaced);
4204 -- Issue fatal error message for misplaced pragma
4206 procedure Process_Atomic_Independent_Shared_Volatile;
4207 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4208 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4209 -- and treated as being identical in effect to pragma Atomic.
4211 procedure Process_Compile_Time_Warning_Or_Error;
4212 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4214 procedure Process_Convention
4215 (C : out Convention_Id;
4216 Ent : out Entity_Id);
4217 -- Common processing for Convention, Interface, Import and Export.
4218 -- Checks first two arguments of pragma, and sets the appropriate
4219 -- convention value in the specified entity or entities. On return
4220 -- C is the convention, Ent is the referenced entity.
4222 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4223 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4224 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4226 procedure Process_Extended_Import_Export_Object_Pragma
4227 (Arg_Internal : Node_Id;
4228 Arg_External : Node_Id;
4229 Arg_Size : Node_Id);
4230 -- Common processing for the pragmas Import/Export_Object. The three
4231 -- arguments correspond to the three named parameters of the pragmas. An
4232 -- argument is empty if the corresponding parameter is not present in
4235 procedure Process_Extended_Import_Export_Internal_Arg
4236 (Arg_Internal : Node_Id := Empty);
4237 -- Common processing for all extended Import and Export pragmas. The
4238 -- argument is the pragma parameter for the Internal argument. If
4239 -- Arg_Internal is empty or inappropriate, an error message is posted.
4240 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4241 -- set to identify the referenced entity.
4243 procedure Process_Extended_Import_Export_Subprogram_Pragma
4244 (Arg_Internal : Node_Id;
4245 Arg_External : Node_Id;
4246 Arg_Parameter_Types : Node_Id;
4247 Arg_Result_Type : Node_Id := Empty;
4248 Arg_Mechanism : Node_Id;
4249 Arg_Result_Mechanism : Node_Id := Empty);
4250 -- Common processing for all extended Import and Export pragmas applying
4251 -- to subprograms. The caller omits any arguments that do not apply to
4252 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4253 -- only in the Import_Function and Export_Function cases). The argument
4254 -- names correspond to the allowed pragma association identifiers.
4256 procedure Process_Generic_List;
4257 -- Common processing for Share_Generic and Inline_Generic
4259 procedure Process_Import_Or_Interface;
4260 -- Common processing for Import or Interface
4262 procedure Process_Import_Predefined_Type;
4263 -- Processing for completing a type with pragma Import. This is used
4264 -- to declare types that match predefined C types, especially for cases
4265 -- without corresponding Ada predefined type.
4267 type Inline_Status is (Suppressed, Disabled, Enabled);
4268 -- Inline status of a subprogram, indicated as follows:
4269 -- Suppressed: inlining is suppressed for the subprogram
4270 -- Disabled: no inlining is requested for the subprogram
4271 -- Enabled: inlining is requested/required for the subprogram
4273 procedure Process_Inline (Status : Inline_Status);
4274 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4275 -- indicates the inline status specified by the pragma.
4277 procedure Process_Interface_Name
4278 (Subprogram_Def : Entity_Id;
4282 -- Given the last two arguments of pragma Import, pragma Export, or
4283 -- pragma Interface_Name, performs validity checks and sets the
4284 -- Interface_Name field of the given subprogram entity to the
4285 -- appropriate external or link name, depending on the arguments given.
4286 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4287 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4288 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4289 -- nor Link_Arg is present, the interface name is set to the default
4290 -- from the subprogram name. In addition, the pragma itself is passed
4291 -- to analyze any expressions in the case the pragma came from an aspect
4294 procedure Process_Interrupt_Or_Attach_Handler;
4295 -- Common processing for Interrupt and Attach_Handler pragmas
4297 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4298 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4299 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4300 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4301 -- is not set in the Restrictions case.
4303 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4304 -- Common processing for Suppress and Unsuppress. The boolean parameter
4305 -- Suppress_Case is True for the Suppress case, and False for the
4308 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4309 -- Subsidiary to the analysis of pragmas Independent[_Components].
4310 -- Record such a pragma N applied to entity E for future checks.
4312 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4313 -- This procedure sets the Is_Exported flag for the given entity,
4314 -- checking that the entity was not previously imported. Arg is
4315 -- the argument that specified the entity. A check is also made
4316 -- for exporting inappropriate entities.
4318 procedure Set_Extended_Import_Export_External_Name
4319 (Internal_Ent : Entity_Id;
4320 Arg_External : Node_Id);
4321 -- Common processing for all extended import export pragmas. The first
4322 -- argument, Internal_Ent, is the internal entity, which has already
4323 -- been checked for validity by the caller. Arg_External is from the
4324 -- Import or Export pragma, and may be null if no External parameter
4325 -- was present. If Arg_External is present and is a non-null string
4326 -- (a null string is treated as the default), then the Interface_Name
4327 -- field of Internal_Ent is set appropriately.
4329 procedure Set_Imported (E : Entity_Id);
4330 -- This procedure sets the Is_Imported flag for the given entity,
4331 -- checking that it is not previously exported or imported.
4333 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4334 -- Mech is a parameter passing mechanism (see Import_Function syntax
4335 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4336 -- has the right form, and if not issues an error message. If the
4337 -- argument has the right form then the Mechanism field of Ent is
4338 -- set appropriately.
4340 procedure Set_Rational_Profile;
4341 -- Activate the set of configuration pragmas and permissions that make
4342 -- up the Rational profile.
4344 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4345 -- Activate the set of configuration pragmas and restrictions that make
4346 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4347 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4348 -- pragma node, which is used for error messages on any constructs
4349 -- violating the profile.
4351 ---------------------
4352 -- Ada_2005_Pragma --
4353 ---------------------
4355 procedure Ada_2005_Pragma is
4357 if Ada_Version <= Ada_95 then
4358 Check_Restriction (No_Implementation_Pragmas, N);
4360 end Ada_2005_Pragma;
4362 ---------------------
4363 -- Ada_2012_Pragma --
4364 ---------------------
4366 procedure Ada_2012_Pragma is
4368 if Ada_Version <= Ada_2005 then
4369 Check_Restriction (No_Implementation_Pragmas, N);
4371 end Ada_2012_Pragma;
4373 ----------------------------
4374 -- Analyze_Depends_Global --
4375 ----------------------------
4377 procedure Analyze_Depends_Global
4378 (Spec_Id : out Entity_Id;
4379 Subp_Decl : out Node_Id;
4380 Legal : out Boolean)
4383 -- Assume that the pragma is illegal
4390 Check_Arg_Count (1);
4392 -- Ensure the proper placement of the pragma. Depends/Global must be
4393 -- associated with a subprogram declaration or a body that acts as a
4396 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4400 if Nkind (Subp_Decl) = N_Entry_Declaration then
4403 -- Generic subprogram
4405 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4408 -- Object declaration of a single concurrent type
4410 elsif Nkind (Subp_Decl) = N_Object_Declaration
4411 and then Is_Single_Concurrent_Object
4412 (Unique_Defining_Entity (Subp_Decl))
4418 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4421 -- Subprogram body acts as spec
4423 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4424 and then No (Corresponding_Spec (Subp_Decl))
4428 -- Subprogram body stub acts as spec
4430 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4431 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4435 -- Subprogram declaration
4437 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4442 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4450 -- If we get here, then the pragma is legal
4453 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4455 -- When the related context is an entry, the entry must belong to a
4456 -- protected unit (SPARK RM 6.1.4(6)).
4458 if Is_Entry_Declaration (Spec_Id)
4459 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4464 -- When the related context is an anonymous object created for a
4465 -- simple concurrent type, the type must be a task
4466 -- (SPARK RM 6.1.4(6)).
4468 elsif Is_Single_Concurrent_Object (Spec_Id)
4469 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4475 -- A pragma that applies to a Ghost entity becomes Ghost for the
4476 -- purposes of legality checks and removal of ignored Ghost code.
4478 Mark_Ghost_Pragma (N, Spec_Id);
4479 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4480 end Analyze_Depends_Global;
4482 ------------------------
4483 -- Analyze_If_Present --
4484 ------------------------
4486 procedure Analyze_If_Present (Id : Pragma_Id) is
4490 pragma Assert (Is_List_Member (N));
4492 -- Inspect the declarations or statements following pragma N looking
4493 -- for another pragma whose Id matches the caller's request. If it is
4494 -- available, analyze it.
4497 while Present (Stmt) loop
4498 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4499 Analyze_Pragma (Stmt);
4502 -- The first source declaration or statement immediately following
4503 -- N ends the region where a pragma may appear.
4505 elsif Comes_From_Source (Stmt) then
4511 end Analyze_If_Present;
4513 --------------------------------
4514 -- Analyze_Pre_Post_Condition --
4515 --------------------------------
4517 procedure Analyze_Pre_Post_Condition is
4518 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4519 Subp_Decl : Node_Id;
4520 Subp_Id : Entity_Id;
4522 Duplicates_OK : Boolean := False;
4523 -- Flag set when a pre/postcondition allows multiple pragmas of the
4526 In_Body_OK : Boolean := False;
4527 -- Flag set when a pre/postcondition is allowed to appear on a body
4528 -- even though the subprogram may have a spec.
4530 Is_Pre_Post : Boolean := False;
4531 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4534 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4535 -- Implement rules in AI12-0131: an overriding operation can have
4536 -- a class-wide precondition only if one of its ancestors has an
4537 -- explicit class-wide precondition.
4539 -----------------------------
4540 -- Inherits_Class_Wide_Pre --
4541 -----------------------------
4543 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4544 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4547 Prev : Entity_Id := Overridden_Operation (E);
4550 -- Check ancestors on the overriding operation to examine the
4551 -- preconditions that may apply to them.
4553 while Present (Prev) loop
4554 Cont := Contract (Prev);
4555 if Present (Cont) then
4556 Prag := Pre_Post_Conditions (Cont);
4557 while Present (Prag) loop
4558 if Pragma_Name (Prag) = Name_Precondition
4559 and then Class_Present (Prag)
4564 Prag := Next_Pragma (Prag);
4568 -- For a type derived from a generic formal type, the operation
4569 -- inheriting the condition is a renaming, not an overriding of
4570 -- the operation of the formal. Ditto for an inherited
4571 -- operation which has no explicit contracts.
4573 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4574 or else not Comes_From_Source (Prev)
4576 Prev := Alias (Prev);
4578 Prev := Overridden_Operation (Prev);
4582 -- If the controlling type of the subprogram has progenitors, an
4583 -- interface operation implemented by the current operation may
4584 -- have a class-wide precondition.
4586 if Has_Interfaces (Typ) then
4591 Prim_Elmt : Elmt_Id;
4592 Prim_List : Elist_Id;
4595 Collect_Interfaces (Typ, Ints);
4596 Elmt := First_Elmt (Ints);
4598 -- Iterate over the primitive operations of each interface
4600 while Present (Elmt) loop
4601 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4602 Prim_Elmt := First_Elmt (Prim_List);
4603 while Present (Prim_Elmt) loop
4604 Prim := Node (Prim_Elmt);
4605 if Chars (Prim) = Chars (E)
4606 and then Present (Contract (Prim))
4607 and then Class_Present
4608 (Pre_Post_Conditions (Contract (Prim)))
4613 Next_Elmt (Prim_Elmt);
4622 end Inherits_Class_Wide_Pre;
4624 -- Start of processing for Analyze_Pre_Post_Condition
4627 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4628 -- offer uniformity among the various kinds of pre/postconditions by
4629 -- rewriting the pragma identifier. This allows the retrieval of the
4630 -- original pragma name by routine Original_Aspect_Pragma_Name.
4632 if Comes_From_Source (N) then
4633 if Pname in Name_Pre | Name_Pre_Class then
4634 Is_Pre_Post := True;
4635 Set_Class_Present (N, Pname = Name_Pre_Class);
4636 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4638 elsif Pname in Name_Post | Name_Post_Class then
4639 Is_Pre_Post := True;
4640 Set_Class_Present (N, Pname = Name_Post_Class);
4641 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4645 -- Determine the semantics with respect to duplicates and placement
4646 -- in a body. Pragmas Precondition and Postcondition were introduced
4647 -- before aspects and are not subject to the same aspect-like rules.
4649 if Pname in Name_Precondition | Name_Postcondition then
4650 Duplicates_OK := True;
4656 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4657 -- argument without an identifier.
4660 Check_Arg_Count (1);
4661 Check_No_Identifiers;
4663 -- Pragmas Precondition and Postcondition have complex argument
4667 Check_At_Least_N_Arguments (1);
4668 Check_At_Most_N_Arguments (2);
4669 Check_Optional_Identifier (Arg1, Name_Check);
4671 if Present (Arg2) then
4672 Check_Optional_Identifier (Arg2, Name_Message);
4673 Preanalyze_Spec_Expression
4674 (Get_Pragma_Arg (Arg2), Standard_String);
4678 -- For a pragma PPC in the extended main source unit, record enabled
4680 -- ??? nothing checks that the pragma is in the main source unit
4682 if Is_Checked (N) and then not Split_PPC (N) then
4683 Set_SCO_Pragma_Enabled (Loc);
4686 -- Ensure the proper placement of the pragma
4689 Find_Related_Declaration_Or_Body
4690 (N, Do_Checks => not Duplicates_OK);
4692 -- When a pre/postcondition pragma applies to an abstract subprogram,
4693 -- its original form must be an aspect with 'Class.
4695 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4696 if not From_Aspect_Specification (N) then
4698 ("pragma % cannot be applied to abstract subprogram");
4700 elsif not Class_Present (N) then
4702 ("aspect % requires ''Class for abstract subprogram");
4705 -- Entry declaration
4707 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4710 -- Generic subprogram declaration
4712 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4717 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4718 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4722 -- Subprogram body stub
4724 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4725 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4729 -- Subprogram declaration
4731 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4733 -- AI05-0230: When a pre/postcondition pragma applies to a null
4734 -- procedure, its original form must be an aspect with 'Class.
4736 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4737 and then Null_Present (Specification (Subp_Decl))
4738 and then From_Aspect_Specification (N)
4739 and then not Class_Present (N)
4741 Error_Pragma ("aspect % requires ''Class for null procedure");
4744 -- Implement the legality checks mandated by AI12-0131:
4745 -- Pre'Class shall not be specified for an overriding primitive
4746 -- subprogram of a tagged type T unless the Pre'Class aspect is
4747 -- specified for the corresponding primitive subprogram of some
4751 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4754 if Class_Present (N)
4755 and then Pragma_Name (N) = Name_Precondition
4756 and then Present (Overridden_Operation (E))
4757 and then not Inherits_Class_Wide_Pre (E)
4760 ("illegal class-wide precondition on overriding operation",
4761 Corresponding_Aspect (N));
4765 -- A renaming declaration may inherit a generated pragma, its
4766 -- placement comes from expansion, not from source.
4768 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4769 and then not Comes_From_Source (N)
4773 -- For Ada 2020, pre/postconditions can appear on formal subprograms
4775 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
4776 and then Ada_Version >= Ada_2020
4780 -- An access-to-subprogram type can have pre/postconditions, but
4781 -- these are transferred to the generated subprogram wrapper and
4784 -- Otherwise the placement of the pragma is illegal
4791 Subp_Id := Defining_Entity (Subp_Decl);
4793 -- A pragma that applies to a Ghost entity becomes Ghost for the
4794 -- purposes of legality checks and removal of ignored Ghost code.
4796 Mark_Ghost_Pragma (N, Subp_Id);
4798 -- Chain the pragma on the contract for further processing by
4799 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4801 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4803 -- Fully analyze the pragma when it appears inside an entry or
4804 -- subprogram body because it cannot benefit from forward references.
4806 if Nkind (Subp_Decl) in N_Entry_Body
4808 | N_Subprogram_Body_Stub
4810 -- The legality checks of pragmas Precondition and Postcondition
4811 -- are affected by the SPARK mode in effect and the volatility of
4812 -- the context. Analyze all pragmas in a specific order.
4814 Analyze_If_Present (Pragma_SPARK_Mode);
4815 Analyze_If_Present (Pragma_Volatile_Function);
4816 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4818 end Analyze_Pre_Post_Condition;
4820 -----------------------------------------
4821 -- Analyze_Refined_Depends_Global_Post --
4822 -----------------------------------------
4824 procedure Analyze_Refined_Depends_Global_Post
4825 (Spec_Id : out Entity_Id;
4826 Body_Id : out Entity_Id;
4827 Legal : out Boolean)
4829 Body_Decl : Node_Id;
4830 Spec_Decl : Node_Id;
4833 -- Assume that the pragma is illegal
4840 Check_Arg_Count (1);
4841 Check_No_Identifiers;
4843 -- Verify the placement of the pragma and check for duplicates. The
4844 -- pragma must apply to a subprogram body [stub].
4846 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4848 if Nkind (Body_Decl) not in
4849 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
4850 N_Task_Body | N_Task_Body_Stub
4856 Body_Id := Defining_Entity (Body_Decl);
4857 Spec_Id := Unique_Defining_Entity (Body_Decl);
4859 -- The pragma must apply to the second declaration of a subprogram.
4860 -- In other words, the body [stub] cannot acts as a spec.
4862 if No (Spec_Id) then
4863 Error_Pragma ("pragma % cannot apply to a stand alone body");
4866 -- Catch the case where the subprogram body is a subunit and acts as
4867 -- the third declaration of the subprogram.
4869 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4870 Error_Pragma ("pragma % cannot apply to a subunit");
4874 -- A refined pragma can only apply to the body [stub] of a subprogram
4875 -- declared in the visible part of a package. Retrieve the context of
4876 -- the subprogram declaration.
4878 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4880 -- When dealing with protected entries or protected subprograms, use
4881 -- the enclosing protected type as the proper context.
4883 if Ekind (Spec_Id) in E_Entry
4887 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4889 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4892 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4894 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4895 & "subprogram declared in a package specification"));
4899 -- If we get here, then the pragma is legal
4903 -- A pragma that applies to a Ghost entity becomes Ghost for the
4904 -- purposes of legality checks and removal of ignored Ghost code.
4906 Mark_Ghost_Pragma (N, Spec_Id);
4908 if Pname in Name_Refined_Depends | Name_Refined_Global then
4909 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4911 end Analyze_Refined_Depends_Global_Post;
4913 ----------------------------------
4914 -- Analyze_Unmodified_Or_Unused --
4915 ----------------------------------
4917 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4922 Ghost_Error_Posted : Boolean := False;
4923 -- Flag set when an error concerning the illegal mix of Ghost and
4924 -- non-Ghost variables is emitted.
4926 Ghost_Id : Entity_Id := Empty;
4927 -- The entity of the first Ghost variable encountered while
4928 -- processing the arguments of the pragma.
4932 Check_At_Least_N_Arguments (1);
4934 -- Loop through arguments
4937 while Present (Arg) loop
4938 Check_No_Identifier (Arg);
4940 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4941 -- in fact generate reference, so that the entity will have a
4942 -- reference, which will inhibit any warnings about it not
4943 -- being referenced, and also properly show up in the ali file
4944 -- as a reference. But this reference is recorded before the
4945 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4946 -- generated for this reference.
4948 Check_Arg_Is_Local_Name (Arg);
4949 Arg_Expr := Get_Pragma_Arg (Arg);
4951 if Is_Entity_Name (Arg_Expr) then
4952 Arg_Id := Entity (Arg_Expr);
4954 -- Skip processing the argument if already flagged
4956 if Is_Assignable (Arg_Id)
4957 and then not Has_Pragma_Unmodified (Arg_Id)
4958 and then not Has_Pragma_Unused (Arg_Id)
4960 Set_Has_Pragma_Unmodified (Arg_Id);
4963 Set_Has_Pragma_Unused (Arg_Id);
4966 -- A pragma that applies to a Ghost entity becomes Ghost for
4967 -- the purposes of legality checks and removal of ignored
4970 Mark_Ghost_Pragma (N, Arg_Id);
4972 -- Capture the entity of the first Ghost variable being
4973 -- processed for error detection purposes.
4975 if Is_Ghost_Entity (Arg_Id) then
4976 if No (Ghost_Id) then
4980 -- Otherwise the variable is non-Ghost. It is illegal to mix
4981 -- references to Ghost and non-Ghost entities
4984 elsif Present (Ghost_Id)
4985 and then not Ghost_Error_Posted
4987 Ghost_Error_Posted := True;
4989 Error_Msg_Name_1 := Pname;
4991 ("pragma % cannot mention ghost and non-ghost "
4994 Error_Msg_Sloc := Sloc (Ghost_Id);
4995 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4997 Error_Msg_Sloc := Sloc (Arg_Id);
4998 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5001 -- Warn if already flagged as Unused or Unmodified
5003 elsif Has_Pragma_Unmodified (Arg_Id) then
5004 if Has_Pragma_Unused (Arg_Id) then
5006 ("??pragma Unused already given for &!", Arg_Expr,
5010 ("??pragma Unmodified already given for &!", Arg_Expr,
5014 -- Otherwise the pragma referenced an illegal entity
5018 ("pragma% can only be applied to a variable", Arg_Expr);
5024 end Analyze_Unmodified_Or_Unused;
5026 ------------------------------------
5027 -- Analyze_Unreferenced_Or_Unused --
5028 ------------------------------------
5030 procedure Analyze_Unreferenced_Or_Unused
5031 (Is_Unused : Boolean := False)
5038 Ghost_Error_Posted : Boolean := False;
5039 -- Flag set when an error concerning the illegal mix of Ghost and
5040 -- non-Ghost names is emitted.
5042 Ghost_Id : Entity_Id := Empty;
5043 -- The entity of the first Ghost name encountered while processing
5044 -- the arguments of the pragma.
5048 Check_At_Least_N_Arguments (1);
5050 -- Check case of appearing within context clause
5052 if not Is_Unused and then Is_In_Context_Clause then
5054 -- The arguments must all be units mentioned in a with clause in
5055 -- the same context clause. Note that Par.Prag already checked
5056 -- that the arguments are either identifiers or selected
5060 while Present (Arg) loop
5061 Citem := First (List_Containing (N));
5062 while Citem /= N loop
5063 Arg_Expr := Get_Pragma_Arg (Arg);
5065 if Nkind (Citem) = N_With_Clause
5066 and then Same_Name (Name (Citem), Arg_Expr)
5068 Set_Has_Pragma_Unreferenced
5071 (Library_Unit (Citem))));
5072 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5081 ("argument of pragma% is not withed unit", Arg);
5087 -- Case of not in list of context items
5091 while Present (Arg) loop
5092 Check_No_Identifier (Arg);
5094 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5095 -- in fact generate reference, so that the entity will have a
5096 -- reference, which will inhibit any warnings about it not
5097 -- being referenced, and also properly show up in the ali file
5098 -- as a reference. But this reference is recorded before the
5099 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5100 -- generated for this reference.
5102 Check_Arg_Is_Local_Name (Arg);
5103 Arg_Expr := Get_Pragma_Arg (Arg);
5105 if Is_Entity_Name (Arg_Expr) then
5106 Arg_Id := Entity (Arg_Expr);
5108 -- Warn if already flagged as Unused or Unreferenced and
5109 -- skip processing the argument.
5111 if Has_Pragma_Unreferenced (Arg_Id) then
5112 if Has_Pragma_Unused (Arg_Id) then
5114 ("??pragma Unused already given for &!", Arg_Expr,
5118 ("??pragma Unreferenced already given for &!",
5122 -- Apply Unreferenced to the entity
5125 -- If the entity is overloaded, the pragma applies to the
5126 -- most recent overloading, as documented. In this case,
5127 -- name resolution does not generate a reference, so it
5128 -- must be done here explicitly.
5130 if Is_Overloaded (Arg_Expr) then
5131 Generate_Reference (Arg_Id, N);
5134 Set_Has_Pragma_Unreferenced (Arg_Id);
5137 Set_Has_Pragma_Unused (Arg_Id);
5140 -- A pragma that applies to a Ghost entity becomes Ghost
5141 -- for the purposes of legality checks and removal of
5142 -- ignored Ghost code.
5144 Mark_Ghost_Pragma (N, Arg_Id);
5146 -- Capture the entity of the first Ghost name being
5147 -- processed for error detection purposes.
5149 if Is_Ghost_Entity (Arg_Id) then
5150 if No (Ghost_Id) then
5154 -- Otherwise the name is non-Ghost. It is illegal to mix
5155 -- references to Ghost and non-Ghost entities
5158 elsif Present (Ghost_Id)
5159 and then not Ghost_Error_Posted
5161 Ghost_Error_Posted := True;
5163 Error_Msg_Name_1 := Pname;
5165 ("pragma % cannot mention ghost and non-ghost "
5168 Error_Msg_Sloc := Sloc (Ghost_Id);
5170 ("\& # declared as ghost", N, Ghost_Id);
5172 Error_Msg_Sloc := Sloc (Arg_Id);
5174 ("\& # declared as non-ghost", N, Arg_Id);
5182 end Analyze_Unreferenced_Or_Unused;
5184 --------------------------
5185 -- Check_Ada_83_Warning --
5186 --------------------------
5188 procedure Check_Ada_83_Warning is
5190 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5191 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5193 end Check_Ada_83_Warning;
5195 ---------------------
5196 -- Check_Arg_Count --
5197 ---------------------
5199 procedure Check_Arg_Count (Required : Nat) is
5201 if Arg_Count /= Required then
5202 Error_Pragma ("wrong number of arguments for pragma%");
5204 end Check_Arg_Count;
5206 --------------------------------
5207 -- Check_Arg_Is_External_Name --
5208 --------------------------------
5210 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5211 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5214 if Nkind (Argx) = N_Identifier then
5218 Analyze_And_Resolve (Argx, Standard_String);
5220 if Is_OK_Static_Expression (Argx) then
5223 elsif Etype (Argx) = Any_Type then
5226 -- An interesting special case, if we have a string literal and
5227 -- we are in Ada 83 mode, then we allow it even though it will
5228 -- not be flagged as static. This allows expected Ada 83 mode
5229 -- use of external names which are string literals, even though
5230 -- technically these are not static in Ada 83.
5232 elsif Ada_Version = Ada_83
5233 and then Nkind (Argx) = N_String_Literal
5237 -- Here we have a real error (non-static expression)
5240 Error_Msg_Name_1 := Pname;
5241 Flag_Non_Static_Expr
5242 (Fix_Error ("argument for pragma% must be a identifier or "
5243 & "static string expression!"), Argx);
5248 end Check_Arg_Is_External_Name;
5250 -----------------------------
5251 -- Check_Arg_Is_Identifier --
5252 -----------------------------
5254 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5255 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5257 if Nkind (Argx) /= N_Identifier then
5258 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5260 end Check_Arg_Is_Identifier;
5262 ----------------------------------
5263 -- Check_Arg_Is_Integer_Literal --
5264 ----------------------------------
5266 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5267 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5269 if Nkind (Argx) /= N_Integer_Literal then
5271 ("argument for pragma% must be integer literal", Argx);
5273 end Check_Arg_Is_Integer_Literal;
5275 -------------------------------------------
5276 -- Check_Arg_Is_Library_Level_Local_Name --
5277 -------------------------------------------
5281 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5282 -- | library_unit_NAME
5284 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5286 Check_Arg_Is_Local_Name (Arg);
5288 -- If it came from an aspect, we want to give the error just as if it
5289 -- came from source.
5291 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5292 and then (Comes_From_Source (N)
5293 or else Present (Corresponding_Aspect (Parent (Arg))))
5296 ("argument for pragma% must be library level entity", Arg);
5298 end Check_Arg_Is_Library_Level_Local_Name;
5300 -----------------------------
5301 -- Check_Arg_Is_Local_Name --
5302 -----------------------------
5306 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5307 -- | library_unit_NAME
5309 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5310 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5313 -- If this pragma came from an aspect specification, we don't want to
5314 -- check for this error, because that would cause spurious errors, in
5315 -- case a type is frozen in a scope more nested than the type. The
5316 -- aspect itself of course can't be anywhere but on the declaration
5319 if Nkind (Arg) = N_Pragma_Argument_Association then
5320 if From_Aspect_Specification (Parent (Arg)) then
5324 -- Arg is the Expression of an N_Pragma_Argument_Association
5327 if From_Aspect_Specification (Parent (Parent (Arg))) then
5334 if Nkind (Argx) not in N_Direct_Name
5335 and then (Nkind (Argx) /= N_Attribute_Reference
5336 or else Present (Expressions (Argx))
5337 or else Nkind (Prefix (Argx)) /= N_Identifier)
5338 and then (not Is_Entity_Name (Argx)
5339 or else not Is_Compilation_Unit (Entity (Argx)))
5341 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5344 -- No further check required if not an entity name
5346 if not Is_Entity_Name (Argx) then
5352 Ent : constant Entity_Id := Entity (Argx);
5353 Scop : constant Entity_Id := Scope (Ent);
5356 -- Case of a pragma applied to a compilation unit: pragma must
5357 -- occur immediately after the program unit in the compilation.
5359 if Is_Compilation_Unit (Ent) then
5361 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5364 -- Case of pragma placed immediately after spec
5366 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5369 -- Case of pragma placed immediately after body
5371 elsif Nkind (Decl) = N_Subprogram_Declaration
5372 and then Present (Corresponding_Body (Decl))
5376 (Parent (Unit_Declaration_Node
5377 (Corresponding_Body (Decl))));
5379 -- All other cases are illegal
5386 -- Special restricted placement rule from 10.2.1(11.8/2)
5388 elsif Is_Generic_Formal (Ent)
5389 and then Prag_Id = Pragma_Preelaborable_Initialization
5391 OK := List_Containing (N) =
5392 Generic_Formal_Declarations
5393 (Unit_Declaration_Node (Scop));
5395 -- If this is an aspect applied to a subprogram body, the
5396 -- pragma is inserted in its declarative part.
5398 elsif From_Aspect_Specification (N)
5399 and then Ent = Current_Scope
5401 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5405 -- If the aspect is a predicate (possibly others ???) and the
5406 -- context is a record type, this is a discriminant expression
5407 -- within a type declaration, that freezes the predicated
5410 elsif From_Aspect_Specification (N)
5411 and then Prag_Id = Pragma_Predicate
5412 and then Ekind (Current_Scope) = E_Record_Type
5413 and then Scop = Scope (Current_Scope)
5417 -- Default case, just check that the pragma occurs in the scope
5418 -- of the entity denoted by the name.
5421 OK := Current_Scope = Scop;
5426 ("pragma% argument must be in same declarative part", Arg);
5430 end Check_Arg_Is_Local_Name;
5432 ---------------------------------
5433 -- Check_Arg_Is_Locking_Policy --
5434 ---------------------------------
5436 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5437 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5440 Check_Arg_Is_Identifier (Argx);
5442 if not Is_Locking_Policy_Name (Chars (Argx)) then
5443 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5445 end Check_Arg_Is_Locking_Policy;
5447 -----------------------------------------------
5448 -- Check_Arg_Is_Partition_Elaboration_Policy --
5449 -----------------------------------------------
5451 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5452 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5455 Check_Arg_Is_Identifier (Argx);
5457 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5459 ("& is not a valid partition elaboration policy name", Argx);
5461 end Check_Arg_Is_Partition_Elaboration_Policy;
5463 -------------------------
5464 -- Check_Arg_Is_One_Of --
5465 -------------------------
5467 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5468 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5471 Check_Arg_Is_Identifier (Argx);
5473 if Chars (Argx) not in N1 | N2 then
5474 Error_Msg_Name_2 := N1;
5475 Error_Msg_Name_3 := N2;
5476 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5478 end Check_Arg_Is_One_Of;
5480 procedure Check_Arg_Is_One_Of
5482 N1, N2, N3 : Name_Id)
5484 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5487 Check_Arg_Is_Identifier (Argx);
5489 if Chars (Argx) not in N1 | N2 | N3 then
5490 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5492 end Check_Arg_Is_One_Of;
5494 procedure Check_Arg_Is_One_Of
5496 N1, N2, N3, N4 : Name_Id)
5498 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5501 Check_Arg_Is_Identifier (Argx);
5503 if Chars (Argx) not in N1 | N2 | N3 | N4 then
5504 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5506 end Check_Arg_Is_One_Of;
5508 procedure Check_Arg_Is_One_Of
5510 N1, N2, N3, N4, N5 : Name_Id)
5512 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5515 Check_Arg_Is_Identifier (Argx);
5517 if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
5518 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5520 end Check_Arg_Is_One_Of;
5522 ---------------------------------
5523 -- Check_Arg_Is_Queuing_Policy --
5524 ---------------------------------
5526 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5527 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5530 Check_Arg_Is_Identifier (Argx);
5532 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5533 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5535 end Check_Arg_Is_Queuing_Policy;
5537 ---------------------------------------
5538 -- Check_Arg_Is_OK_Static_Expression --
5539 ---------------------------------------
5541 procedure Check_Arg_Is_OK_Static_Expression
5543 Typ : Entity_Id := Empty)
5546 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5547 end Check_Arg_Is_OK_Static_Expression;
5549 ------------------------------------------
5550 -- Check_Arg_Is_Task_Dispatching_Policy --
5551 ------------------------------------------
5553 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5554 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5557 Check_Arg_Is_Identifier (Argx);
5559 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5561 ("& is not an allowed task dispatching policy name", Argx);
5563 end Check_Arg_Is_Task_Dispatching_Policy;
5565 ---------------------
5566 -- Check_Arg_Order --
5567 ---------------------
5569 procedure Check_Arg_Order (Names : Name_List) is
5572 Highest_So_Far : Natural := 0;
5573 -- Highest index in Names seen do far
5577 for J in 1 .. Arg_Count loop
5578 if Chars (Arg) /= No_Name then
5579 for K in Names'Range loop
5580 if Chars (Arg) = Names (K) then
5581 if K < Highest_So_Far then
5582 Error_Msg_Name_1 := Pname;
5584 ("parameters out of order for pragma%", Arg);
5585 Error_Msg_Name_1 := Names (K);
5586 Error_Msg_Name_2 := Names (Highest_So_Far);
5587 Error_Msg_N ("\% must appear before %", Arg);
5591 Highest_So_Far := K;
5599 end Check_Arg_Order;
5601 --------------------------------
5602 -- Check_At_Least_N_Arguments --
5603 --------------------------------
5605 procedure Check_At_Least_N_Arguments (N : Nat) is
5607 if Arg_Count < N then
5608 Error_Pragma ("too few arguments for pragma%");
5610 end Check_At_Least_N_Arguments;
5612 -------------------------------
5613 -- Check_At_Most_N_Arguments --
5614 -------------------------------
5616 procedure Check_At_Most_N_Arguments (N : Nat) is
5619 if Arg_Count > N then
5621 for J in 1 .. N loop
5623 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5626 end Check_At_Most_N_Arguments;
5628 ------------------------
5629 -- Check_Atomic_VFA --
5630 ------------------------
5632 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is
5634 Aliased_Subcomponent : exception;
5635 -- Exception raised if an aliased subcomponent is found in E
5637 Independent_Subcomponent : exception;
5638 -- Exception raised if an independent subcomponent is found in E
5640 procedure Check_Subcomponents (Typ : Entity_Id);
5641 -- Apply checks to subcomponents for Atomic and Volatile_Full_Access
5643 -------------------------
5644 -- Check_Subcomponents --
5645 -------------------------
5647 procedure Check_Subcomponents (Typ : Entity_Id) is
5651 if Is_Array_Type (Typ) then
5652 Comp := Component_Type (Typ);
5654 -- For Atomic we accept any atomic subcomponents
5657 and then (Has_Atomic_Components (Typ)
5658 or else Is_Atomic (Comp))
5662 -- Give an error if the components are aliased
5664 elsif Has_Aliased_Components (Typ)
5665 or else Is_Aliased (Comp)
5667 raise Aliased_Subcomponent;
5669 -- For VFA we accept non-aliased VFA subcomponents
5672 and then Is_Volatile_Full_Access (Comp)
5676 -- Give an error if the components are independent
5678 elsif Has_Independent_Components (Typ)
5679 or else Is_Independent (Comp)
5681 raise Independent_Subcomponent;
5684 -- Recurse on the component type
5686 Check_Subcomponents (Comp);
5688 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
5689 -- and Has_Independent_Components, applies only to arrays.
5690 -- However, this flag does not have a corresponding pragma, so
5691 -- perhaps it should be possible to apply it to record types as
5692 -- well. Should this be done ???
5694 elsif Is_Record_Type (Typ) then
5695 -- It is possible to have an aliased discriminant, so they
5696 -- must be checked along with normal components.
5698 Comp := First_Component_Or_Discriminant (Typ);
5699 while Present (Comp) loop
5701 -- For Atomic we accept any atomic subcomponents
5704 and then (Is_Atomic (Comp)
5705 or else Is_Atomic (Etype (Comp)))
5709 -- Give an error if the component is aliased
5711 elsif Is_Aliased (Comp)
5712 or else Is_Aliased (Etype (Comp))
5714 raise Aliased_Subcomponent;
5716 -- For VFA we accept non-aliased VFA subcomponents
5719 and then (Is_Volatile_Full_Access (Comp)
5720 or else Is_Volatile_Full_Access (Etype (Comp)))
5724 -- Give an error if the component is independent
5726 elsif Is_Independent (Comp)
5727 or else Is_Independent (Etype (Comp))
5729 raise Independent_Subcomponent;
5732 -- Recurse on the component type
5734 Check_Subcomponents (Etype (Comp));
5736 Next_Component_Or_Discriminant (Comp);
5739 end Check_Subcomponents;
5744 -- Fetch the type in case we are dealing with an object or component
5749 pragma Assert (Is_Object (E)
5751 Nkind (Declaration_Node (E)) = N_Component_Declaration);
5756 -- Check all the subcomponents of the type recursively, if any
5758 Check_Subcomponents (Typ);
5761 when Aliased_Subcomponent =>
5764 ("cannot apply Volatile_Full_Access with aliased "
5768 ("cannot apply Atomic with aliased subcomponent "
5772 when Independent_Subcomponent =>
5775 ("cannot apply Volatile_Full_Access with independent "
5779 ("cannot apply Atomic with independent subcomponent "
5784 raise Program_Error;
5785 end Check_Atomic_VFA;
5787 ---------------------
5788 -- Check_Component --
5789 ---------------------
5791 procedure Check_Component
5794 In_Variant_Part : Boolean := False)
5796 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5797 Sindic : constant Node_Id :=
5798 Subtype_Indication (Component_Definition (Comp));
5799 Typ : constant Entity_Id := Etype (Comp_Id);
5802 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5803 -- object constraint, then the component type shall be an Unchecked_
5806 if Nkind (Sindic) = N_Subtype_Indication
5807 and then Has_Per_Object_Constraint (Comp_Id)
5808 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5811 ("component subtype subject to per-object constraint "
5812 & "must be an Unchecked_Union", Comp);
5814 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5815 -- the body of a generic unit, or within the body of any of its
5816 -- descendant library units, no part of the type of a component
5817 -- declared in a variant_part of the unchecked union type shall be of
5818 -- a formal private type or formal private extension declared within
5819 -- the formal part of the generic unit.
5821 elsif Ada_Version >= Ada_2012
5822 and then In_Generic_Body (UU_Typ)
5823 and then In_Variant_Part
5824 and then Is_Private_Type (Typ)
5825 and then Is_Generic_Type (Typ)
5828 ("component of unchecked union cannot be of generic type", Comp);
5830 elsif Needs_Finalization (Typ) then
5832 ("component of unchecked union cannot be controlled", Comp);
5834 elsif Has_Task (Typ) then
5836 ("component of unchecked union cannot have tasks", Comp);
5838 end Check_Component;
5840 ----------------------------
5841 -- Check_Duplicate_Pragma --
5842 ----------------------------
5844 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5845 Id : Entity_Id := E;
5849 -- Nothing to do if this pragma comes from an aspect specification,
5850 -- since we could not be duplicating a pragma, and we dealt with the
5851 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5853 if From_Aspect_Specification (N) then
5857 -- Otherwise current pragma may duplicate previous pragma or a
5858 -- previously given aspect specification or attribute definition
5859 -- clause for the same pragma.
5861 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5865 -- If the entity is a type, then we have to make sure that the
5866 -- ostensible duplicate is not for a parent type from which this
5870 if Nkind (P) = N_Pragma then
5872 Args : constant List_Id :=
5873 Pragma_Argument_Associations (P);
5876 and then Is_Entity_Name (Expression (First (Args)))
5877 and then Is_Type (Entity (Expression (First (Args))))
5878 and then Entity (Expression (First (Args))) /= E
5884 elsif Nkind (P) = N_Aspect_Specification
5885 and then Is_Type (Entity (P))
5886 and then Entity (P) /= E
5892 -- Here we have a definite duplicate
5894 Error_Msg_Name_1 := Pragma_Name (N);
5895 Error_Msg_Sloc := Sloc (P);
5897 -- For a single protected or a single task object, the error is
5898 -- issued on the original entity.
5900 if Ekind (Id) in E_Task_Type | E_Protected_Type then
5901 Id := Defining_Identifier (Original_Node (Parent (Id)));
5904 if Nkind (P) = N_Aspect_Specification
5905 or else From_Aspect_Specification (P)
5907 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5909 -- If -gnatwr is set, warn in case of a duplicate pragma
5910 -- [No_]Inline which is suspicious but not an error, generate
5911 -- an error for other pragmas.
5913 if Pragma_Name (N) in Name_Inline | Name_No_Inline then
5914 if Warn_On_Redundant_Constructs then
5916 ("?r?pragma% for & duplicates pragma#", N, Id);
5919 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5925 end Check_Duplicate_Pragma;
5927 ----------------------------------
5928 -- Check_Duplicated_Export_Name --
5929 ----------------------------------
5931 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5932 String_Val : constant String_Id := Strval (Nam);
5935 -- We are only interested in the export case, and in the case of
5936 -- generics, it is the instance, not the template, that is the
5937 -- problem (the template will generate a warning in any case).
5939 if not Inside_A_Generic
5940 and then (Prag_Id = Pragma_Export
5942 Prag_Id = Pragma_Export_Procedure
5944 Prag_Id = Pragma_Export_Valued_Procedure
5946 Prag_Id = Pragma_Export_Function)
5948 for J in Externals.First .. Externals.Last loop
5949 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5950 Error_Msg_Sloc := Sloc (Externals.Table (J));
5951 Error_Msg_N ("external name duplicates name given#", Nam);
5956 Externals.Append (Nam);
5958 end Check_Duplicated_Export_Name;
5960 ----------------------------------------
5961 -- Check_Expr_Is_OK_Static_Expression --
5962 ----------------------------------------
5964 procedure Check_Expr_Is_OK_Static_Expression
5966 Typ : Entity_Id := Empty)
5969 if Present (Typ) then
5970 Analyze_And_Resolve (Expr, Typ);
5972 Analyze_And_Resolve (Expr);
5975 -- An expression cannot be considered static if its resolution failed
5976 -- or if it's erroneous. Stop the analysis of the related pragma.
5978 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5981 elsif Is_OK_Static_Expression (Expr) then
5984 -- An interesting special case, if we have a string literal and we
5985 -- are in Ada 83 mode, then we allow it even though it will not be
5986 -- flagged as static. This allows the use of Ada 95 pragmas like
5987 -- Import in Ada 83 mode. They will of course be flagged with
5988 -- warnings as usual, but will not cause errors.
5990 elsif Ada_Version = Ada_83
5991 and then Nkind (Expr) = N_String_Literal
5995 -- Finally, we have a real error
5998 Error_Msg_Name_1 := Pname;
5999 Flag_Non_Static_Expr
6000 (Fix_Error ("argument for pragma% must be a static expression!"),
6004 end Check_Expr_Is_OK_Static_Expression;
6006 -------------------------
6007 -- Check_First_Subtype --
6008 -------------------------
6010 procedure Check_First_Subtype (Arg : Node_Id) is
6011 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6012 Ent : constant Entity_Id := Entity (Argx);
6015 if Is_First_Subtype (Ent) then
6018 elsif Is_Type (Ent) then
6020 ("pragma% cannot apply to subtype", Argx);
6022 elsif Is_Object (Ent) then
6024 ("pragma% cannot apply to object, requires a type", Argx);
6028 ("pragma% cannot apply to&, requires a type", Argx);
6030 end Check_First_Subtype;
6032 ----------------------
6033 -- Check_Identifier --
6034 ----------------------
6036 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
6039 and then Nkind (Arg) = N_Pragma_Argument_Association
6041 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
6042 Error_Msg_Name_1 := Pname;
6043 Error_Msg_Name_2 := Id;
6044 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6048 end Check_Identifier;
6050 --------------------------------
6051 -- Check_Identifier_Is_One_Of --
6052 --------------------------------
6054 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
6057 and then Nkind (Arg) = N_Pragma_Argument_Association
6059 if Chars (Arg) = No_Name then
6060 Error_Msg_Name_1 := Pname;
6061 Error_Msg_N ("pragma% argument expects an identifier", Arg);
6064 elsif Chars (Arg) /= N1
6065 and then Chars (Arg) /= N2
6067 Error_Msg_Name_1 := Pname;
6068 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
6072 end Check_Identifier_Is_One_Of;
6074 ---------------------------
6075 -- Check_In_Main_Program --
6076 ---------------------------
6078 procedure Check_In_Main_Program is
6079 P : constant Node_Id := Parent (N);
6082 -- Must be in subprogram body
6084 if Nkind (P) /= N_Subprogram_Body then
6085 Error_Pragma ("% pragma allowed only in subprogram");
6087 -- Otherwise warn if obviously not main program
6089 elsif Present (Parameter_Specifications (Specification (P)))
6090 or else not Is_Compilation_Unit (Defining_Entity (P))
6092 Error_Msg_Name_1 := Pname;
6094 ("??pragma% is only effective in main program", N);
6096 end Check_In_Main_Program;
6098 ---------------------------------------
6099 -- Check_Interrupt_Or_Attach_Handler --
6100 ---------------------------------------
6102 procedure Check_Interrupt_Or_Attach_Handler is
6103 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6104 Handler_Proc, Proc_Scope : Entity_Id;
6109 if Prag_Id = Pragma_Interrupt_Handler then
6110 Check_Restriction (No_Dynamic_Attachment, N);
6113 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6114 Proc_Scope := Scope (Handler_Proc);
6116 if Ekind (Proc_Scope) /= E_Protected_Type then
6118 ("argument of pragma% must be protected procedure", Arg1);
6121 -- For pragma case (as opposed to access case), check placement.
6122 -- We don't need to do that for aspects, because we have the
6123 -- check that they aspect applies an appropriate procedure.
6125 if not From_Aspect_Specification (N)
6126 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6128 Error_Pragma ("pragma% must be in protected definition");
6131 if not Is_Library_Level_Entity (Proc_Scope) then
6133 ("argument for pragma% must be library level entity", Arg1);
6136 -- AI05-0033: A pragma cannot appear within a generic body, because
6137 -- instance can be in a nested scope. The check that protected type
6138 -- is itself a library-level declaration is done elsewhere.
6140 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6141 -- handle code prior to AI-0033. Analysis tools typically are not
6142 -- interested in this pragma in any case, so no need to worry too
6143 -- much about its placement.
6145 if Inside_A_Generic then
6146 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6147 and then In_Package_Body (Scope (Current_Scope))
6148 and then not Relaxed_RM_Semantics
6150 Error_Pragma ("pragma% cannot be used inside a generic");
6153 end Check_Interrupt_Or_Attach_Handler;
6155 ---------------------------------
6156 -- Check_Loop_Pragma_Placement --
6157 ---------------------------------
6159 procedure Check_Loop_Pragma_Placement is
6160 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6161 -- Verify whether the current pragma is properly grouped with other
6162 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6163 -- related loop where the pragma appears.
6165 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6166 -- Determine whether an arbitrary statement Stmt denotes pragma
6167 -- Loop_Invariant or Loop_Variant.
6169 procedure Placement_Error (Constr : Node_Id);
6170 pragma No_Return (Placement_Error);
6171 -- Node Constr denotes the last loop restricted construct before we
6172 -- encountered an illegal relation between enclosing constructs. Emit
6173 -- an error depending on what Constr was.
6175 --------------------------------
6176 -- Check_Loop_Pragma_Grouping --
6177 --------------------------------
6179 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6180 Stop_Search : exception;
6181 -- This exception is used to terminate the recursive descent of
6182 -- routine Check_Grouping.
6184 procedure Check_Grouping (L : List_Id);
6185 -- Find the first group of pragmas in list L and if successful,
6186 -- ensure that the current pragma is part of that group. The
6187 -- routine raises Stop_Search once such a check is performed to
6188 -- halt the recursive descent.
6190 procedure Grouping_Error (Prag : Node_Id);
6191 pragma No_Return (Grouping_Error);
6192 -- Emit an error concerning the current pragma indicating that it
6193 -- should be placed after pragma Prag.
6195 --------------------
6196 -- Check_Grouping --
6197 --------------------
6199 procedure Check_Grouping (L : List_Id) is
6202 Prag : Node_Id := Empty; -- init to avoid warning
6205 -- Inspect the list of declarations or statements looking for
6206 -- the first grouping of pragmas:
6209 -- pragma Loop_Invariant ...;
6210 -- pragma Loop_Variant ...;
6212 -- pragma Loop_Variant ...; -- current pragma
6214 -- If the current pragma is not in the grouping, then it must
6215 -- either appear in a different declarative or statement list
6216 -- or the construct at (1) is separating the pragma from the
6220 while Present (Stmt) loop
6222 -- First pragma of the first topmost grouping has been found
6224 if Is_Loop_Pragma (Stmt) then
6226 -- The group and the current pragma are not in the same
6227 -- declarative or statement list.
6229 if List_Containing (Stmt) /= List_Containing (N) then
6230 Grouping_Error (Stmt);
6232 -- Try to reach the current pragma from the first pragma
6233 -- of the grouping while skipping other members:
6235 -- pragma Loop_Invariant ...; -- first pragma
6236 -- pragma Loop_Variant ...; -- member
6238 -- pragma Loop_Variant ...; -- current pragma
6241 while Present (Stmt) loop
6242 -- The current pragma is either the first pragma
6243 -- of the group or is a member of the group.
6244 -- Stop the search as the placement is legal.
6249 -- Skip group members, but keep track of the
6250 -- last pragma in the group.
6252 elsif Is_Loop_Pragma (Stmt) then
6255 -- Skip declarations and statements generated by
6256 -- the compiler during expansion. Note that some
6257 -- source statements (e.g. pragma Assert) may have
6258 -- been transformed so that they do not appear as
6259 -- coming from source anymore, so we instead look
6260 -- at their Original_Node.
6262 elsif not Comes_From_Source (Original_Node (Stmt))
6266 -- A non-pragma is separating the group from the
6267 -- current pragma, the placement is illegal.
6270 Grouping_Error (Prag);
6276 -- If the traversal did not reach the current pragma,
6277 -- then the list must be malformed.
6279 raise Program_Error;
6282 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6283 -- inside a loop or a block housed inside a loop. Inspect
6284 -- the declarations and statements of the block as they may
6285 -- contain the first grouping. This case follows the one for
6286 -- loop pragmas, as block statements which originate in a
6287 -- loop pragma (and so Is_Loop_Pragma will return True on
6288 -- that block statement) should be treated in the previous
6291 elsif Nkind (Stmt) = N_Block_Statement then
6292 HSS := Handled_Statement_Sequence (Stmt);
6294 Check_Grouping (Declarations (Stmt));
6296 if Present (HSS) then
6297 Check_Grouping (Statements (HSS));
6305 --------------------
6306 -- Grouping_Error --
6307 --------------------
6309 procedure Grouping_Error (Prag : Node_Id) is
6311 Error_Msg_Sloc := Sloc (Prag);
6312 Error_Pragma ("pragma% must appear next to pragma#");
6315 -- Start of processing for Check_Loop_Pragma_Grouping
6318 -- Inspect the statements of the loop or nested blocks housed
6319 -- within to determine whether the current pragma is part of the
6320 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6322 Check_Grouping (Statements (Loop_Stmt));
6325 when Stop_Search => null;
6326 end Check_Loop_Pragma_Grouping;
6328 --------------------
6329 -- Is_Loop_Pragma --
6330 --------------------
6332 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6334 -- Inspect the original node as Loop_Invariant and Loop_Variant
6335 -- pragmas are rewritten to null when assertions are disabled.
6337 if Nkind (Original_Node (Stmt)) = N_Pragma then
6339 Pragma_Name_Unmapped (Original_Node (Stmt))
6340 in Name_Loop_Invariant | Name_Loop_Variant;
6346 ---------------------
6347 -- Placement_Error --
6348 ---------------------
6350 procedure Placement_Error (Constr : Node_Id) is
6351 LA : constant String := " with Loop_Entry";
6354 if Prag_Id = Pragma_Assert then
6355 Error_Msg_String (1 .. LA'Length) := LA;
6356 Error_Msg_Strlen := LA'Length;
6358 Error_Msg_Strlen := 0;
6361 if Nkind (Constr) = N_Pragma then
6363 ("pragma %~ must appear immediately within the statements "
6367 ("block containing pragma %~ must appear immediately within "
6368 & "the statements of a loop", Constr);
6370 end Placement_Error;
6372 -- Local declarations
6377 -- Start of processing for Check_Loop_Pragma_Placement
6380 -- Check that pragma appears immediately within a loop statement,
6381 -- ignoring intervening block statements.
6385 while Present (Stmt) loop
6387 -- The pragma or previous block must appear immediately within the
6388 -- current block's declarative or statement part.
6390 if Nkind (Stmt) = N_Block_Statement then
6391 if (No (Declarations (Stmt))
6392 or else List_Containing (Prev) /= Declarations (Stmt))
6394 List_Containing (Prev) /=
6395 Statements (Handled_Statement_Sequence (Stmt))
6397 Placement_Error (Prev);
6400 -- Keep inspecting the parents because we are now within a
6401 -- chain of nested blocks.
6405 Stmt := Parent (Stmt);
6408 -- The pragma or previous block must appear immediately within the
6409 -- statements of the loop.
6411 elsif Nkind (Stmt) = N_Loop_Statement then
6412 if List_Containing (Prev) /= Statements (Stmt) then
6413 Placement_Error (Prev);
6416 -- Stop the traversal because we reached the innermost loop
6417 -- regardless of whether we encountered an error or not.
6421 -- Ignore a handled statement sequence. Note that this node may
6422 -- be related to a subprogram body in which case we will emit an
6423 -- error on the next iteration of the search.
6425 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6426 Stmt := Parent (Stmt);
6428 -- Any other statement breaks the chain from the pragma to the
6432 Placement_Error (Prev);
6437 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6438 -- grouped together with other such pragmas.
6440 if Is_Loop_Pragma (N) then
6442 -- The previous check should have located the related loop
6444 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6445 Check_Loop_Pragma_Grouping (Stmt);
6447 end Check_Loop_Pragma_Placement;
6449 -------------------------------------------
6450 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6451 -------------------------------------------
6453 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6462 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6465 elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
6468 -- Note: the following tests seem a little peculiar, because
6469 -- they test for bodies, but if we were in the statement part
6470 -- of the body, we would already have hit the handled statement
6471 -- sequence, so the only way we get here is by being in the
6472 -- declarative part of the body.
6475 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6483 Error_Pragma ("pragma% is not in declarative part or package spec");
6484 end Check_Is_In_Decl_Part_Or_Package_Spec;
6486 -------------------------
6487 -- Check_No_Identifier --
6488 -------------------------
6490 procedure Check_No_Identifier (Arg : Node_Id) is
6492 if Nkind (Arg) = N_Pragma_Argument_Association
6493 and then Chars (Arg) /= No_Name
6495 Error_Pragma_Arg_Ident
6496 ("pragma% does not permit identifier& here", Arg);
6498 end Check_No_Identifier;
6500 --------------------------
6501 -- Check_No_Identifiers --
6502 --------------------------
6504 procedure Check_No_Identifiers is
6508 for J in 1 .. Arg_Count loop
6509 Check_No_Identifier (Arg_Node);
6512 end Check_No_Identifiers;
6514 ------------------------
6515 -- Check_No_Link_Name --
6516 ------------------------
6518 procedure Check_No_Link_Name is
6520 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6524 if Present (Arg4) then
6526 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6528 end Check_No_Link_Name;
6530 -------------------------------
6531 -- Check_Optional_Identifier --
6532 -------------------------------
6534 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6537 and then Nkind (Arg) = N_Pragma_Argument_Association
6538 and then Chars (Arg) /= No_Name
6540 if Chars (Arg) /= Id then
6541 Error_Msg_Name_1 := Pname;
6542 Error_Msg_Name_2 := Id;
6543 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6547 end Check_Optional_Identifier;
6549 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6551 Check_Optional_Identifier (Arg, Name_Find (Id));
6552 end Check_Optional_Identifier;
6554 -------------------------------------
6555 -- Check_Static_Boolean_Expression --
6556 -------------------------------------
6558 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6560 if Present (Expr) then
6561 Analyze_And_Resolve (Expr, Standard_Boolean);
6563 if not Is_OK_Static_Expression (Expr) then
6565 ("expression of pragma % must be static", Expr);
6568 end Check_Static_Boolean_Expression;
6570 -----------------------------
6571 -- Check_Static_Constraint --
6572 -----------------------------
6574 -- Note: for convenience in writing this procedure, in addition to
6575 -- the officially (i.e. by spec) allowed argument which is always a
6576 -- constraint, it also allows ranges and discriminant associations.
6577 -- Above is not clear ???
6579 procedure Check_Static_Constraint (Constr : Node_Id) is
6581 procedure Require_Static (E : Node_Id);
6582 -- Require given expression to be static expression
6584 --------------------
6585 -- Require_Static --
6586 --------------------
6588 procedure Require_Static (E : Node_Id) is
6590 if not Is_OK_Static_Expression (E) then
6591 Flag_Non_Static_Expr
6592 ("non-static constraint not allowed in Unchecked_Union!", E);
6597 -- Start of processing for Check_Static_Constraint
6600 case Nkind (Constr) is
6601 when N_Discriminant_Association =>
6602 Require_Static (Expression (Constr));
6605 Require_Static (Low_Bound (Constr));
6606 Require_Static (High_Bound (Constr));
6608 when N_Attribute_Reference =>
6609 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6610 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6612 when N_Range_Constraint =>
6613 Check_Static_Constraint (Range_Expression (Constr));
6615 when N_Index_Or_Discriminant_Constraint =>
6619 IDC := First (Constraints (Constr));
6620 while Present (IDC) loop
6621 Check_Static_Constraint (IDC);
6629 end Check_Static_Constraint;
6631 --------------------------------------
6632 -- Check_Valid_Configuration_Pragma --
6633 --------------------------------------
6635 -- A configuration pragma must appear in the context clause of a
6636 -- compilation unit, and only other pragmas may precede it. Note that
6637 -- the test also allows use in a configuration pragma file.
6639 procedure Check_Valid_Configuration_Pragma is
6641 if not Is_Configuration_Pragma then
6642 Error_Pragma ("incorrect placement for configuration pragma%");
6644 end Check_Valid_Configuration_Pragma;
6646 -------------------------------------
6647 -- Check_Valid_Library_Unit_Pragma --
6648 -------------------------------------
6650 procedure Check_Valid_Library_Unit_Pragma is
6652 Parent_Node : Node_Id;
6653 Unit_Name : Entity_Id;
6654 Unit_Kind : Node_Kind;
6655 Unit_Node : Node_Id;
6656 Sindex : Source_File_Index;
6659 if not Is_List_Member (N) then
6663 Plist := List_Containing (N);
6664 Parent_Node := Parent (Plist);
6666 if Parent_Node = Empty then
6669 -- Case of pragma appearing after a compilation unit. In this case
6670 -- it must have an argument with the corresponding name and must
6671 -- be part of the following pragmas of its parent.
6673 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6674 if Plist /= Pragmas_After (Parent_Node) then
6677 elsif Arg_Count = 0 then
6679 ("argument required if outside compilation unit");
6682 Check_No_Identifiers;
6683 Check_Arg_Count (1);
6684 Unit_Node := Unit (Parent (Parent_Node));
6685 Unit_Kind := Nkind (Unit_Node);
6687 Analyze (Get_Pragma_Arg (Arg1));
6689 if Unit_Kind = N_Generic_Subprogram_Declaration
6690 or else Unit_Kind = N_Subprogram_Declaration
6692 Unit_Name := Defining_Entity (Unit_Node);
6694 elsif Unit_Kind in N_Generic_Instantiation then
6695 Unit_Name := Defining_Entity (Unit_Node);
6698 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6701 if Chars (Unit_Name) /=
6702 Chars (Entity (Get_Pragma_Arg (Arg1)))
6705 ("pragma% argument is not current unit name", Arg1);
6708 if Ekind (Unit_Name) = E_Package
6709 and then Present (Renamed_Entity (Unit_Name))
6711 Error_Pragma ("pragma% not allowed for renamed package");
6715 -- Pragma appears other than after a compilation unit
6718 -- Here we check for the generic instantiation case and also
6719 -- for the case of processing a generic formal package. We
6720 -- detect these cases by noting that the Sloc on the node
6721 -- does not belong to the current compilation unit.
6723 Sindex := Source_Index (Current_Sem_Unit);
6725 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6726 Rewrite (N, Make_Null_Statement (Loc));
6729 -- If before first declaration, the pragma applies to the
6730 -- enclosing unit, and the name if present must be this name.
6732 elsif Is_Before_First_Decl (N, Plist) then
6733 Unit_Node := Unit_Declaration_Node (Current_Scope);
6734 Unit_Kind := Nkind (Unit_Node);
6736 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6739 elsif Unit_Kind = N_Subprogram_Body
6740 and then not Acts_As_Spec (Unit_Node)
6744 elsif Nkind (Parent_Node) = N_Package_Body then
6747 elsif Nkind (Parent_Node) = N_Package_Specification
6748 and then Plist = Private_Declarations (Parent_Node)
6752 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6753 or else Nkind (Parent_Node) =
6754 N_Generic_Subprogram_Declaration)
6755 and then Plist = Generic_Formal_Declarations (Parent_Node)
6759 elsif Arg_Count > 0 then
6760 Analyze (Get_Pragma_Arg (Arg1));
6762 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6764 ("name in pragma% must be enclosing unit", Arg1);
6767 -- It is legal to have no argument in this context
6773 -- Error if not before first declaration. This is because a
6774 -- library unit pragma argument must be the name of a library
6775 -- unit (RM 10.1.5(7)), but the only names permitted in this
6776 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6777 -- generic subprogram declarations or generic instantiations.
6781 ("pragma% misplaced, must be before first declaration");
6785 end Check_Valid_Library_Unit_Pragma;
6791 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6792 Clist : constant Node_Id := Component_List (Variant);
6796 Comp := First_Non_Pragma (Component_Items (Clist));
6797 while Present (Comp) loop
6798 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6799 Next_Non_Pragma (Comp);
6803 ---------------------------
6804 -- Ensure_Aggregate_Form --
6805 ---------------------------
6807 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6808 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6809 Expr : constant Node_Id := Expression (Arg);
6810 Loc : constant Source_Ptr := Sloc (Expr);
6811 Comps : List_Id := No_List;
6812 Exprs : List_Id := No_List;
6813 Nam : Name_Id := No_Name;
6814 Nam_Loc : Source_Ptr;
6817 -- The pragma argument is in positional form:
6819 -- pragma Depends (Nam => ...)
6823 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6824 -- argument association.
6826 if Nkind (Arg) = N_Pragma_Argument_Association then
6828 Nam_Loc := Sloc (Arg);
6830 -- Remove the pragma argument name as this will be captured in the
6833 Set_Chars (Arg, No_Name);
6836 -- The argument is already in aggregate form, but the presence of a
6837 -- name causes this to be interpreted as named association which in
6838 -- turn must be converted into an aggregate.
6840 -- pragma Global (In_Out => (A, B, C))
6844 -- pragma Global ((In_Out => (A, B, C)))
6846 -- aggregate aggregate
6848 if Nkind (Expr) = N_Aggregate then
6849 if Nam = No_Name then
6853 -- Do not transform a null argument into an aggregate as N_Null has
6854 -- special meaning in formal verification pragmas.
6856 elsif Nkind (Expr) = N_Null then
6860 -- Everything comes from source if the original comes from source
6862 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6864 -- Positional argument is transformed into an aggregate with an
6865 -- Expressions list.
6867 if Nam = No_Name then
6868 Exprs := New_List (Relocate_Node (Expr));
6870 -- An associative argument is transformed into an aggregate with
6871 -- Component_Associations.
6875 Make_Component_Association (Loc,
6876 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6877 Expression => Relocate_Node (Expr)));
6880 Set_Expression (Arg,
6881 Make_Aggregate (Loc,
6882 Component_Associations => Comps,
6883 Expressions => Exprs));
6885 -- Restore Comes_From_Source default
6887 Set_Comes_From_Source_Default (CFSD);
6888 end Ensure_Aggregate_Form;
6894 procedure Error_Pragma (Msg : String) is
6896 Error_Msg_Name_1 := Pname;
6897 Error_Msg_N (Fix_Error (Msg), N);
6901 ----------------------
6902 -- Error_Pragma_Arg --
6903 ----------------------
6905 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6907 Error_Msg_Name_1 := Pname;
6908 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6910 end Error_Pragma_Arg;
6912 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6914 Error_Msg_Name_1 := Pname;
6915 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6916 Error_Pragma_Arg (Msg2, Arg);
6917 end Error_Pragma_Arg;
6919 ----------------------------
6920 -- Error_Pragma_Arg_Ident --
6921 ----------------------------
6923 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6925 Error_Msg_Name_1 := Pname;
6926 Error_Msg_N (Fix_Error (Msg), Arg);
6928 end Error_Pragma_Arg_Ident;
6930 ----------------------
6931 -- Error_Pragma_Ref --
6932 ----------------------
6934 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6936 Error_Msg_Name_1 := Pname;
6937 Error_Msg_Sloc := Sloc (Ref);
6938 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6940 end Error_Pragma_Ref;
6942 ------------------------
6943 -- Find_Lib_Unit_Name --
6944 ------------------------
6946 function Find_Lib_Unit_Name return Entity_Id is
6948 -- Return inner compilation unit entity, for case of nested
6949 -- categorization pragmas. This happens in generic unit.
6951 if Nkind (Parent (N)) = N_Package_Specification
6952 and then Defining_Entity (Parent (N)) /= Current_Scope
6954 return Defining_Entity (Parent (N));
6956 return Current_Scope;
6958 end Find_Lib_Unit_Name;
6960 ----------------------------
6961 -- Find_Program_Unit_Name --
6962 ----------------------------
6964 procedure Find_Program_Unit_Name (Id : Node_Id) is
6965 Unit_Name : Entity_Id;
6966 Unit_Kind : Node_Kind;
6967 P : constant Node_Id := Parent (N);
6970 if Nkind (P) = N_Compilation_Unit then
6971 Unit_Kind := Nkind (Unit (P));
6973 if Unit_Kind in N_Subprogram_Declaration
6974 | N_Package_Declaration
6975 | N_Generic_Declaration
6977 Unit_Name := Defining_Entity (Unit (P));
6979 if Chars (Id) = Chars (Unit_Name) then
6980 Set_Entity (Id, Unit_Name);
6981 Set_Etype (Id, Etype (Unit_Name));
6983 Set_Etype (Id, Any_Type);
6985 ("cannot find program unit referenced by pragma%");
6989 Set_Etype (Id, Any_Type);
6990 Error_Pragma ("pragma% inapplicable to this unit");
6996 end Find_Program_Unit_Name;
6998 -----------------------------------------
6999 -- Find_Unique_Parameterless_Procedure --
7000 -----------------------------------------
7002 function Find_Unique_Parameterless_Procedure
7004 Arg : Node_Id) return Entity_Id
7006 Proc : Entity_Id := Empty;
7009 -- The body of this procedure needs some comments ???
7011 if not Is_Entity_Name (Name) then
7013 ("argument of pragma% must be entity name", Arg);
7015 elsif not Is_Overloaded (Name) then
7016 Proc := Entity (Name);
7018 if Ekind (Proc) /= E_Procedure
7019 or else Present (First_Formal (Proc))
7022 ("argument of pragma% must be parameterless procedure", Arg);
7027 Found : Boolean := False;
7029 Index : Interp_Index;
7032 Get_First_Interp (Name, Index, It);
7033 while Present (It.Nam) loop
7036 if Ekind (Proc) = E_Procedure
7037 and then No (First_Formal (Proc))
7041 Set_Entity (Name, Proc);
7042 Set_Is_Overloaded (Name, False);
7045 ("ambiguous handler name for pragma% ", Arg);
7049 Get_Next_Interp (Index, It);
7054 ("argument of pragma% must be parameterless procedure",
7057 Proc := Entity (Name);
7063 end Find_Unique_Parameterless_Procedure;
7069 function Fix_Error (Msg : String) return String is
7070 Res : String (Msg'Range) := Msg;
7071 Res_Last : Natural := Msg'Last;
7075 -- If we have a rewriting of another pragma, go to that pragma
7077 if Is_Rewrite_Substitution (N)
7078 and then Nkind (Original_Node (N)) = N_Pragma
7080 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
7083 -- Case where pragma comes from an aspect specification
7085 if From_Aspect_Specification (N) then
7087 -- Change appearence of "pragma" in message to "aspect"
7090 while J <= Res_Last - 5 loop
7091 if Res (J .. J + 5) = "pragma" then
7092 Res (J .. J + 5) := "aspect";
7100 -- Change "argument of" at start of message to "entity for"
7103 and then Res (Res'First .. Res'First + 10) = "argument of"
7105 Res (Res'First .. Res'First + 9) := "entity for";
7106 Res (Res'First + 10 .. Res_Last - 1) :=
7107 Res (Res'First + 11 .. Res_Last);
7108 Res_Last := Res_Last - 1;
7111 -- Change "argument" at start of message to "entity"
7114 and then Res (Res'First .. Res'First + 7) = "argument"
7116 Res (Res'First .. Res'First + 5) := "entity";
7117 Res (Res'First + 6 .. Res_Last - 2) :=
7118 Res (Res'First + 8 .. Res_Last);
7119 Res_Last := Res_Last - 2;
7122 -- Get name from corresponding aspect
7124 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7127 -- Return possibly modified message
7129 return Res (Res'First .. Res_Last);
7132 -------------------------
7133 -- Gather_Associations --
7134 -------------------------
7136 procedure Gather_Associations
7138 Args : out Args_List)
7143 -- Initialize all parameters to Empty
7145 for J in Args'Range loop
7149 -- That's all we have to do if there are no argument associations
7151 if No (Pragma_Argument_Associations (N)) then
7155 -- Otherwise first deal with any positional parameters present
7157 Arg := First (Pragma_Argument_Associations (N));
7158 for Index in Args'Range loop
7159 exit when No (Arg) or else Chars (Arg) /= No_Name;
7160 Args (Index) := Get_Pragma_Arg (Arg);
7164 -- Positional parameters all processed, if any left, then we
7165 -- have too many positional parameters.
7167 if Present (Arg) and then Chars (Arg) = No_Name then
7169 ("too many positional associations for pragma%", Arg);
7172 -- Process named parameters if any are present
7174 while Present (Arg) loop
7175 if Chars (Arg) = No_Name then
7177 ("positional association cannot follow named association",
7181 for Index in Names'Range loop
7182 if Names (Index) = Chars (Arg) then
7183 if Present (Args (Index)) then
7185 ("duplicate argument association for pragma%", Arg);
7187 Args (Index) := Get_Pragma_Arg (Arg);
7192 if Index = Names'Last then
7193 Error_Msg_Name_1 := Pname;
7194 Error_Msg_N ("pragma% does not allow & argument", Arg);
7196 -- Check for possible misspelling
7198 for Index1 in Names'Range loop
7199 if Is_Bad_Spelling_Of
7200 (Chars (Arg), Names (Index1))
7202 Error_Msg_Name_1 := Names (Index1);
7203 Error_Msg_N -- CODEFIX
7204 ("\possible misspelling of%", Arg);
7216 end Gather_Associations;
7222 procedure GNAT_Pragma is
7224 -- We need to check the No_Implementation_Pragmas restriction for
7225 -- the case of a pragma from source. Note that the case of aspects
7226 -- generating corresponding pragmas marks these pragmas as not being
7227 -- from source, so this test also catches that case.
7229 if Comes_From_Source (N) then
7230 Check_Restriction (No_Implementation_Pragmas, N);
7234 --------------------------
7235 -- Is_Before_First_Decl --
7236 --------------------------
7238 function Is_Before_First_Decl
7239 (Pragma_Node : Node_Id;
7240 Decls : List_Id) return Boolean
7242 Item : Node_Id := First (Decls);
7245 -- Only other pragmas can come before this pragma, but they might
7246 -- have been rewritten so check the original node.
7249 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7252 elsif Item = Pragma_Node then
7258 end Is_Before_First_Decl;
7260 -----------------------------
7261 -- Is_Configuration_Pragma --
7262 -----------------------------
7264 -- A configuration pragma must appear in the context clause of a
7265 -- compilation unit, and only other pragmas may precede it. Note that
7266 -- the test below also permits use in a configuration pragma file.
7268 function Is_Configuration_Pragma return Boolean is
7269 Lis : constant List_Id := List_Containing (N);
7270 Par : constant Node_Id := Parent (N);
7274 -- If no parent, then we are in the configuration pragma file,
7275 -- so the placement is definitely appropriate.
7280 -- Otherwise we must be in the context clause of a compilation unit
7281 -- and the only thing allowed before us in the context list is more
7282 -- configuration pragmas.
7284 elsif Nkind (Par) = N_Compilation_Unit
7285 and then Context_Items (Par) = Lis
7292 elsif Nkind (Prg) /= N_Pragma then
7302 end Is_Configuration_Pragma;
7304 --------------------------
7305 -- Is_In_Context_Clause --
7306 --------------------------
7308 function Is_In_Context_Clause return Boolean is
7310 Parent_Node : Node_Id;
7313 if not Is_List_Member (N) then
7317 Plist := List_Containing (N);
7318 Parent_Node := Parent (Plist);
7320 if Parent_Node = Empty
7321 or else Nkind (Parent_Node) /= N_Compilation_Unit
7322 or else Context_Items (Parent_Node) /= Plist
7329 end Is_In_Context_Clause;
7331 ---------------------------------
7332 -- Is_Static_String_Expression --
7333 ---------------------------------
7335 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7336 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7337 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7340 Analyze_And_Resolve (Argx);
7342 -- Special case Ada 83, where the expression will never be static,
7343 -- but we will return true if we had a string literal to start with.
7345 if Ada_Version = Ada_83 then
7348 -- Normal case, true only if we end up with a string literal that
7349 -- is marked as being the result of evaluating a static expression.
7352 return Is_OK_Static_Expression (Argx)
7353 and then Nkind (Argx) = N_String_Literal;
7356 end Is_Static_String_Expression;
7358 ----------------------
7359 -- Pragma_Misplaced --
7360 ----------------------
7362 procedure Pragma_Misplaced is
7364 Error_Pragma ("incorrect placement of pragma%");
7365 end Pragma_Misplaced;
7367 ------------------------------------------------
7368 -- Process_Atomic_Independent_Shared_Volatile --
7369 ------------------------------------------------
7371 procedure Process_Atomic_Independent_Shared_Volatile is
7372 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7373 -- Check that Volatile_Full_Access and VFA do not conflict
7375 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7376 -- Appropriately set flags on the given entity, either an array or
7377 -- record component, or an object declaration) according to the
7380 procedure Mark_Type (Ent : Entity_Id);
7381 -- Appropriately set flags on the given entity, a type
7383 procedure Set_Atomic_VFA (Ent : Entity_Id);
7384 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7385 -- no explicit alignment was given, set alignment to unknown, since
7386 -- back end knows what the alignment requirements are for atomic and
7387 -- full access arrays. Note: this is necessary for derived types.
7389 -------------------------
7390 -- Check_VFA_Conflicts --
7391 -------------------------
7393 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7397 VFA_And_Atomic : Boolean := False;
7398 -- Set True if both VFA and Atomic present
7401 -- Fetch the type in case we are dealing with an object or
7404 if Is_Type (Ent) then
7407 pragma Assert (Is_Object (Ent)
7409 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7414 -- Check Atomic and VFA used together
7416 if Prag_Id = Pragma_Volatile_Full_Access
7417 or else Is_Volatile_Full_Access (Ent)
7419 if Prag_Id = Pragma_Atomic
7420 or else Prag_Id = Pragma_Shared
7421 or else Is_Atomic (Ent)
7423 VFA_And_Atomic := True;
7425 elsif Is_Array_Type (Typ) then
7426 VFA_And_Atomic := Has_Atomic_Components (Typ);
7428 -- Note: Has_Atomic_Components is not used below, as this flag
7429 -- represents the pragma of the same name, Atomic_Components,
7430 -- which only applies to arrays.
7432 elsif Is_Record_Type (Typ) then
7433 -- Attributes cannot be applied to discriminants, only
7434 -- regular record components.
7436 Comp := First_Component (Typ);
7437 while Present (Comp) loop
7439 or else Is_Atomic (Typ)
7441 VFA_And_Atomic := True;
7446 Next_Component (Comp);
7450 if VFA_And_Atomic then
7452 ("cannot have Volatile_Full_Access and Atomic for same "
7456 end Check_VFA_Conflicts;
7458 ------------------------------
7459 -- Mark_Component_Or_Object --
7460 ------------------------------
7462 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7464 if Prag_Id = Pragma_Atomic
7465 or else Prag_Id = Pragma_Shared
7466 or else Prag_Id = Pragma_Volatile_Full_Access
7468 if Prag_Id = Pragma_Volatile_Full_Access then
7469 Set_Is_Volatile_Full_Access (Ent);
7471 Set_Is_Atomic (Ent);
7474 -- If the object declaration has an explicit initialization, a
7475 -- temporary may have to be created to hold the expression, to
7476 -- ensure that access to the object remains atomic.
7478 if Nkind (Parent (Ent)) = N_Object_Declaration
7479 and then Present (Expression (Parent (Ent)))
7481 Set_Has_Delayed_Freeze (Ent);
7485 -- Atomic/Shared/Volatile_Full_Access imply Independent
7487 if Prag_Id /= Pragma_Volatile then
7488 Set_Is_Independent (Ent);
7490 if Prag_Id = Pragma_Independent then
7491 Record_Independence_Check (N, Ent);
7495 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7497 if Prag_Id /= Pragma_Independent then
7498 Set_Is_Volatile (Ent);
7499 Set_Treat_As_Volatile (Ent);
7501 end Mark_Component_Or_Object;
7507 procedure Mark_Type (Ent : Entity_Id) is
7509 -- Attribute belongs on the base type. If the view of the type is
7510 -- currently private, it also belongs on the underlying type.
7512 -- In Ada 2020, the pragma can apply to a formal type, for which
7513 -- there may be no underlying type.
7515 if Prag_Id = Pragma_Atomic
7516 or else Prag_Id = Pragma_Shared
7517 or else Prag_Id = Pragma_Volatile_Full_Access
7519 Set_Atomic_VFA (Ent);
7520 Set_Atomic_VFA (Base_Type (Ent));
7522 if not Is_Generic_Type (Ent) then
7523 Set_Atomic_VFA (Underlying_Type (Ent));
7527 -- Atomic/Shared/Volatile_Full_Access imply Independent
7529 if Prag_Id /= Pragma_Volatile then
7530 Set_Is_Independent (Ent);
7531 Set_Is_Independent (Base_Type (Ent));
7533 if not Is_Generic_Type (Ent) then
7534 Set_Is_Independent (Underlying_Type (Ent));
7536 if Prag_Id = Pragma_Independent then
7537 Record_Independence_Check (N, Base_Type (Ent));
7542 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7544 if Prag_Id /= Pragma_Independent then
7545 Set_Is_Volatile (Ent);
7546 Set_Is_Volatile (Base_Type (Ent));
7548 if not Is_Generic_Type (Ent) then
7549 Set_Is_Volatile (Underlying_Type (Ent));
7550 Set_Treat_As_Volatile (Underlying_Type (Ent));
7553 Set_Treat_As_Volatile (Ent);
7556 -- Apply Volatile to the composite type's individual components,
7559 if Prag_Id = Pragma_Volatile
7560 and then Is_Record_Type (Etype (Ent))
7565 Comp := First_Component (Ent);
7566 while Present (Comp) loop
7567 Mark_Component_Or_Object (Comp);
7569 Next_Component (Comp);
7575 --------------------
7576 -- Set_Atomic_VFA --
7577 --------------------
7579 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7581 if Prag_Id = Pragma_Volatile_Full_Access then
7582 Set_Is_Volatile_Full_Access (Ent);
7584 Set_Is_Atomic (Ent);
7587 if not Has_Alignment_Clause (Ent) then
7588 Set_Alignment (Ent, Uint_0);
7598 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7601 Check_Ada_83_Warning;
7602 Check_No_Identifiers;
7603 Check_Arg_Count (1);
7604 Check_Arg_Is_Local_Name (Arg1);
7605 E_Arg := Get_Pragma_Arg (Arg1);
7607 if Etype (E_Arg) = Any_Type then
7611 E := Entity (E_Arg);
7613 -- A pragma that applies to a Ghost entity becomes Ghost for the
7614 -- purposes of legality checks and removal of ignored Ghost code.
7616 Mark_Ghost_Pragma (N, E);
7618 -- Check duplicate before we chain ourselves
7620 Check_Duplicate_Pragma (E);
7622 -- Check appropriateness of the entity
7624 Decl := Declaration_Node (E);
7626 -- Deal with the case where the pragma/attribute is applied to a type
7629 if Rep_Item_Too_Early (E, N)
7630 or else Rep_Item_Too_Late (E, N)
7634 Check_First_Subtype (Arg1);
7639 -- Deal with the case where the pragma/attribute applies to a
7640 -- component or object declaration.
7642 elsif Nkind (Decl) = N_Object_Declaration
7643 or else (Nkind (Decl) = N_Component_Declaration
7644 and then Original_Record_Component (E) = E)
7646 if Rep_Item_Too_Late (E, N) then
7650 Mark_Component_Or_Object (E);
7652 -- In other cases give an error
7655 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7658 -- Check that Volatile_Full_Access and Atomic do not conflict
7660 Check_VFA_Conflicts (E);
7662 -- Check for the application of Atomic or Volatile_Full_Access to
7663 -- an entity that has [nonatomic] aliased, or else specified to be
7664 -- independently addressable, subcomponents.
7666 if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020)
7667 or else Prag_Id = Pragma_Volatile_Full_Access
7669 Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access);
7672 -- The following check is only relevant when SPARK_Mode is on as
7673 -- this is not a standard Ada legality rule. Pragma Volatile can
7674 -- only apply to a full type declaration or an object declaration
7675 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7676 -- untagged derived types that are rewritten as subtypes of their
7677 -- respective root types.
7680 and then Prag_Id = Pragma_Volatile
7681 and then Nkind (Original_Node (Decl)) not in
7682 N_Full_Type_Declaration |
7683 N_Formal_Type_Declaration |
7684 N_Object_Declaration |
7685 N_Single_Protected_Declaration |
7686 N_Single_Task_Declaration
7689 ("argument of pragma % must denote a full type or object "
7690 & "declaration", Arg1);
7692 end Process_Atomic_Independent_Shared_Volatile;
7694 -------------------------------------------
7695 -- Process_Compile_Time_Warning_Or_Error --
7696 -------------------------------------------
7698 procedure Process_Compile_Time_Warning_Or_Error is
7699 P : Node_Id := Parent (N);
7700 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7703 Check_Arg_Count (2);
7704 Check_No_Identifiers;
7705 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7706 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7708 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7709 -- a Check pragma in GNATprove mode, handled as an assumption in
7710 -- GNATprove. This is correct as the compiler will issue an error
7711 -- if the condition cannot be statically evaluated to False.
7712 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7713 -- same information as the compiler (in particular regarding size of
7714 -- objects decided in gigi) so it makes no sense to issue a warning
7717 if GNATprove_Mode then
7718 if Prag_Id = Pragma_Compile_Time_Error then
7722 -- Implement Compile_Time_Error by generating
7723 -- a corresponding Check pragma:
7725 -- pragma Check (name, condition);
7727 -- where name is the identifier matching the pragma name. So
7728 -- rewrite pragma in this manner and analyze the result.
7730 New_Args := New_List
7731 (Make_Pragma_Argument_Association
7733 Expression => Make_Identifier (Loc, Pname)),
7734 Make_Pragma_Argument_Association
7736 Expression => Arg1x));
7738 -- Rewrite as Check pragma
7742 Chars => Name_Check,
7743 Pragma_Argument_Associations => New_Args));
7749 Rewrite (N, Make_Null_Statement (Loc));
7755 -- If the condition is known at compile time (now), validate it now.
7756 -- Otherwise, register the expression for validation after the back
7757 -- end has been called, because it might be known at compile time
7758 -- then. For example, if the expression is "Record_Type'Size /= 32"
7759 -- it might be known after the back end has determined the size of
7760 -- Record_Type. We do not defer validation if we're inside a generic
7761 -- unit, because we will have more information in the instances.
7763 if Compile_Time_Known_Value (Arg1x) then
7764 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7766 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7768 if Nkind (P) in N_Package_Body | N_Subprogram_Body then
7769 P := Corresponding_Spec (P);
7776 Defer_Compile_Time_Warning_Error_To_BE (N);
7779 end Process_Compile_Time_Warning_Or_Error;
7781 ------------------------
7782 -- Process_Convention --
7783 ------------------------
7785 procedure Process_Convention
7786 (C : out Convention_Id;
7787 Ent : out Entity_Id)
7791 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7792 -- Called if we have more than one Export/Import/Convention pragma.
7793 -- This is generally illegal, but we have a special case of allowing
7794 -- Import and Interface to coexist if they specify the convention in
7795 -- a consistent manner. We are allowed to do this, since Interface is
7796 -- an implementation defined pragma, and we choose to do it since we
7797 -- know Rational allows this combination. S is the entity id of the
7798 -- subprogram in question. This procedure also sets the special flag
7799 -- Import_Interface_Present in both pragmas in the case where we do
7800 -- have matching Import and Interface pragmas.
7802 procedure Set_Convention_From_Pragma (E : Entity_Id);
7803 -- Set convention in entity E, and also flag that the entity has a
7804 -- convention pragma. If entity is for a private or incomplete type,
7805 -- also set convention and flag on underlying type. This procedure
7806 -- also deals with the special case of C_Pass_By_Copy convention,
7807 -- and error checks for inappropriate convention specification.
7809 -------------------------------
7810 -- Diagnose_Multiple_Pragmas --
7811 -------------------------------
7813 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7814 Pdec : constant Node_Id := Declaration_Node (S);
7818 function Same_Convention (Decl : Node_Id) return Boolean;
7819 -- Decl is a pragma node. This function returns True if this
7820 -- pragma has a first argument that is an identifier with a
7821 -- Chars field corresponding to the Convention_Id C.
7823 function Same_Name (Decl : Node_Id) return Boolean;
7824 -- Decl is a pragma node. This function returns True if this
7825 -- pragma has a second argument that is an identifier with a
7826 -- Chars field that matches the Chars of the current subprogram.
7828 ---------------------
7829 -- Same_Convention --
7830 ---------------------
7832 function Same_Convention (Decl : Node_Id) return Boolean is
7833 Arg1 : constant Node_Id :=
7834 First (Pragma_Argument_Associations (Decl));
7837 if Present (Arg1) then
7839 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7841 if Nkind (Arg) = N_Identifier
7842 and then Is_Convention_Name (Chars (Arg))
7843 and then Get_Convention_Id (Chars (Arg)) = C
7851 end Same_Convention;
7857 function Same_Name (Decl : Node_Id) return Boolean is
7858 Arg1 : constant Node_Id :=
7859 First (Pragma_Argument_Associations (Decl));
7867 Arg2 := Next (Arg1);
7874 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7876 if Nkind (Arg) = N_Identifier
7877 and then Chars (Arg) = Chars (S)
7886 -- Start of processing for Diagnose_Multiple_Pragmas
7891 -- Definitely give message if we have Convention/Export here
7893 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7896 -- If we have an Import or Export, scan back from pragma to
7897 -- find any previous pragma applying to the same procedure.
7898 -- The scan will be terminated by the start of the list, or
7899 -- hitting the subprogram declaration. This won't allow one
7900 -- pragma to appear in the public part and one in the private
7901 -- part, but that seems very unlikely in practice.
7905 while Present (Decl) and then Decl /= Pdec loop
7907 -- Look for pragma with same name as us
7909 if Nkind (Decl) = N_Pragma
7910 and then Same_Name (Decl)
7912 -- Give error if same as our pragma or Export/Convention
7914 if Pragma_Name_Unmapped (Decl)
7917 | Pragma_Name_Unmapped (N)
7921 -- Case of Import/Interface or the other way round
7923 elsif Pragma_Name_Unmapped (Decl)
7924 in Name_Interface | Name_Import
7926 -- Here we know that we have Import and Interface. It
7927 -- doesn't matter which way round they are. See if
7928 -- they specify the same convention. If so, all OK,
7929 -- and set special flags to stop other messages
7931 if Same_Convention (Decl) then
7932 Set_Import_Interface_Present (N);
7933 Set_Import_Interface_Present (Decl);
7936 -- If different conventions, special message
7939 Error_Msg_Sloc := Sloc (Decl);
7941 ("convention differs from that given#", Arg1);
7951 -- Give message if needed if we fall through those tests
7952 -- except on Relaxed_RM_Semantics where we let go: either this
7953 -- is a case accepted/ignored by other Ada compilers (e.g.
7954 -- a mix of Convention and Import), or another error will be
7955 -- generated later (e.g. using both Import and Export).
7957 if Err and not Relaxed_RM_Semantics then
7959 ("at most one Convention/Export/Import pragma is allowed",
7962 end Diagnose_Multiple_Pragmas;
7964 --------------------------------
7965 -- Set_Convention_From_Pragma --
7966 --------------------------------
7968 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7970 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7971 -- for an overridden dispatching operation. Technically this is
7972 -- an amendment and should only be done in Ada 2005 mode. However,
7973 -- this is clearly a mistake, since the problem that is addressed
7974 -- by this AI is that there is a clear gap in the RM.
7976 if Is_Dispatching_Operation (E)
7977 and then Present (Overridden_Operation (E))
7978 and then C /= Convention (Overridden_Operation (E))
7981 ("cannot change convention for overridden dispatching "
7982 & "operation", Arg1);
7984 -- Special check for convention Stdcall: a dispatching call is not
7985 -- allowed. A dispatching subprogram cannot be used to interface
7986 -- to the Win32 API, so this check actually does not impose any
7987 -- effective restriction.
7989 elsif Is_Dispatching_Operation (E)
7990 and then C = Convention_Stdcall
7992 -- Note: make this unconditional so that if there is more
7993 -- than one call to which the pragma applies, we get a
7994 -- message for each call. Also don't use Error_Pragma,
7995 -- so that we get multiple messages.
7997 Error_Msg_Sloc := Sloc (E);
7999 ("dispatching subprogram# cannot use Stdcall convention!",
8000 Get_Pragma_Arg (Arg1));
8003 -- Set the convention
8005 Set_Convention (E, C);
8006 Set_Has_Convention_Pragma (E);
8008 -- For the case of a record base type, also set the convention of
8009 -- any anonymous access types declared in the record which do not
8010 -- currently have a specified convention.
8011 -- Similarly for an array base type and anonymous access types
8014 if Is_Base_Type (E) then
8015 if Is_Record_Type (E) then
8020 Comp := First_Component (E);
8021 while Present (Comp) loop
8022 if Present (Etype (Comp))
8024 Ekind (Etype (Comp)) in
8025 E_Anonymous_Access_Type |
8026 E_Anonymous_Access_Subprogram_Type
8027 and then not Has_Convention_Pragma (Comp)
8029 Set_Convention (Comp, C);
8032 Next_Component (Comp);
8036 elsif Is_Array_Type (E)
8037 and then Ekind (Component_Type (E)) in
8038 E_Anonymous_Access_Type |
8039 E_Anonymous_Access_Subprogram_Type
8041 Set_Convention (Designated_Type (Component_Type (E)), C);
8045 -- Deal with incomplete/private type case, where underlying type
8046 -- is available, so set convention of that underlying type.
8048 if Is_Incomplete_Or_Private_Type (E)
8049 and then Present (Underlying_Type (E))
8051 Set_Convention (Underlying_Type (E), C);
8052 Set_Has_Convention_Pragma (Underlying_Type (E), True);
8055 -- A class-wide type should inherit the convention of the specific
8056 -- root type (although this isn't specified clearly by the RM).
8058 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
8059 Set_Convention (Class_Wide_Type (E), C);
8062 -- If the entity is a record type, then check for special case of
8063 -- C_Pass_By_Copy, which is treated the same as C except that the
8064 -- special record flag is set. This convention is only permitted
8065 -- on record types (see AI95-00131).
8067 if Cname = Name_C_Pass_By_Copy then
8068 if Is_Record_Type (E) then
8069 Set_C_Pass_By_Copy (Base_Type (E));
8070 elsif Is_Incomplete_Or_Private_Type (E)
8071 and then Is_Record_Type (Underlying_Type (E))
8073 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
8076 ("C_Pass_By_Copy convention allowed only for record type",
8081 -- If the entity is a derived boolean type, check for the special
8082 -- case of convention C, C++, or Fortran, where we consider any
8083 -- nonzero value to represent true.
8085 if Is_Discrete_Type (E)
8086 and then Root_Type (Etype (E)) = Standard_Boolean
8092 C = Convention_Fortran)
8094 Set_Nonzero_Is_True (Base_Type (E));
8096 end Set_Convention_From_Pragma;
8100 Comp_Unit : Unit_Number_Type;
8106 -- Start of processing for Process_Convention
8109 Check_At_Least_N_Arguments (2);
8110 Check_Optional_Identifier (Arg1, Name_Convention);
8111 Check_Arg_Is_Identifier (Arg1);
8112 Cname := Chars (Get_Pragma_Arg (Arg1));
8114 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8115 -- tested again below to set the critical flag).
8117 if Cname = Name_C_Pass_By_Copy then
8120 -- Otherwise we must have something in the standard convention list
8122 elsif Is_Convention_Name (Cname) then
8123 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8125 -- Otherwise warn on unrecognized convention
8128 if Warn_On_Export_Import then
8130 ("??unrecognized convention name, C assumed",
8131 Get_Pragma_Arg (Arg1));
8137 Check_Optional_Identifier (Arg2, Name_Entity);
8138 Check_Arg_Is_Local_Name (Arg2);
8140 Id := Get_Pragma_Arg (Arg2);
8143 if not Is_Entity_Name (Id) then
8144 Error_Pragma_Arg ("entity name required", Arg2);
8149 -- Set entity to return
8153 -- Ada_Pass_By_Copy special checking
8155 if C = Convention_Ada_Pass_By_Copy then
8156 if not Is_First_Subtype (E) then
8158 ("convention `Ada_Pass_By_Copy` only allowed for types",
8162 if Is_By_Reference_Type (E) then
8164 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8168 -- Ada_Pass_By_Reference special checking
8170 elsif C = Convention_Ada_Pass_By_Reference then
8171 if not Is_First_Subtype (E) then
8173 ("convention `Ada_Pass_By_Reference` only allowed for types",
8177 if Is_By_Copy_Type (E) then
8179 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8184 -- Go to renamed subprogram if present, since convention applies to
8185 -- the actual renamed entity, not to the renaming entity. If the
8186 -- subprogram is inherited, go to parent subprogram.
8188 if Is_Subprogram (E)
8189 and then Present (Alias (E))
8191 if Nkind (Parent (Declaration_Node (E))) =
8192 N_Subprogram_Renaming_Declaration
8194 if Scope (E) /= Scope (Alias (E)) then
8196 ("cannot apply pragma% to non-local entity&#", E);
8201 elsif Nkind (Parent (E)) in
8202 N_Full_Type_Declaration | N_Private_Extension_Declaration
8203 and then Scope (E) = Scope (Alias (E))
8207 -- Return the parent subprogram the entity was inherited from
8213 -- Check that we are not applying this to a specless body. Relax this
8214 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8216 if Is_Subprogram (E)
8217 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8218 and then not Relaxed_RM_Semantics
8221 ("pragma% requires separate spec and must come before body");
8224 -- Check that we are not applying this to a named constant
8226 if Ekind (E) in E_Named_Integer | E_Named_Real then
8227 Error_Msg_Name_1 := Pname;
8229 ("cannot apply pragma% to named constant!",
8230 Get_Pragma_Arg (Arg2));
8232 ("\supply appropriate type for&!", Arg2);
8235 if Ekind (E) = E_Enumeration_Literal then
8236 Error_Pragma ("enumeration literal not allowed for pragma%");
8239 -- Check for rep item appearing too early or too late
8241 if Etype (E) = Any_Type
8242 or else Rep_Item_Too_Early (E, N)
8246 elsif Present (Underlying_Type (E)) then
8247 E := Underlying_Type (E);
8250 if Rep_Item_Too_Late (E, N) then
8254 if Has_Convention_Pragma (E) then
8255 Diagnose_Multiple_Pragmas (E);
8257 elsif Convention (E) = Convention_Protected
8258 or else Ekind (Scope (E)) = E_Protected_Type
8261 ("a protected operation cannot be given a different convention",
8265 -- For Intrinsic, a subprogram is required
8267 if C = Convention_Intrinsic
8268 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8270 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8272 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8274 ("second argument of pragma% must be a subprogram", Arg2);
8277 -- Special checks for C_Variadic_n
8279 elsif C in Convention_C_Variadic then
8281 -- Several allowed cases
8283 if Is_Subprogram_Or_Generic_Subprogram (E) then
8286 -- An access to subprogram is also allowed
8288 elsif Is_Access_Type (E)
8289 and then Ekind (Designated_Type (E)) = E_Subprogram_Type
8291 Subp := Designated_Type (E);
8293 -- Allow internal call to set convention of subprogram type
8295 elsif Ekind (E) = E_Subprogram_Type then
8300 ("argument of pragma% must be subprogram or access type",
8305 -- ISO C requires a named parameter before the ellipsis, so a
8306 -- variadic C function taking 0 fixed parameter cannot exist.
8308 if C = Convention_C_Variadic_0 then
8311 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8312 Get_Pragma_Arg (Arg2));
8314 -- Now check the number of parameters of the subprogram and give
8315 -- an error if it is lower than n.
8317 elsif Present (Subp) then
8319 Minimum : constant Nat :=
8320 Convention_Id'Pos (C) -
8321 Convention_Id'Pos (Convention_C_Variadic_0);
8328 Formal := First_Formal (Subp);
8329 while Present (Formal) loop
8331 Next_Formal (Formal);
8334 if Count < Minimum then
8335 Error_Msg_Uint_1 := UI_From_Int (Minimum);
8337 ("argument of pragma% must have at least"
8338 & "^ parameters", Arg2);
8343 -- Special checks for Stdcall
8345 elsif C = Convention_Stdcall then
8347 -- Several allowed cases
8349 if Is_Subprogram_Or_Generic_Subprogram (E)
8353 or else Ekind (E) = E_Variable
8355 -- A component as well. The entity does not have its Ekind
8356 -- set until the enclosing record declaration is fully
8359 or else Nkind (Parent (E)) = N_Component_Declaration
8361 -- An access to subprogram is also allowed
8365 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8367 -- Allow internal call to set convention of subprogram type
8369 or else Ekind (E) = E_Subprogram_Type
8375 ("argument of pragma% must be subprogram or access type",
8380 Set_Convention_From_Pragma (E);
8382 -- Deal with non-subprogram cases
8384 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8387 -- The pragma must apply to a first subtype, but it can also
8388 -- apply to a generic type in a generic formal part, in which
8389 -- case it will also appear in the corresponding instance.
8391 if Is_Generic_Type (E) or else In_Instance then
8394 Check_First_Subtype (Arg2);
8397 Set_Convention_From_Pragma (Base_Type (E));
8399 -- For access subprograms, we must set the convention on the
8400 -- internally generated directly designated type as well.
8402 if Ekind (E) = E_Access_Subprogram_Type then
8403 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8407 -- For the subprogram case, set proper convention for all homonyms
8408 -- in same scope and the same declarative part, i.e. the same
8409 -- compilation unit.
8412 -- Treat a pragma Import as an implicit body, and pragma import
8413 -- as implicit reference (for navigation in GNAT Studio).
8415 if Prag_Id = Pragma_Import then
8416 Generate_Reference (E, Id, 'b');
8418 -- For exported entities we restrict the generation of references
8419 -- to entities exported to foreign languages since entities
8420 -- exported to Ada do not provide further information to
8421 -- GNAT Studio and add undesired references to the output of the
8424 elsif Prag_Id = Pragma_Export
8425 and then Convention (E) /= Convention_Ada
8427 Generate_Reference (E, Id, 'i');
8430 -- If the pragma comes from an aspect, it only applies to the
8431 -- given entity, not its homonyms.
8433 if From_Aspect_Specification (N) then
8434 if C = Convention_Intrinsic
8435 and then Nkind (Ent) = N_Defining_Operator_Symbol
8437 if Is_Fixed_Point_Type (Etype (Ent))
8438 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8439 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8442 ("no intrinsic operator available for this fixed-point "
8445 ("\use expression functions with the desired "
8446 & "conversions made explicit", N);
8453 -- Otherwise Loop through the homonyms of the pragma argument's
8454 -- entity, an apply convention to those in the current scope.
8456 Comp_Unit := Get_Source_Unit (E);
8461 exit when No (E1) or else Scope (E1) /= Current_Scope;
8463 -- Ignore entry for which convention is already set
8465 if Has_Convention_Pragma (E1) then
8469 if Is_Subprogram (E1)
8470 and then Nkind (Parent (Declaration_Node (E1))) =
8472 and then not Relaxed_RM_Semantics
8474 Set_Has_Completion (E); -- to prevent cascaded error
8476 ("pragma% requires separate spec and must come before "
8480 -- Do not set the pragma on inherited operations or on formal
8483 if Comes_From_Source (E1)
8484 and then Comp_Unit = Get_Source_Unit (E1)
8485 and then not Is_Formal_Subprogram (E1)
8486 and then Nkind (Original_Node (Parent (E1))) /=
8487 N_Full_Type_Declaration
8489 if Present (Alias (E1))
8490 and then Scope (E1) /= Scope (Alias (E1))
8493 ("cannot apply pragma% to non-local entity& declared#",
8497 Set_Convention_From_Pragma (E1);
8499 if Prag_Id = Pragma_Import then
8500 Generate_Reference (E1, Id, 'b');
8508 end Process_Convention;
8510 ----------------------------------------
8511 -- Process_Disable_Enable_Atomic_Sync --
8512 ----------------------------------------
8514 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8516 Check_No_Identifiers;
8517 Check_At_Most_N_Arguments (1);
8519 -- Modeled internally as
8520 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8525 Pragma_Argument_Associations => New_List (
8526 Make_Pragma_Argument_Association (Loc,
8528 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8530 if Present (Arg1) then
8531 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8535 end Process_Disable_Enable_Atomic_Sync;
8537 -------------------------------------------------
8538 -- Process_Extended_Import_Export_Internal_Arg --
8539 -------------------------------------------------
8541 procedure Process_Extended_Import_Export_Internal_Arg
8542 (Arg_Internal : Node_Id := Empty)
8545 if No (Arg_Internal) then
8546 Error_Pragma ("Internal parameter required for pragma%");
8549 if Nkind (Arg_Internal) = N_Identifier then
8552 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8553 and then (Prag_Id = Pragma_Import_Function
8555 Prag_Id = Pragma_Export_Function)
8561 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8564 Check_Arg_Is_Local_Name (Arg_Internal);
8565 end Process_Extended_Import_Export_Internal_Arg;
8567 --------------------------------------------------
8568 -- Process_Extended_Import_Export_Object_Pragma --
8569 --------------------------------------------------
8571 procedure Process_Extended_Import_Export_Object_Pragma
8572 (Arg_Internal : Node_Id;
8573 Arg_External : Node_Id;
8579 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8580 Def_Id := Entity (Arg_Internal);
8582 if Ekind (Def_Id) not in E_Constant | E_Variable then
8584 ("pragma% must designate an object", Arg_Internal);
8587 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8589 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8592 ("previous Common/Psect_Object applies, pragma % not permitted",
8596 if Rep_Item_Too_Late (Def_Id, N) then
8600 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8602 if Present (Arg_Size) then
8603 Check_Arg_Is_External_Name (Arg_Size);
8606 -- Export_Object case
8608 if Prag_Id = Pragma_Export_Object then
8609 if not Is_Library_Level_Entity (Def_Id) then
8611 ("argument for pragma% must be library level entity",
8615 if Ekind (Current_Scope) = E_Generic_Package then
8616 Error_Pragma ("pragma& cannot appear in a generic unit");
8619 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8621 ("exported object must have compile time known size",
8625 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8626 Error_Msg_N ("??duplicate Export_Object pragma", N);
8628 Set_Exported (Def_Id, Arg_Internal);
8631 -- Import_Object case
8634 if Is_Concurrent_Type (Etype (Def_Id)) then
8636 ("cannot use pragma% for task/protected object",
8640 if Ekind (Def_Id) = E_Constant then
8642 ("cannot import a constant", Arg_Internal);
8645 if Warn_On_Export_Import
8646 and then Has_Discriminants (Etype (Def_Id))
8649 ("imported value must be initialized??", Arg_Internal);
8652 if Warn_On_Export_Import
8653 and then Is_Access_Type (Etype (Def_Id))
8656 ("cannot import object of an access type??", Arg_Internal);
8659 if Warn_On_Export_Import
8660 and then Is_Imported (Def_Id)
8662 Error_Msg_N ("??duplicate Import_Object pragma", N);
8664 -- Check for explicit initialization present. Note that an
8665 -- initialization generated by the code generator, e.g. for an
8666 -- access type, does not count here.
8668 elsif Present (Expression (Parent (Def_Id)))
8671 (Original_Node (Expression (Parent (Def_Id))))
8673 Error_Msg_Sloc := Sloc (Def_Id);
8675 ("imported entities cannot be initialized (RM B.1(24))",
8676 "\no initialization allowed for & declared#", Arg1);
8678 Set_Imported (Def_Id);
8679 Note_Possible_Modification (Arg_Internal, Sure => False);
8682 end Process_Extended_Import_Export_Object_Pragma;
8684 ------------------------------------------------------
8685 -- Process_Extended_Import_Export_Subprogram_Pragma --
8686 ------------------------------------------------------
8688 procedure Process_Extended_Import_Export_Subprogram_Pragma
8689 (Arg_Internal : Node_Id;
8690 Arg_External : Node_Id;
8691 Arg_Parameter_Types : Node_Id;
8692 Arg_Result_Type : Node_Id := Empty;
8693 Arg_Mechanism : Node_Id;
8694 Arg_Result_Mechanism : Node_Id := Empty)
8700 Ambiguous : Boolean;
8703 function Same_Base_Type
8705 Formal : Entity_Id) return Boolean;
8706 -- Determines if Ptype references the type of Formal. Note that only
8707 -- the base types need to match according to the spec. Ptype here is
8708 -- the argument from the pragma, which is either a type name, or an
8709 -- access attribute.
8711 --------------------
8712 -- Same_Base_Type --
8713 --------------------
8715 function Same_Base_Type
8717 Formal : Entity_Id) return Boolean
8719 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8723 -- Case where pragma argument is typ'Access
8725 if Nkind (Ptype) = N_Attribute_Reference
8726 and then Attribute_Name (Ptype) = Name_Access
8728 Pref := Prefix (Ptype);
8731 if not Is_Entity_Name (Pref)
8732 or else Entity (Pref) = Any_Type
8737 -- We have a match if the corresponding argument is of an
8738 -- anonymous access type, and its designated type matches the
8739 -- type of the prefix of the access attribute
8741 return Ekind (Ftyp) = E_Anonymous_Access_Type
8742 and then Base_Type (Entity (Pref)) =
8743 Base_Type (Etype (Designated_Type (Ftyp)));
8745 -- Case where pragma argument is a type name
8750 if not Is_Entity_Name (Ptype)
8751 or else Entity (Ptype) = Any_Type
8756 -- We have a match if the corresponding argument is of the type
8757 -- given in the pragma (comparing base types)
8759 return Base_Type (Entity (Ptype)) = Ftyp;
8763 -- Start of processing for
8764 -- Process_Extended_Import_Export_Subprogram_Pragma
8767 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8771 -- Loop through homonyms (overloadings) of the entity
8773 Hom_Id := Entity (Arg_Internal);
8774 while Present (Hom_Id) loop
8775 Def_Id := Get_Base_Subprogram (Hom_Id);
8777 -- We need a subprogram in the current scope
8779 if not Is_Subprogram (Def_Id)
8780 or else Scope (Def_Id) /= Current_Scope
8787 -- Pragma cannot apply to subprogram body
8789 if Is_Subprogram (Def_Id)
8790 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8794 ("pragma% requires separate spec and must come before "
8798 -- Test result type if given, note that the result type
8799 -- parameter can only be present for the function cases.
8801 if Present (Arg_Result_Type)
8802 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8806 elsif Etype (Def_Id) /= Standard_Void_Type
8808 Pname in Name_Export_Procedure | Name_Import_Procedure
8812 -- Test parameter types if given. Note that this parameter has
8813 -- not been analyzed (and must not be, since it is semantic
8814 -- nonsense), so we get it as the parser left it.
8816 elsif Present (Arg_Parameter_Types) then
8817 Check_Matching_Types : declare
8822 Formal := First_Formal (Def_Id);
8824 if Nkind (Arg_Parameter_Types) = N_Null then
8825 if Present (Formal) then
8829 -- A list of one type, e.g. (List) is parsed as a
8830 -- parenthesized expression.
8832 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8833 and then Paren_Count (Arg_Parameter_Types) = 1
8836 or else Present (Next_Formal (Formal))
8841 Same_Base_Type (Arg_Parameter_Types, Formal);
8844 -- A list of more than one type is parsed as a aggregate
8846 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8847 and then Paren_Count (Arg_Parameter_Types) = 0
8849 Ptype := First (Expressions (Arg_Parameter_Types));
8850 while Present (Ptype) or else Present (Formal) loop
8853 or else not Same_Base_Type (Ptype, Formal)
8858 Next_Formal (Formal);
8863 -- Anything else is of the wrong form
8867 ("wrong form for Parameter_Types parameter",
8868 Arg_Parameter_Types);
8870 end Check_Matching_Types;
8873 -- Match is now False if the entry we found did not match
8874 -- either a supplied Parameter_Types or Result_Types argument
8880 -- Ambiguous case, the flag Ambiguous shows if we already
8881 -- detected this and output the initial messages.
8884 if not Ambiguous then
8886 Error_Msg_Name_1 := Pname;
8888 ("pragma% does not uniquely identify subprogram!",
8890 Error_Msg_Sloc := Sloc (Ent);
8891 Error_Msg_N ("matching subprogram #!", N);
8895 Error_Msg_Sloc := Sloc (Def_Id);
8896 Error_Msg_N ("matching subprogram #!", N);
8901 Hom_Id := Homonym (Hom_Id);
8904 -- See if we found an entry
8907 if not Ambiguous then
8908 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8910 ("pragma% cannot be given for generic subprogram");
8913 ("pragma% does not identify local subprogram");
8920 -- Import pragmas must be for imported entities
8922 if Prag_Id = Pragma_Import_Function
8924 Prag_Id = Pragma_Import_Procedure
8926 Prag_Id = Pragma_Import_Valued_Procedure
8928 if not Is_Imported (Ent) then
8930 ("pragma Import or Interface must precede pragma%");
8933 -- Here we have the Export case which can set the entity as exported
8935 -- But does not do so if the specified external name is null, since
8936 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8937 -- compatible) to request no external name.
8939 elsif Nkind (Arg_External) = N_String_Literal
8940 and then String_Length (Strval (Arg_External)) = 0
8944 -- In all other cases, set entity as exported
8947 Set_Exported (Ent, Arg_Internal);
8950 -- Special processing for Valued_Procedure cases
8952 if Prag_Id = Pragma_Import_Valued_Procedure
8954 Prag_Id = Pragma_Export_Valued_Procedure
8956 Formal := First_Formal (Ent);
8959 Error_Pragma ("at least one parameter required for pragma%");
8961 elsif Ekind (Formal) /= E_Out_Parameter then
8962 Error_Pragma ("first parameter must have mode out for pragma%");
8965 Set_Is_Valued_Procedure (Ent);
8969 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8971 -- Process Result_Mechanism argument if present. We have already
8972 -- checked that this is only allowed for the function case.
8974 if Present (Arg_Result_Mechanism) then
8975 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8978 -- Process Mechanism parameter if present. Note that this parameter
8979 -- is not analyzed, and must not be analyzed since it is semantic
8980 -- nonsense, so we get it in exactly as the parser left it.
8982 if Present (Arg_Mechanism) then
8990 -- A single mechanism association without a formal parameter
8991 -- name is parsed as a parenthesized expression. All other
8992 -- cases are parsed as aggregates, so we rewrite the single
8993 -- parameter case as an aggregate for consistency.
8995 if Nkind (Arg_Mechanism) /= N_Aggregate
8996 and then Paren_Count (Arg_Mechanism) = 1
8998 Rewrite (Arg_Mechanism,
8999 Make_Aggregate (Sloc (Arg_Mechanism),
9000 Expressions => New_List (
9001 Relocate_Node (Arg_Mechanism))));
9004 -- Case of only mechanism name given, applies to all formals
9006 if Nkind (Arg_Mechanism) /= N_Aggregate then
9007 Formal := First_Formal (Ent);
9008 while Present (Formal) loop
9009 Set_Mechanism_Value (Formal, Arg_Mechanism);
9010 Next_Formal (Formal);
9013 -- Case of list of mechanism associations given
9016 if Null_Record_Present (Arg_Mechanism) then
9018 ("inappropriate form for Mechanism parameter",
9022 -- Deal with positional ones first
9024 Formal := First_Formal (Ent);
9026 if Present (Expressions (Arg_Mechanism)) then
9027 Mname := First (Expressions (Arg_Mechanism));
9028 while Present (Mname) loop
9031 ("too many mechanism associations", Mname);
9034 Set_Mechanism_Value (Formal, Mname);
9035 Next_Formal (Formal);
9040 -- Deal with named entries
9042 if Present (Component_Associations (Arg_Mechanism)) then
9043 Massoc := First (Component_Associations (Arg_Mechanism));
9044 while Present (Massoc) loop
9045 Choice := First (Choices (Massoc));
9047 if Nkind (Choice) /= N_Identifier
9048 or else Present (Next (Choice))
9051 ("incorrect form for mechanism association",
9055 Formal := First_Formal (Ent);
9059 ("parameter name & not present", Choice);
9062 if Chars (Choice) = Chars (Formal) then
9064 (Formal, Expression (Massoc));
9066 -- Set entity on identifier for proper tree
9069 Set_Entity (Choice, Formal);
9074 Next_Formal (Formal);
9083 end Process_Extended_Import_Export_Subprogram_Pragma;
9085 --------------------------
9086 -- Process_Generic_List --
9087 --------------------------
9089 procedure Process_Generic_List is
9094 Check_No_Identifiers;
9095 Check_At_Least_N_Arguments (1);
9097 -- Check all arguments are names of generic units or instances
9100 while Present (Arg) loop
9101 Exp := Get_Pragma_Arg (Arg);
9104 if not Is_Entity_Name (Exp)
9106 (not Is_Generic_Instance (Entity (Exp))
9108 not Is_Generic_Unit (Entity (Exp)))
9111 ("pragma% argument must be name of generic unit/instance",
9117 end Process_Generic_List;
9119 ------------------------------------
9120 -- Process_Import_Predefined_Type --
9121 ------------------------------------
9123 procedure Process_Import_Predefined_Type is
9124 Loc : constant Source_Ptr := Sloc (N);
9126 Ftyp : Node_Id := Empty;
9132 Nam := String_To_Name (Strval (Expression (Arg3)));
9134 Elmt := First_Elmt (Predefined_Float_Types);
9135 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9139 Ftyp := Node (Elmt);
9141 if Present (Ftyp) then
9143 -- Don't build a derived type declaration, because predefined C
9144 -- types have no declaration anywhere, so cannot really be named.
9145 -- Instead build a full type declaration, starting with an
9146 -- appropriate type definition is built
9148 if Is_Floating_Point_Type (Ftyp) then
9149 Def := Make_Floating_Point_Definition (Loc,
9150 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9151 Make_Real_Range_Specification (Loc,
9152 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9153 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9155 -- Should never have a predefined type we cannot handle
9158 raise Program_Error;
9161 -- Build and insert a Full_Type_Declaration, which will be
9162 -- analyzed as soon as this list entry has been analyzed.
9164 Decl := Make_Full_Type_Declaration (Loc,
9165 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9166 Type_Definition => Def);
9168 Insert_After (N, Decl);
9169 Mark_Rewrite_Insertion (Decl);
9172 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9174 end Process_Import_Predefined_Type;
9176 ---------------------------------
9177 -- Process_Import_Or_Interface --
9178 ---------------------------------
9180 procedure Process_Import_Or_Interface is
9186 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9187 -- pragma Import (Entity, "external name");
9189 if Relaxed_RM_Semantics
9190 and then Arg_Count = 2
9191 and then Prag_Id = Pragma_Import
9192 and then Nkind (Expression (Arg2)) = N_String_Literal
9195 Def_Id := Get_Pragma_Arg (Arg1);
9198 if not Is_Entity_Name (Def_Id) then
9199 Error_Pragma_Arg ("entity name required", Arg1);
9202 Def_Id := Entity (Def_Id);
9203 Kill_Size_Check_Code (Def_Id);
9204 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9207 Process_Convention (C, Def_Id);
9209 -- A pragma that applies to a Ghost entity becomes Ghost for the
9210 -- purposes of legality checks and removal of ignored Ghost code.
9212 Mark_Ghost_Pragma (N, Def_Id);
9213 Kill_Size_Check_Code (Def_Id);
9214 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9217 -- Various error checks
9219 if Ekind (Def_Id) in E_Variable | E_Constant then
9221 -- We do not permit Import to apply to a renaming declaration
9223 if Present (Renamed_Object (Def_Id)) then
9225 ("pragma% not allowed for object renaming", Arg2);
9227 -- User initialization is not allowed for imported object, but
9228 -- the object declaration may contain a default initialization,
9229 -- that will be discarded. Note that an explicit initialization
9230 -- only counts if it comes from source, otherwise it is simply
9231 -- the code generator making an implicit initialization explicit.
9233 elsif Present (Expression (Parent (Def_Id)))
9234 and then Comes_From_Source
9235 (Original_Node (Expression (Parent (Def_Id))))
9237 -- Set imported flag to prevent cascaded errors
9239 Set_Is_Imported (Def_Id);
9241 Error_Msg_Sloc := Sloc (Def_Id);
9243 ("no initialization allowed for declaration of& #",
9244 "\imported entities cannot be initialized (RM B.1(24))",
9248 -- If the pragma comes from an aspect specification the
9249 -- Is_Imported flag has already been set.
9251 if not From_Aspect_Specification (N) then
9252 Set_Imported (Def_Id);
9255 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9257 -- Note that we do not set Is_Public here. That's because we
9258 -- only want to set it if there is no address clause, and we
9259 -- don't know that yet, so we delay that processing till
9262 -- pragma Import completes deferred constants
9264 if Ekind (Def_Id) = E_Constant then
9265 Set_Has_Completion (Def_Id);
9268 -- It is not possible to import a constant of an unconstrained
9269 -- array type (e.g. string) because there is no simple way to
9270 -- write a meaningful subtype for it.
9272 if Is_Array_Type (Etype (Def_Id))
9273 and then not Is_Constrained (Etype (Def_Id))
9276 ("imported constant& must have a constrained subtype",
9281 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9283 -- If the name is overloaded, pragma applies to all of the denoted
9284 -- entities in the same declarative part, unless the pragma comes
9285 -- from an aspect specification or was generated by the compiler
9286 -- (such as for pragma Provide_Shift_Operators).
9289 while Present (Hom_Id) loop
9291 Def_Id := Get_Base_Subprogram (Hom_Id);
9293 -- Ignore inherited subprograms because the pragma will apply
9294 -- to the parent operation, which is the one called.
9296 if Is_Overloadable (Def_Id)
9297 and then Present (Alias (Def_Id))
9301 -- If it is not a subprogram, it must be in an outer scope and
9302 -- pragma does not apply.
9304 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9307 -- The pragma does not apply to primitives of interfaces
9309 elsif Is_Dispatching_Operation (Def_Id)
9310 and then Present (Find_Dispatching_Type (Def_Id))
9311 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9315 -- Verify that the homonym is in the same declarative part (not
9316 -- just the same scope). If the pragma comes from an aspect
9317 -- specification we know that it is part of the declaration.
9319 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9320 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9321 and then not From_Aspect_Specification (N)
9326 -- If the pragma comes from an aspect specification the
9327 -- Is_Imported flag has already been set.
9329 if not From_Aspect_Specification (N) then
9330 Set_Imported (Def_Id);
9333 -- Reject an Import applied to an abstract subprogram
9335 if Is_Subprogram (Def_Id)
9336 and then Is_Abstract_Subprogram (Def_Id)
9338 Error_Msg_Sloc := Sloc (Def_Id);
9340 ("cannot import abstract subprogram& declared#",
9344 -- Special processing for Convention_Intrinsic
9346 if C = Convention_Intrinsic then
9348 -- Link_Name argument not allowed for intrinsic
9352 Set_Is_Intrinsic_Subprogram (Def_Id);
9354 -- If no external name is present, then check that this
9355 -- is a valid intrinsic subprogram. If an external name
9356 -- is present, then this is handled by the back end.
9359 Check_Intrinsic_Subprogram
9360 (Def_Id, Get_Pragma_Arg (Arg2));
9364 -- Verify that the subprogram does not have a completion
9365 -- through a renaming declaration. For other completions the
9366 -- pragma appears as a too late representation.
9369 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9373 and then Nkind (Decl) = N_Subprogram_Declaration
9374 and then Present (Corresponding_Body (Decl))
9375 and then Nkind (Unit_Declaration_Node
9376 (Corresponding_Body (Decl))) =
9377 N_Subprogram_Renaming_Declaration
9379 Error_Msg_Sloc := Sloc (Def_Id);
9381 ("cannot import&, renaming already provided for "
9382 & "declaration #", N, Def_Id);
9386 -- If the pragma comes from an aspect specification, there
9387 -- must be an Import aspect specified as well. In the rare
9388 -- case where Import is set to False, the suprogram needs to
9389 -- have a local completion.
9392 Imp_Aspect : constant Node_Id :=
9393 Find_Aspect (Def_Id, Aspect_Import);
9397 if Present (Imp_Aspect)
9398 and then Present (Expression (Imp_Aspect))
9400 Expr := Expression (Imp_Aspect);
9401 Analyze_And_Resolve (Expr, Standard_Boolean);
9403 if Is_Entity_Name (Expr)
9404 and then Entity (Expr) = Standard_True
9406 Set_Has_Completion (Def_Id);
9409 -- If there is no expression, the default is True, as for
9410 -- all boolean aspects. Same for the older pragma.
9413 Set_Has_Completion (Def_Id);
9417 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9420 if Is_Compilation_Unit (Hom_Id) then
9422 -- Its possible homonyms are not affected by the pragma.
9423 -- Such homonyms might be present in the context of other
9424 -- units being compiled.
9428 elsif From_Aspect_Specification (N) then
9431 -- If the pragma was created by the compiler, then we don't
9432 -- want it to apply to other homonyms. This kind of case can
9433 -- occur when using pragma Provide_Shift_Operators, which
9434 -- generates implicit shift and rotate operators with Import
9435 -- pragmas that might apply to earlier explicit or implicit
9436 -- declarations marked with Import (for example, coming from
9437 -- an earlier pragma Provide_Shift_Operators for another type),
9438 -- and we don't generally want other homonyms being treated
9439 -- as imported or the pragma flagged as an illegal duplicate.
9441 elsif not Comes_From_Source (N) then
9445 Hom_Id := Homonym (Hom_Id);
9449 -- Import a CPP class
9451 elsif C = Convention_CPP
9452 and then (Is_Record_Type (Def_Id)
9453 or else Ekind (Def_Id) = E_Incomplete_Type)
9455 if Ekind (Def_Id) = E_Incomplete_Type then
9456 if Present (Full_View (Def_Id)) then
9457 Def_Id := Full_View (Def_Id);
9461 ("cannot import 'C'P'P type before full declaration seen",
9462 Get_Pragma_Arg (Arg2));
9464 -- Although we have reported the error we decorate it as
9465 -- CPP_Class to avoid reporting spurious errors
9467 Set_Is_CPP_Class (Def_Id);
9472 -- Types treated as CPP classes must be declared limited (note:
9473 -- this used to be a warning but there is no real benefit to it
9474 -- since we did effectively intend to treat the type as limited
9477 if not Is_Limited_Type (Def_Id) then
9479 ("imported 'C'P'P type must be limited",
9480 Get_Pragma_Arg (Arg2));
9483 if Etype (Def_Id) /= Def_Id
9484 and then not Is_CPP_Class (Root_Type (Def_Id))
9486 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9489 Set_Is_CPP_Class (Def_Id);
9491 -- Imported CPP types must not have discriminants (because C++
9492 -- classes do not have discriminants).
9494 if Has_Discriminants (Def_Id) then
9496 ("imported 'C'P'P type cannot have discriminants",
9497 First (Discriminant_Specifications
9498 (Declaration_Node (Def_Id))));
9501 -- Check that components of imported CPP types do not have default
9502 -- expressions. For private types this check is performed when the
9503 -- full view is analyzed (see Process_Full_View).
9505 if not Is_Private_Type (Def_Id) then
9506 Check_CPP_Type_Has_No_Defaults (Def_Id);
9509 -- Import a CPP exception
9511 elsif C = Convention_CPP
9512 and then Ekind (Def_Id) = E_Exception
9516 ("'External_'Name arguments is required for 'Cpp exception",
9519 -- As only a string is allowed, Check_Arg_Is_External_Name
9522 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9525 if Present (Arg4) then
9527 ("Link_Name argument not allowed for imported Cpp exception",
9531 -- Do not call Set_Interface_Name as the name of the exception
9532 -- shouldn't be modified (and in particular it shouldn't be
9533 -- the External_Name). For exceptions, the External_Name is the
9534 -- name of the RTTI structure.
9536 -- ??? Emit an error if pragma Import/Export_Exception is present
9538 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9540 Check_Arg_Count (3);
9541 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9543 Process_Import_Predefined_Type;
9547 ("second argument of pragma% must be object, subprogram "
9548 & "or incomplete type",
9552 -- If this pragma applies to a compilation unit, then the unit, which
9553 -- is a subprogram, does not require (or allow) a body. We also do
9554 -- not need to elaborate imported procedures.
9556 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9558 Cunit : constant Node_Id := Parent (Parent (N));
9560 Set_Body_Required (Cunit, False);
9563 end Process_Import_Or_Interface;
9565 --------------------
9566 -- Process_Inline --
9567 --------------------
9569 procedure Process_Inline (Status : Inline_Status) is
9576 Ghost_Error_Posted : Boolean := False;
9577 -- Flag set when an error concerning the illegal mix of Ghost and
9578 -- non-Ghost subprograms is emitted.
9580 Ghost_Id : Entity_Id := Empty;
9581 -- The entity of the first Ghost subprogram encountered while
9582 -- processing the arguments of the pragma.
9584 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9585 -- Verify the placement of pragma Inline_Always with respect to the
9586 -- initial declaration of subprogram Spec_Id.
9588 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9589 -- Returns True if it can be determined at this stage that inlining
9590 -- is not possible, for example if the body is available and contains
9591 -- exception handlers, we prevent inlining, since otherwise we can
9592 -- get undefined symbols at link time. This function also emits a
9593 -- warning if the pragma appears too late.
9595 -- ??? is business with link symbols still valid, or does it relate
9596 -- to front end ZCX which is being phased out ???
9598 procedure Make_Inline (Subp : Entity_Id);
9599 -- Subp is the defining unit name of the subprogram declaration. If
9600 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9601 -- the corresponding body, if there is one present.
9603 procedure Set_Inline_Flags (Subp : Entity_Id);
9604 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9605 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9607 -----------------------------------
9608 -- Check_Inline_Always_Placement --
9609 -----------------------------------
9611 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9612 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9614 function Compilation_Unit_OK return Boolean;
9615 pragma Inline (Compilation_Unit_OK);
9616 -- Determine whether pragma Inline_Always applies to a compatible
9617 -- compilation unit denoted by Spec_Id.
9619 function Declarative_List_OK return Boolean;
9620 pragma Inline (Declarative_List_OK);
9621 -- Determine whether the initial declaration of subprogram Spec_Id
9622 -- and the pragma appear in compatible declarative lists.
9624 function Subprogram_Body_OK return Boolean;
9625 pragma Inline (Subprogram_Body_OK);
9626 -- Determine whether pragma Inline_Always applies to a compatible
9627 -- subprogram body denoted by Spec_Id.
9629 -------------------------
9630 -- Compilation_Unit_OK --
9631 -------------------------
9633 function Compilation_Unit_OK return Boolean is
9634 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9637 -- The pragma appears after the initial declaration of a
9638 -- compilation unit.
9640 -- procedure Comp_Unit;
9641 -- pragma Inline_Always (Comp_Unit);
9643 -- Note that for compatibility reasons, the following case is
9646 -- procedure Stand_Alone_Body_Comp_Unit is
9648 -- end Stand_Alone_Body_Comp_Unit;
9649 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9652 Nkind (Comp_Unit) = N_Compilation_Unit
9653 and then Present (Aux_Decls_Node (Comp_Unit))
9654 and then Is_List_Member (N)
9655 and then List_Containing (N) =
9656 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9657 end Compilation_Unit_OK;
9659 -------------------------
9660 -- Declarative_List_OK --
9661 -------------------------
9663 function Declarative_List_OK return Boolean is
9664 Context : constant Node_Id := Parent (Spec_Decl);
9666 Init_Decl : Node_Id;
9667 Init_List : List_Id;
9668 Prag_List : List_Id;
9671 -- Determine the proper initial declaration. In general this is
9672 -- the declaration node of the subprogram except when the input
9673 -- denotes a generic instantiation.
9675 -- procedure Inst is new Gen;
9676 -- pragma Inline_Always (Inst);
9678 -- In this case the original subprogram is moved inside an
9679 -- anonymous package while pragma Inline_Always remains at the
9680 -- level of the anonymous package. Use the declaration of the
9681 -- package because it reflects the placement of the original
9684 -- package Anon_Pack is
9685 -- procedure Inst is ... end Inst; -- original
9688 -- procedure Inst renames Anon_Pack.Inst;
9689 -- pragma Inline_Always (Inst);
9691 if Is_Generic_Instance (Spec_Id) then
9692 Init_Decl := Parent (Parent (Spec_Decl));
9693 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9695 Init_Decl := Spec_Decl;
9698 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9699 Init_List := List_Containing (Init_Decl);
9700 Prag_List := List_Containing (N);
9702 -- The pragma and then initial declaration appear within the
9703 -- same declarative list.
9705 if Init_List = Prag_List then
9708 -- A special case of the above is when both the pragma and
9709 -- the initial declaration appear in different lists of a
9710 -- package spec, protected definition, or a task definition.
9715 -- pragma Inline_Always (Proc);
9718 elsif Nkind (Context) in N_Package_Specification
9719 | N_Protected_Definition
9721 and then Init_List = Visible_Declarations (Context)
9722 and then Prag_List = Private_Declarations (Context)
9729 end Declarative_List_OK;
9731 ------------------------
9732 -- Subprogram_Body_OK --
9733 ------------------------
9735 function Subprogram_Body_OK return Boolean is
9736 Body_Decl : Node_Id;
9739 -- The pragma appears within the declarative list of a stand-
9740 -- alone subprogram body.
9742 -- procedure Stand_Alone_Body is
9743 -- pragma Inline_Always (Stand_Alone_Body);
9746 -- end Stand_Alone_Body;
9748 -- The compiler creates a dummy spec in this case, however the
9749 -- pragma remains within the declarative list of the body.
9751 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9752 and then not Comes_From_Source (Spec_Decl)
9753 and then Present (Corresponding_Body (Spec_Decl))
9756 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9758 if Present (Declarations (Body_Decl))
9759 and then Is_List_Member (N)
9760 and then List_Containing (N) = Declarations (Body_Decl)
9767 end Subprogram_Body_OK;
9769 -- Start of processing for Check_Inline_Always_Placement
9772 -- This check is relevant only for pragma Inline_Always
9774 if Pname /= Name_Inline_Always then
9777 -- Nothing to do when the pragma is internally generated on the
9778 -- assumption that it is properly placed.
9780 elsif not Comes_From_Source (N) then
9783 -- Nothing to do for internally generated subprograms that act
9784 -- as accidental homonyms of a source subprogram being inlined.
9786 elsif not Comes_From_Source (Spec_Id) then
9789 -- Nothing to do for generic formal subprograms that act as
9790 -- homonyms of another source subprogram being inlined.
9792 elsif Is_Formal_Subprogram (Spec_Id) then
9795 elsif Compilation_Unit_OK
9796 or else Declarative_List_OK
9797 or else Subprogram_Body_OK
9802 -- At this point it is known that the pragma applies to or appears
9803 -- within a completing body, a completing stub, or a subunit.
9805 Error_Msg_Name_1 := Pname;
9806 Error_Msg_Name_2 := Chars (Spec_Id);
9807 Error_Msg_Sloc := Sloc (Spec_Id);
9810 ("pragma % must appear on initial declaration of subprogram "
9811 & "% defined #", N);
9812 end Check_Inline_Always_Placement;
9814 ---------------------------
9815 -- Inlining_Not_Possible --
9816 ---------------------------
9818 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9819 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9823 if Nkind (Decl) = N_Subprogram_Body then
9824 Stats := Handled_Statement_Sequence (Decl);
9825 return Present (Exception_Handlers (Stats))
9826 or else Present (At_End_Proc (Stats));
9828 elsif Nkind (Decl) = N_Subprogram_Declaration
9829 and then Present (Corresponding_Body (Decl))
9831 if Analyzed (Corresponding_Body (Decl)) then
9832 Error_Msg_N ("pragma appears too late, ignored??", N);
9835 -- If the subprogram is a renaming as body, the body is just a
9836 -- call to the renamed subprogram, and inlining is trivially
9840 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9841 N_Subprogram_Renaming_Declaration
9847 Handled_Statement_Sequence
9848 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9851 Present (Exception_Handlers (Stats))
9852 or else Present (At_End_Proc (Stats));
9856 -- If body is not available, assume the best, the check is
9857 -- performed again when compiling enclosing package bodies.
9861 end Inlining_Not_Possible;
9867 procedure Make_Inline (Subp : Entity_Id) is
9868 Kind : constant Entity_Kind := Ekind (Subp);
9869 Inner_Subp : Entity_Id := Subp;
9872 -- Ignore if bad type, avoid cascaded error
9874 if Etype (Subp) = Any_Type then
9878 -- If inlining is not possible, for now do not treat as an error
9880 elsif Status /= Suppressed
9881 and then Front_End_Inlining
9882 and then Inlining_Not_Possible (Subp)
9887 -- Here we have a candidate for inlining, but we must exclude
9888 -- derived operations. Otherwise we would end up trying to inline
9889 -- a phantom declaration, and the result would be to drag in a
9890 -- body which has no direct inlining associated with it. That
9891 -- would not only be inefficient but would also result in the
9892 -- backend doing cross-unit inlining in cases where it was
9893 -- definitely inappropriate to do so.
9895 -- However, a simple Comes_From_Source test is insufficient, since
9896 -- we do want to allow inlining of generic instances which also do
9897 -- not come from source. We also need to recognize specs generated
9898 -- by the front-end for bodies that carry the pragma. Finally,
9899 -- predefined operators do not come from source but are not
9900 -- inlineable either.
9902 elsif Is_Generic_Instance (Subp)
9903 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9907 elsif not Comes_From_Source (Subp)
9908 and then Scope (Subp) /= Standard_Standard
9914 -- The referenced entity must either be the enclosing entity, or
9915 -- an entity declared within the current open scope.
9917 if Present (Scope (Subp))
9918 and then Scope (Subp) /= Current_Scope
9919 and then Subp /= Current_Scope
9922 ("argument of% must be entity in current scope", Assoc);
9926 -- Processing for procedure, operator or function. If subprogram
9927 -- is aliased (as for an instance) indicate that the renamed
9928 -- entity (if declared in the same unit) is inlined.
9929 -- If this is the anonymous subprogram created for a subprogram
9930 -- instance, the inlining applies to it directly. Otherwise we
9931 -- retrieve it as the alias of the visible subprogram instance.
9933 if Is_Subprogram (Subp) then
9935 -- Ensure that pragma Inline_Always is associated with the
9936 -- initial declaration of the subprogram.
9938 Check_Inline_Always_Placement (Subp);
9940 if Is_Wrapper_Package (Scope (Subp)) then
9943 Inner_Subp := Ultimate_Alias (Inner_Subp);
9946 if In_Same_Source_Unit (Subp, Inner_Subp) then
9947 Set_Inline_Flags (Inner_Subp);
9949 Decl := Parent (Parent (Inner_Subp));
9951 if Nkind (Decl) = N_Subprogram_Declaration
9952 and then Present (Corresponding_Body (Decl))
9954 Set_Inline_Flags (Corresponding_Body (Decl));
9956 elsif Is_Generic_Instance (Subp)
9957 and then Comes_From_Source (Subp)
9959 -- Indicate that the body needs to be created for
9960 -- inlining subsequent calls. The instantiation node
9961 -- follows the declaration of the wrapper package
9962 -- created for it. The subprogram that requires the
9963 -- body is the anonymous one in the wrapper package.
9965 if Scope (Subp) /= Standard_Standard
9967 Need_Subprogram_Instance_Body
9968 (Next (Unit_Declaration_Node
9969 (Scope (Alias (Subp)))), Subp)
9974 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9975 -- appear in a formal part to apply to a formal subprogram.
9976 -- Do not apply check within an instance or a formal package
9977 -- the test will have been applied to the original generic.
9979 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9980 and then List_Containing (Decl) = List_Containing (N)
9981 and then not In_Instance
9984 ("Inline cannot apply to a formal subprogram", N);
9990 -- For a generic subprogram set flag as well, for use at the point
9991 -- of instantiation, to determine whether the body should be
9994 elsif Is_Generic_Subprogram (Subp) then
9995 Set_Inline_Flags (Subp);
9998 -- Literals are by definition inlined
10000 elsif Kind = E_Enumeration_Literal then
10003 -- Anything else is an error
10007 ("expect subprogram name for pragma%", Assoc);
10011 ----------------------
10012 -- Set_Inline_Flags --
10013 ----------------------
10015 procedure Set_Inline_Flags (Subp : Entity_Id) is
10017 -- First set the Has_Pragma_XXX flags and issue the appropriate
10018 -- errors and warnings for suspicious combinations.
10020 if Prag_Id = Pragma_No_Inline then
10021 if Has_Pragma_Inline_Always (Subp) then
10023 ("Inline_Always and No_Inline are mutually exclusive", N);
10024 elsif Has_Pragma_Inline (Subp) then
10026 ("Inline and No_Inline both specified for& ??",
10027 N, Entity (Subp_Id));
10030 Set_Has_Pragma_No_Inline (Subp);
10032 if Prag_Id = Pragma_Inline_Always then
10033 if Has_Pragma_No_Inline (Subp) then
10035 ("Inline_Always and No_Inline are mutually exclusive",
10039 Set_Has_Pragma_Inline_Always (Subp);
10041 if Has_Pragma_No_Inline (Subp) then
10043 ("Inline and No_Inline both specified for& ??",
10044 N, Entity (Subp_Id));
10048 Set_Has_Pragma_Inline (Subp);
10051 -- Then adjust the Is_Inlined flag. It can never be set if the
10052 -- subprogram is subject to pragma No_Inline.
10056 Set_Is_Inlined (Subp, False);
10062 if not Has_Pragma_No_Inline (Subp) then
10063 Set_Is_Inlined (Subp, True);
10067 -- A pragma that applies to a Ghost entity becomes Ghost for the
10068 -- purposes of legality checks and removal of ignored Ghost code.
10070 Mark_Ghost_Pragma (N, Subp);
10072 -- Capture the entity of the first Ghost subprogram being
10073 -- processed for error detection purposes.
10075 if Is_Ghost_Entity (Subp) then
10076 if No (Ghost_Id) then
10080 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10081 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10083 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
10084 Ghost_Error_Posted := True;
10086 Error_Msg_Name_1 := Pname;
10088 ("pragma % cannot mention ghost and non-ghost subprograms",
10091 Error_Msg_Sloc := Sloc (Ghost_Id);
10092 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10094 Error_Msg_Sloc := Sloc (Subp);
10095 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10097 end Set_Inline_Flags;
10099 -- Start of processing for Process_Inline
10102 -- An inlined subprogram may grant access to its private enclosing
10103 -- context depending on the placement of its body. From elaboration
10104 -- point of view, the flow of execution may enter this private
10105 -- context, and then reach an external unit, thus producing a
10106 -- dependency on that external unit. For such a path to be properly
10107 -- discovered and encoded in the ALI file of the main unit, let the
10108 -- ABE mechanism process the body of the main unit, and encode all
10109 -- relevant invocation constructs and the relations between them.
10111 Mark_Save_Invocation_Graph_Of_Body;
10113 Check_No_Identifiers;
10114 Check_At_Least_N_Arguments (1);
10116 if Status = Enabled then
10117 Inline_Processing_Required := True;
10121 while Present (Assoc) loop
10122 Subp_Id := Get_Pragma_Arg (Assoc);
10126 if Is_Entity_Name (Subp_Id) then
10127 Subp := Entity (Subp_Id);
10129 if Subp = Any_Id then
10131 -- If previous error, avoid cascaded errors
10133 Check_Error_Detected;
10137 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10138 -- is given that directly specifies an aspect of an entity,
10139 -- then it is illegal to give another [...]
10140 -- aspect_specification that directly specifies the same
10141 -- aspect of the entity.
10142 -- We only check Subp directly as per "directly specifies"
10143 -- above and because the case of pragma Inline is really
10144 -- special given its pre aspect usage.
10146 Check_Duplicate_Pragma (Subp);
10147 Record_Rep_Item (Subp, N);
10149 Make_Inline (Subp);
10151 -- For the pragma case, climb homonym chain. This is
10152 -- what implements allowing the pragma in the renaming
10153 -- case, with the result applying to the ancestors, and
10154 -- also allows Inline to apply to all previous homonyms.
10156 if not From_Aspect_Specification (N) then
10157 while Present (Homonym (Subp))
10158 and then Scope (Homonym (Subp)) = Current_Scope
10160 Subp := Homonym (Subp);
10161 Make_Inline (Subp);
10167 if not Applies then
10168 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10174 -- If the context is a package declaration, the pragma indicates
10175 -- that inlining will require the presence of the corresponding
10176 -- body. (this may be further refined).
10179 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10180 N_Package_Declaration
10182 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10184 end Process_Inline;
10186 ----------------------------
10187 -- Process_Interface_Name --
10188 ----------------------------
10190 procedure Process_Interface_Name
10191 (Subprogram_Def : Entity_Id;
10193 Link_Arg : Node_Id;
10197 Link_Nam : Node_Id;
10198 String_Val : String_Id;
10200 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10201 -- SN is a string literal node for an interface name. This routine
10202 -- performs some minimal checks that the name is reasonable. In
10203 -- particular that no spaces or other obviously incorrect characters
10204 -- appear. This is only a warning, since any characters are allowed.
10206 ----------------------------------
10207 -- Check_Form_Of_Interface_Name --
10208 ----------------------------------
10210 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10211 S : constant String_Id := Strval (Expr_Value_S (SN));
10212 SL : constant Nat := String_Length (S);
10217 Error_Msg_N ("interface name cannot be null string", SN);
10220 for J in 1 .. SL loop
10221 C := Get_String_Char (S, J);
10223 -- Look for dubious character and issue unconditional warning.
10224 -- Definitely dubious if not in character range.
10226 if not In_Character_Range (C)
10228 -- Commas, spaces and (back)slashes are dubious
10230 or else Get_Character (C) = ','
10231 or else Get_Character (C) = '\'
10232 or else Get_Character (C) = ' '
10233 or else Get_Character (C) = '/'
10236 ("??interface name contains illegal character",
10237 Sloc (SN) + Source_Ptr (J));
10240 end Check_Form_Of_Interface_Name;
10242 -- Start of processing for Process_Interface_Name
10245 -- If we are looking at a pragma that comes from an aspect then it
10246 -- needs to have its corresponding aspect argument expressions
10247 -- analyzed in addition to the generated pragma so that aspects
10248 -- within generic units get properly resolved.
10250 if Present (Prag) and then From_Aspect_Specification (Prag) then
10252 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10260 -- Obtain all interfacing aspects used to construct the pragma
10262 Get_Interfacing_Aspects
10263 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10265 -- Analyze the expression of aspect External_Name
10267 if Present (EN) then
10268 Analyze (Expression (EN));
10271 -- Analyze the expressio of aspect Link_Name
10273 if Present (LN) then
10274 Analyze (Expression (LN));
10279 if No (Link_Arg) then
10280 if No (Ext_Arg) then
10283 elsif Chars (Ext_Arg) = Name_Link_Name then
10285 Link_Nam := Expression (Ext_Arg);
10288 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10289 Ext_Nam := Expression (Ext_Arg);
10294 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10295 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10296 Ext_Nam := Expression (Ext_Arg);
10297 Link_Nam := Expression (Link_Arg);
10300 -- Check expressions for external name and link name are static
10302 if Present (Ext_Nam) then
10303 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10304 Check_Form_Of_Interface_Name (Ext_Nam);
10306 -- Verify that external name is not the name of a local entity,
10307 -- which would hide the imported one and could lead to run-time
10308 -- surprises. The problem can only arise for entities declared in
10309 -- a package body (otherwise the external name is fully qualified
10310 -- and will not conflict).
10318 if Prag_Id = Pragma_Import then
10319 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10320 E := Entity_Id (Get_Name_Table_Int (Nam));
10322 if Nam /= Chars (Subprogram_Def)
10323 and then Present (E)
10324 and then not Is_Overloadable (E)
10325 and then Is_Immediately_Visible (E)
10326 and then not Is_Imported (E)
10327 and then Ekind (Scope (E)) = E_Package
10330 while Present (Par) loop
10331 if Nkind (Par) = N_Package_Body then
10332 Error_Msg_Sloc := Sloc (E);
10334 ("imported entity is hidden by & declared#",
10339 Par := Parent (Par);
10346 if Present (Link_Nam) then
10347 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10348 Check_Form_Of_Interface_Name (Link_Nam);
10351 -- If there is no link name, just set the external name
10353 if No (Link_Nam) then
10354 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10356 -- For the Link_Name case, the given literal is preceded by an
10357 -- asterisk, which indicates to GCC that the given name should be
10358 -- taken literally, and in particular that no prepending of
10359 -- underlines should occur, even in systems where this is the
10364 Store_String_Char (Get_Char_Code ('*'));
10365 String_Val := Strval (Expr_Value_S (Link_Nam));
10366 Store_String_Chars (String_Val);
10368 Make_String_Literal (Sloc (Link_Nam),
10369 Strval => End_String);
10372 -- Set the interface name. If the entity is a generic instance, use
10373 -- its alias, which is the callable entity.
10375 if Is_Generic_Instance (Subprogram_Def) then
10376 Set_Encoded_Interface_Name
10377 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10379 Set_Encoded_Interface_Name
10380 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10383 Check_Duplicated_Export_Name (Link_Nam);
10384 end Process_Interface_Name;
10386 -----------------------------------------
10387 -- Process_Interrupt_Or_Attach_Handler --
10388 -----------------------------------------
10390 procedure Process_Interrupt_Or_Attach_Handler is
10391 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10392 Prot_Typ : constant Entity_Id := Scope (Handler);
10395 -- A pragma that applies to a Ghost entity becomes Ghost for the
10396 -- purposes of legality checks and removal of ignored Ghost code.
10398 Mark_Ghost_Pragma (N, Handler);
10399 Set_Is_Interrupt_Handler (Handler);
10401 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10403 Record_Rep_Item (Prot_Typ, N);
10405 -- Chain the pragma on the contract for completeness
10407 Add_Contract_Item (N, Handler);
10408 end Process_Interrupt_Or_Attach_Handler;
10410 --------------------------------------------------
10411 -- Process_Restrictions_Or_Restriction_Warnings --
10412 --------------------------------------------------
10414 -- Note: some of the simple identifier cases were handled in par-prag,
10415 -- but it is harmless (and more straightforward) to simply handle all
10416 -- cases here, even if it means we repeat a bit of work in some cases.
10418 procedure Process_Restrictions_Or_Restriction_Warnings
10422 R_Id : Restriction_Id;
10428 -- Ignore all Restrictions pragmas in CodePeer mode
10430 if CodePeer_Mode then
10434 Check_Ada_83_Warning;
10435 Check_At_Least_N_Arguments (1);
10436 Check_Valid_Configuration_Pragma;
10439 while Present (Arg) loop
10441 Expr := Get_Pragma_Arg (Arg);
10443 -- Case of no restriction identifier present
10445 if Id = No_Name then
10446 if Nkind (Expr) /= N_Identifier then
10448 ("invalid form for restriction", Arg);
10453 (Process_Restriction_Synonyms (Expr));
10455 if R_Id not in All_Boolean_Restrictions then
10456 Error_Msg_Name_1 := Pname;
10458 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10460 -- Check for possible misspelling
10462 for J in Restriction_Id loop
10464 Rnm : constant String := Restriction_Id'Image (J);
10467 Name_Buffer (1 .. Rnm'Length) := Rnm;
10468 Name_Len := Rnm'Length;
10469 Set_Casing (All_Lower_Case);
10471 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10474 (Source_Index (Current_Sem_Unit)));
10475 Error_Msg_String (1 .. Rnm'Length) :=
10476 Name_Buffer (1 .. Name_Len);
10477 Error_Msg_Strlen := Rnm'Length;
10478 Error_Msg_N -- CODEFIX
10479 ("\possible misspelling of ""~""",
10480 Get_Pragma_Arg (Arg));
10489 if Implementation_Restriction (R_Id) then
10490 Check_Restriction (No_Implementation_Restrictions, Arg);
10493 -- Special processing for No_Elaboration_Code restriction
10495 if R_Id = No_Elaboration_Code then
10497 -- Restriction is only recognized within a configuration
10498 -- pragma file, or within a unit of the main extended
10499 -- program. Note: the test for Main_Unit is needed to
10500 -- properly include the case of configuration pragma files.
10502 if not (Current_Sem_Unit = Main_Unit
10503 or else In_Extended_Main_Source_Unit (N))
10507 -- Don't allow in a subunit unless already specified in
10510 elsif Nkind (Parent (N)) = N_Compilation_Unit
10511 and then Nkind (Unit (Parent (N))) = N_Subunit
10512 and then not Restriction_Active (No_Elaboration_Code)
10515 ("invalid specification of ""No_Elaboration_Code""",
10518 ("\restriction cannot be specified in a subunit", N);
10520 ("\unless also specified in body or spec", N);
10523 -- If we accept a No_Elaboration_Code restriction, then it
10524 -- needs to be added to the configuration restriction set so
10525 -- that we get proper application to other units in the main
10526 -- extended source as required.
10529 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10532 -- Special processing for No_Tasking restriction placed in
10533 -- a configuration pragmas file.
10535 elsif R_Id = No_Tasking and then No (Cunit (Main_Unit)) then
10536 Set_Global_No_Tasking;
10539 Set_Restriction (R_Id, N, Warn);
10541 if R_Id = No_Dynamic_CPU_Assignment
10542 or else R_Id = No_Tasks_Unassigned_To_CPU
10544 -- These imply No_Dependence =>
10545 -- "System.Multiprocessors.Dispatching_Domains".
10546 -- This is not strictly what the AI says, but it eliminates
10547 -- the need for run-time checks, which are undesirable in
10550 Set_Restriction_No_Dependence
10552 (Sel_Comp ("system", "multiprocessors", Loc),
10553 "dispatching_domains"),
10557 if R_Id = No_Tasks_Unassigned_To_CPU then
10558 -- Likewise, imply No_Dynamic_CPU_Assignment
10560 Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
10563 -- Check for obsolescent restrictions in Ada 2005 mode
10566 and then Ada_Version >= Ada_2005
10567 and then (R_Id = No_Asynchronous_Control
10569 R_Id = No_Unchecked_Deallocation
10571 R_Id = No_Unchecked_Conversion)
10573 Check_Restriction (No_Obsolescent_Features, N);
10576 -- A very special case that must be processed here: pragma
10577 -- Restrictions (No_Exceptions) turns off all run-time
10578 -- checking. This is a bit dubious in terms of the formal
10579 -- language definition, but it is what is intended by RM
10580 -- H.4(12). Restriction_Warnings never affects generated code
10581 -- so this is done only in the real restriction case.
10583 -- Atomic_Synchronization is not a real check, so it is not
10584 -- affected by this processing).
10586 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10587 -- run-time checks in CodePeer and GNATprove modes: we want to
10588 -- generate checks for analysis purposes, as set respectively
10589 -- by -gnatC and -gnatd.F
10592 and then not (CodePeer_Mode or GNATprove_Mode)
10593 and then R_Id = No_Exceptions
10595 for J in Scope_Suppress.Suppress'Range loop
10596 if J /= Atomic_Synchronization then
10597 Scope_Suppress.Suppress (J) := True;
10602 -- Case of No_Dependence => unit-name. Note that the parser
10603 -- already made the necessary entry in the No_Dependence table.
10605 elsif Id = Name_No_Dependence then
10606 if not OK_No_Dependence_Unit_Name (Expr) then
10610 -- Case of No_Specification_Of_Aspect => aspect-identifier
10612 elsif Id = Name_No_Specification_Of_Aspect then
10617 if Nkind (Expr) /= N_Identifier then
10620 A_Id := Get_Aspect_Id (Chars (Expr));
10623 if A_Id = No_Aspect then
10624 Error_Pragma_Arg ("invalid restriction name", Arg);
10626 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10630 -- Case of No_Use_Of_Attribute => attribute-identifier
10632 elsif Id = Name_No_Use_Of_Attribute then
10633 if Nkind (Expr) /= N_Identifier
10634 or else not Is_Attribute_Name (Chars (Expr))
10636 Error_Msg_N ("unknown attribute name??", Expr);
10639 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10642 -- Case of No_Use_Of_Entity => fully-qualified-name
10644 elsif Id = Name_No_Use_Of_Entity then
10646 -- Restriction is only recognized within a configuration
10647 -- pragma file, or within a unit of the main extended
10648 -- program. Note: the test for Main_Unit is needed to
10649 -- properly include the case of configuration pragma files.
10651 if Current_Sem_Unit = Main_Unit
10652 or else In_Extended_Main_Source_Unit (N)
10654 if not OK_No_Dependence_Unit_Name (Expr) then
10655 Error_Msg_N ("wrong form for entity name", Expr);
10657 Set_Restriction_No_Use_Of_Entity
10658 (Expr, Warn, No_Profile);
10662 -- Case of No_Use_Of_Pragma => pragma-identifier
10664 elsif Id = Name_No_Use_Of_Pragma then
10665 if Nkind (Expr) /= N_Identifier
10666 or else not Is_Pragma_Name (Chars (Expr))
10668 Error_Msg_N ("unknown pragma name??", Expr);
10670 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10673 -- All other cases of restriction identifier present
10676 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10677 Analyze_And_Resolve (Expr, Any_Integer);
10679 if R_Id not in All_Parameter_Restrictions then
10681 ("invalid restriction parameter identifier", Arg);
10683 elsif not Is_OK_Static_Expression (Expr) then
10684 Flag_Non_Static_Expr
10685 ("value must be static expression!", Expr);
10688 elsif not Is_Integer_Type (Etype (Expr))
10689 or else Expr_Value (Expr) < 0
10692 ("value must be non-negative integer", Arg);
10695 -- Restriction pragma is active
10697 Val := Expr_Value (Expr);
10699 if not UI_Is_In_Int_Range (Val) then
10701 ("pragma ignored, value too large??", Arg);
10704 Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
10709 end Process_Restrictions_Or_Restriction_Warnings;
10711 ---------------------------------
10712 -- Process_Suppress_Unsuppress --
10713 ---------------------------------
10715 -- Note: this procedure makes entries in the check suppress data
10716 -- structures managed by Sem. See spec of package Sem for full
10717 -- details on how we handle recording of check suppression.
10719 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10724 In_Package_Spec : constant Boolean :=
10725 Is_Package_Or_Generic_Package (Current_Scope)
10726 and then not In_Package_Body (Current_Scope);
10728 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10729 -- Used to suppress a single check on the given entity
10731 --------------------------------
10732 -- Suppress_Unsuppress_Echeck --
10733 --------------------------------
10735 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10737 -- Check for error of trying to set atomic synchronization for
10738 -- a non-atomic variable.
10740 if C = Atomic_Synchronization
10741 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10744 ("pragma & requires atomic type or variable",
10745 Pragma_Identifier (Original_Node (N)));
10748 Set_Checks_May_Be_Suppressed (E);
10750 if In_Package_Spec then
10751 Push_Global_Suppress_Stack_Entry
10754 Suppress => Suppress_Case);
10756 Push_Local_Suppress_Stack_Entry
10759 Suppress => Suppress_Case);
10762 -- If this is a first subtype, and the base type is distinct,
10763 -- then also set the suppress flags on the base type.
10765 if Is_First_Subtype (E) and then Etype (E) /= E then
10766 Suppress_Unsuppress_Echeck (Etype (E), C);
10768 end Suppress_Unsuppress_Echeck;
10770 -- Start of processing for Process_Suppress_Unsuppress
10773 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10774 -- on user code: we want to generate checks for analysis purposes, as
10775 -- set respectively by -gnatC and -gnatd.F
10777 if Comes_From_Source (N)
10778 and then (CodePeer_Mode or GNATprove_Mode)
10783 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10784 -- declarative part or a package spec (RM 11.5(5)).
10786 if not Is_Configuration_Pragma then
10787 Check_Is_In_Decl_Part_Or_Package_Spec;
10790 Check_At_Least_N_Arguments (1);
10791 Check_At_Most_N_Arguments (2);
10792 Check_No_Identifier (Arg1);
10793 Check_Arg_Is_Identifier (Arg1);
10795 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10797 if C = No_Check_Id then
10799 ("argument of pragma% is not valid check name", Arg1);
10802 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10804 if C = Elaboration_Check and then SPARK_Mode = On then
10806 ("Suppress of Elaboration_Check ignored in SPARK??",
10807 "\elaboration checking rules are statically enforced "
10808 & "(SPARK RM 7.7)", Arg1);
10811 -- One-argument case
10813 if Arg_Count = 1 then
10815 -- Make an entry in the local scope suppress table. This is the
10816 -- table that directly shows the current value of the scope
10817 -- suppress check for any check id value.
10819 if C = All_Checks then
10821 -- For All_Checks, we set all specific predefined checks with
10822 -- the exception of Elaboration_Check, which is handled
10823 -- specially because of not wanting All_Checks to have the
10824 -- effect of deactivating static elaboration order processing.
10825 -- Atomic_Synchronization is also not affected, since this is
10826 -- not a real check.
10828 for J in Scope_Suppress.Suppress'Range loop
10829 if J /= Elaboration_Check
10831 J /= Atomic_Synchronization
10833 Scope_Suppress.Suppress (J) := Suppress_Case;
10837 -- If not All_Checks, and predefined check, then set appropriate
10838 -- scope entry. Note that we will set Elaboration_Check if this
10839 -- is explicitly specified. Atomic_Synchronization is allowed
10840 -- only if internally generated and entity is atomic.
10842 elsif C in Predefined_Check_Id
10843 and then (not Comes_From_Source (N)
10844 or else C /= Atomic_Synchronization)
10846 Scope_Suppress.Suppress (C) := Suppress_Case;
10849 -- Also make an entry in the Local_Entity_Suppress table
10851 Push_Local_Suppress_Stack_Entry
10854 Suppress => Suppress_Case);
10856 -- Case of two arguments present, where the check is suppressed for
10857 -- a specified entity (given as the second argument of the pragma)
10860 -- This is obsolescent in Ada 2005 mode
10862 if Ada_Version >= Ada_2005 then
10863 Check_Restriction (No_Obsolescent_Features, Arg2);
10866 Check_Optional_Identifier (Arg2, Name_On);
10867 E_Id := Get_Pragma_Arg (Arg2);
10870 if not Is_Entity_Name (E_Id) then
10872 ("second argument of pragma% must be entity name", Arg2);
10875 E := Entity (E_Id);
10881 -- A pragma that applies to a Ghost entity becomes Ghost for the
10882 -- purposes of legality checks and removal of ignored Ghost code.
10884 Mark_Ghost_Pragma (N, E);
10886 -- Enforce RM 11.5(7) which requires that for a pragma that
10887 -- appears within a package spec, the named entity must be
10888 -- within the package spec. We allow the package name itself
10889 -- to be mentioned since that makes sense, although it is not
10890 -- strictly allowed by 11.5(7).
10893 and then E /= Current_Scope
10894 and then Scope (E) /= Current_Scope
10897 ("entity in pragma% is not in package spec (RM 11.5(7))",
10901 -- Loop through homonyms. As noted below, in the case of a package
10902 -- spec, only homonyms within the package spec are considered.
10905 Suppress_Unsuppress_Echeck (E, C);
10907 if Is_Generic_Instance (E)
10908 and then Is_Subprogram (E)
10909 and then Present (Alias (E))
10911 Suppress_Unsuppress_Echeck (Alias (E), C);
10914 -- Move to next homonym if not aspect spec case
10916 exit when From_Aspect_Specification (N);
10920 -- If we are within a package specification, the pragma only
10921 -- applies to homonyms in the same scope.
10923 exit when In_Package_Spec
10924 and then Scope (E) /= Current_Scope;
10927 end Process_Suppress_Unsuppress;
10929 -------------------------------
10930 -- Record_Independence_Check --
10931 -------------------------------
10933 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10934 pragma Unreferenced (N, E);
10936 -- For GCC back ends the validation is done a priori
10937 -- ??? This code is dead, might be useful in the future
10939 -- if not AAMP_On_Target then
10943 -- Independence_Checks.Append ((N, E));
10946 end Record_Independence_Check;
10952 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10954 if Is_Imported (E) then
10956 ("cannot export entity& that was previously imported", Arg);
10958 elsif Present (Address_Clause (E))
10959 and then not Relaxed_RM_Semantics
10962 ("cannot export entity& that has an address clause", Arg);
10965 Set_Is_Exported (E);
10967 -- Generate a reference for entity explicitly, because the
10968 -- identifier may be overloaded and name resolution will not
10971 Generate_Reference (E, Arg);
10973 -- Deal with exporting non-library level entity
10975 if not Is_Library_Level_Entity (E) then
10977 -- Not allowed at all for subprograms
10979 if Is_Subprogram (E) then
10980 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10982 -- Otherwise set public and statically allocated
10986 Set_Is_Statically_Allocated (E);
10988 -- Warn if the corresponding W flag is set
10990 if Warn_On_Export_Import
10992 -- Only do this for something that was in the source. Not
10993 -- clear if this can be False now (there used for sure to be
10994 -- cases on some systems where it was False), but anyway the
10995 -- test is harmless if not needed, so it is retained.
10997 and then Comes_From_Source (Arg)
11000 ("?x?& has been made static as a result of Export",
11003 ("\?x?this usage is non-standard and non-portable",
11009 if Warn_On_Export_Import and then Is_Type (E) then
11010 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
11013 if Warn_On_Export_Import and Inside_A_Generic then
11015 ("all instances of& will have the same external name?x?",
11020 ----------------------------------------------
11021 -- Set_Extended_Import_Export_External_Name --
11022 ----------------------------------------------
11024 procedure Set_Extended_Import_Export_External_Name
11025 (Internal_Ent : Entity_Id;
11026 Arg_External : Node_Id)
11028 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
11029 New_Name : Node_Id;
11032 if No (Arg_External) then
11036 Check_Arg_Is_External_Name (Arg_External);
11038 if Nkind (Arg_External) = N_String_Literal then
11039 if String_Length (Strval (Arg_External)) = 0 then
11042 New_Name := Adjust_External_Name_Case (Arg_External);
11045 elsif Nkind (Arg_External) = N_Identifier then
11046 New_Name := Get_Default_External_Name (Arg_External);
11048 -- Check_Arg_Is_External_Name should let through only identifiers and
11049 -- string literals or static string expressions (which are folded to
11050 -- string literals).
11053 raise Program_Error;
11056 -- If we already have an external name set (by a prior normal Import
11057 -- or Export pragma), then the external names must match
11059 if Present (Interface_Name (Internal_Ent)) then
11061 -- Ignore mismatching names in CodePeer mode, to support some
11062 -- old compilers which would export the same procedure under
11063 -- different names, e.g:
11065 -- pragma Export_Procedure (P, "a");
11066 -- pragma Export_Procedure (P, "b");
11068 if CodePeer_Mode then
11072 Check_Matching_Internal_Names : declare
11073 S1 : constant String_Id := Strval (Old_Name);
11074 S2 : constant String_Id := Strval (New_Name);
11076 procedure Mismatch;
11077 pragma No_Return (Mismatch);
11078 -- Called if names do not match
11084 procedure Mismatch is
11086 Error_Msg_Sloc := Sloc (Old_Name);
11088 ("external name does not match that given #",
11092 -- Start of processing for Check_Matching_Internal_Names
11095 if String_Length (S1) /= String_Length (S2) then
11099 for J in 1 .. String_Length (S1) loop
11100 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11105 end Check_Matching_Internal_Names;
11107 -- Otherwise set the given name
11110 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11111 Check_Duplicated_Export_Name (New_Name);
11113 end Set_Extended_Import_Export_External_Name;
11119 procedure Set_Imported (E : Entity_Id) is
11121 -- Error message if already imported or exported
11123 if Is_Exported (E) or else Is_Imported (E) then
11125 -- Error if being set Exported twice
11127 if Is_Exported (E) then
11128 Error_Msg_NE ("entity& was previously exported", N, E);
11130 -- Ignore error in CodePeer mode where we treat all imported
11131 -- subprograms as unknown.
11133 elsif CodePeer_Mode then
11136 -- OK if Import/Interface case
11138 elsif Import_Interface_Present (N) then
11141 -- Error if being set Imported twice
11144 Error_Msg_NE ("entity& was previously imported", N, E);
11147 Error_Msg_Name_1 := Pname;
11149 ("\(pragma% applies to all previous entities)", N);
11151 Error_Msg_Sloc := Sloc (E);
11152 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11154 -- Here if not previously imported or exported, OK to import
11157 Set_Is_Imported (E);
11159 -- For subprogram, set Import_Pragma field
11161 if Is_Subprogram (E) then
11162 Set_Import_Pragma (E, N);
11165 -- If the entity is an object that is not at the library level,
11166 -- then it is statically allocated. We do not worry about objects
11167 -- with address clauses in this context since they are not really
11168 -- imported in the linker sense.
11171 and then not Is_Library_Level_Entity (E)
11172 and then No (Address_Clause (E))
11174 Set_Is_Statically_Allocated (E);
11181 -------------------------
11182 -- Set_Mechanism_Value --
11183 -------------------------
11185 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11186 -- analyzed, since it is semantic nonsense), so we get it in the exact
11187 -- form created by the parser.
11189 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11190 procedure Bad_Mechanism;
11191 pragma No_Return (Bad_Mechanism);
11192 -- Signal bad mechanism name
11194 -------------------
11195 -- Bad_Mechanism --
11196 -------------------
11198 procedure Bad_Mechanism is
11200 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11203 -- Start of processing for Set_Mechanism_Value
11206 if Mechanism (Ent) /= Default_Mechanism then
11208 ("mechanism for & has already been set", Mech_Name, Ent);
11211 -- MECHANISM_NAME ::= value | reference
11213 if Nkind (Mech_Name) = N_Identifier then
11214 if Chars (Mech_Name) = Name_Value then
11215 Set_Mechanism (Ent, By_Copy);
11218 elsif Chars (Mech_Name) = Name_Reference then
11219 Set_Mechanism (Ent, By_Reference);
11222 elsif Chars (Mech_Name) = Name_Copy then
11224 ("bad mechanism name, Value assumed", Mech_Name);
11233 end Set_Mechanism_Value;
11235 --------------------------
11236 -- Set_Rational_Profile --
11237 --------------------------
11239 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11240 -- extension to the semantics of renaming declarations.
11242 procedure Set_Rational_Profile is
11244 Implicit_Packing := True;
11245 Overriding_Renamings := True;
11246 Use_VADS_Size := True;
11247 end Set_Rational_Profile;
11249 ---------------------------
11250 -- Set_Ravenscar_Profile --
11251 ---------------------------
11253 -- The tasks to be done here are
11255 -- Set required policies
11257 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11258 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11259 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11260 -- (For GNAT_Ravenscar_EDF profile)
11261 -- pragma Locking_Policy (Ceiling_Locking)
11263 -- Set Detect_Blocking mode
11265 -- Set required restrictions (see System.Rident for detailed list)
11267 -- Set the No_Dependence rules
11268 -- No_Dependence => Ada.Asynchronous_Task_Control
11269 -- No_Dependence => Ada.Calendar
11270 -- No_Dependence => Ada.Execution_Time.Group_Budget
11271 -- No_Dependence => Ada.Execution_Time.Timers
11272 -- No_Dependence => Ada.Task_Attributes
11273 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11275 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11276 procedure Set_Error_Msg_To_Profile_Name;
11277 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11280 -----------------------------------
11281 -- Set_Error_Msg_To_Profile_Name --
11282 -----------------------------------
11284 procedure Set_Error_Msg_To_Profile_Name is
11285 Prof_Nam : constant Node_Id :=
11287 (First (Pragma_Argument_Associations (N)));
11290 Get_Name_String (Chars (Prof_Nam));
11291 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11292 Error_Msg_Strlen := Name_Len;
11293 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11294 end Set_Error_Msg_To_Profile_Name;
11296 Profile_Dispatching_Policy : Character;
11298 -- Start of processing for Set_Ravenscar_Profile
11301 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11303 if Profile = GNAT_Ravenscar_EDF then
11304 Profile_Dispatching_Policy := 'E';
11306 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11309 Profile_Dispatching_Policy := 'F';
11312 if Task_Dispatching_Policy /= ' '
11313 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11315 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11316 Set_Error_Msg_To_Profile_Name;
11317 Error_Pragma ("Profile (~) incompatible with policy#");
11319 -- Set the FIFO_Within_Priorities policy, but always preserve
11320 -- System_Location since we like the error message with the run time
11324 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11326 if Task_Dispatching_Policy_Sloc /= System_Location then
11327 Task_Dispatching_Policy_Sloc := Loc;
11331 -- pragma Locking_Policy (Ceiling_Locking)
11333 if Locking_Policy /= ' '
11334 and then Locking_Policy /= 'C'
11336 Error_Msg_Sloc := Locking_Policy_Sloc;
11337 Set_Error_Msg_To_Profile_Name;
11338 Error_Pragma ("Profile (~) incompatible with policy#");
11340 -- Set the Ceiling_Locking policy, but preserve System_Location since
11341 -- we like the error message with the run time name.
11344 Locking_Policy := 'C';
11346 if Locking_Policy_Sloc /= System_Location then
11347 Locking_Policy_Sloc := Loc;
11351 -- pragma Detect_Blocking
11353 Detect_Blocking := True;
11355 -- Set the corresponding restrictions
11357 Set_Profile_Restrictions
11358 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11360 -- Set the No_Dependence restrictions
11362 -- The following No_Dependence restrictions:
11363 -- No_Dependence => Ada.Asynchronous_Task_Control
11364 -- No_Dependence => Ada.Calendar
11365 -- No_Dependence => Ada.Task_Attributes
11366 -- are already set by previous call to Set_Profile_Restrictions.
11369 -- Set the following restrictions which were added to Ada 2005:
11370 -- No_Dependence => Ada.Execution_Time.Group_Budget
11371 -- No_Dependence => Ada.Execution_Time.Timers
11373 if Ada_Version >= Ada_2005 then
11375 Execution_Time : constant Node_Id :=
11376 Sel_Comp ("ada", "execution_time", Loc);
11377 Group_Budgets : constant Node_Id :=
11378 Sel_Comp (Execution_Time, "group_budgets");
11379 Timers : constant Node_Id :=
11380 Sel_Comp (Execution_Time, "timers");
11382 Set_Restriction_No_Dependence
11383 (Unit => Group_Budgets,
11384 Warn => Treat_Restrictions_As_Warnings,
11385 Profile => Ravenscar);
11386 Set_Restriction_No_Dependence
11388 Warn => Treat_Restrictions_As_Warnings,
11389 Profile => Ravenscar);
11393 -- Set the following restriction which was added to Ada 2012 (see
11395 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11397 if Ada_Version >= Ada_2012 then
11398 Set_Restriction_No_Dependence
11400 (Sel_Comp ("system", "multiprocessors", Loc),
11401 "dispatching_domains"),
11402 Warn => Treat_Restrictions_As_Warnings,
11403 Profile => Ravenscar);
11405 -- Set the following restriction which was added to Ada 2020,
11406 -- but as a binding interpretation:
11407 -- No_Dependence => Ada.Synchronous_Barriers
11408 -- for Ravenscar (and therefore for Ravenscar variants) but not
11409 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11410 -- in Ada2012 (AI05-0174).
11412 if Profile /= Jorvik then
11413 Set_Restriction_No_Dependence
11414 (Sel_Comp ("ada", "synchronous_barriers", Loc),
11415 Warn => Treat_Restrictions_As_Warnings,
11416 Profile => Ravenscar);
11420 end Set_Ravenscar_Profile;
11422 -- Start of processing for Analyze_Pragma
11425 -- The following code is a defense against recursion. Not clear that
11426 -- this can happen legitimately, but perhaps some error situations can
11427 -- cause it, and we did see this recursion during testing.
11429 if Analyzed (N) then
11435 Check_Restriction_No_Use_Of_Pragma (N);
11437 if Get_Aspect_Id (Chars (Pragma_Identifier (N))) /= No_Aspect then
11438 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11439 -- no aspect_specification, attribute_definition_clause, or pragma
11441 Check_Restriction_No_Specification_Of_Aspect (N);
11444 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11445 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11447 if Should_Ignore_Pragma_Sem (N)
11448 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11449 and then Ignore_Rep_Clauses)
11454 -- Deal with unrecognized pragma
11456 if not Is_Pragma_Name (Pname) then
11457 if Warn_On_Unrecognized_Pragma then
11458 Error_Msg_Name_1 := Pname;
11459 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11461 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11462 if Is_Bad_Spelling_Of (Pname, PN) then
11463 Error_Msg_Name_1 := PN;
11464 Error_Msg_N -- CODEFIX
11465 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11474 -- Here to start processing for recognized pragma
11476 Pname := Original_Aspect_Pragma_Name (N);
11478 -- Capture setting of Opt.Uneval_Old
11480 case Opt.Uneval_Old is
11482 Set_Uneval_Old_Accept (N);
11488 Set_Uneval_Old_Warn (N);
11491 raise Program_Error;
11494 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11495 -- is already set, indicating that we have already checked the policy
11496 -- at the right point. This happens for example in the case of a pragma
11497 -- that is derived from an Aspect.
11499 if Is_Ignored (N) or else Is_Checked (N) then
11502 -- For a pragma that is a rewriting of another pragma, copy the
11503 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11505 elsif Is_Rewrite_Substitution (N)
11506 and then Nkind (Original_Node (N)) = N_Pragma
11508 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11509 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11511 -- Otherwise query the applicable policy at this point
11514 Check_Applicable_Policy (N);
11516 -- If pragma is disabled, rewrite as NULL and skip analysis
11518 if Is_Disabled (N) then
11519 Rewrite (N, Make_Null_Statement (Loc));
11525 -- Preset arguments
11534 if Present (Pragma_Argument_Associations (N)) then
11535 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11536 Arg1 := First (Pragma_Argument_Associations (N));
11538 if Present (Arg1) then
11539 Arg2 := Next (Arg1);
11541 if Present (Arg2) then
11542 Arg3 := Next (Arg2);
11544 if Present (Arg3) then
11545 Arg4 := Next (Arg3);
11547 if Present (Arg4) then
11548 Arg5 := Next (Arg4);
11555 -- An enumeration type defines the pragmas that are supported by the
11556 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11557 -- into the corresponding enumeration value for the following case.
11565 -- pragma Abort_Defer;
11567 when Pragma_Abort_Defer =>
11569 Check_Arg_Count (0);
11571 -- The only required semantic processing is to check the
11572 -- placement. This pragma must appear at the start of the
11573 -- statement sequence of a handled sequence of statements.
11575 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11576 or else N /= First (Statements (Parent (N)))
11581 --------------------
11582 -- Abstract_State --
11583 --------------------
11585 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11587 -- ABSTRACT_STATE_LIST ::=
11589 -- | STATE_NAME_WITH_OPTIONS
11590 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11592 -- STATE_NAME_WITH_OPTIONS ::=
11594 -- | (STATE_NAME with OPTION_LIST)
11596 -- OPTION_LIST ::= OPTION {, OPTION}
11600 -- | NAME_VALUE_OPTION
11602 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11604 -- NAME_VALUE_OPTION ::=
11605 -- Part_Of => ABSTRACT_STATE
11606 -- | External [=> EXTERNAL_PROPERTY_LIST]
11608 -- EXTERNAL_PROPERTY_LIST ::=
11609 -- EXTERNAL_PROPERTY
11610 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11612 -- EXTERNAL_PROPERTY ::=
11613 -- Async_Readers [=> boolean_EXPRESSION]
11614 -- | Async_Writers [=> boolean_EXPRESSION]
11615 -- | Effective_Reads [=> boolean_EXPRESSION]
11616 -- | Effective_Writes [=> boolean_EXPRESSION]
11617 -- others => boolean_EXPRESSION
11619 -- STATE_NAME ::= defining_identifier
11621 -- ABSTRACT_STATE ::= name
11623 -- Characteristics:
11625 -- * Analysis - The annotation is fully analyzed immediately upon
11626 -- elaboration as it cannot forward reference entities.
11628 -- * Expansion - None.
11630 -- * Template - The annotation utilizes the generic template of the
11631 -- related package declaration.
11633 -- * Globals - The annotation cannot reference global entities.
11635 -- * Instance - The annotation is instantiated automatically when
11636 -- the related generic package is instantiated.
11638 when Pragma_Abstract_State => Abstract_State : declare
11639 Missing_Parentheses : Boolean := False;
11640 -- Flag set when a state declaration with options is not properly
11643 -- Flags used to verify the consistency of states
11645 Non_Null_Seen : Boolean := False;
11646 Null_Seen : Boolean := False;
11648 procedure Analyze_Abstract_State
11650 Pack_Id : Entity_Id);
11651 -- Verify the legality of a single state declaration. Create and
11652 -- decorate a state abstraction entity and introduce it into the
11653 -- visibility chain. Pack_Id denotes the entity or the related
11654 -- package where pragma Abstract_State appears.
11656 procedure Malformed_State_Error (State : Node_Id);
11657 -- Emit an error concerning the illegal declaration of abstract
11658 -- state State. This routine diagnoses syntax errors that lead to
11659 -- a different parse tree. The error is issued regardless of the
11660 -- SPARK mode in effect.
11662 ----------------------------
11663 -- Analyze_Abstract_State --
11664 ----------------------------
11666 procedure Analyze_Abstract_State
11668 Pack_Id : Entity_Id)
11670 -- Flags used to verify the consistency of options
11672 AR_Seen : Boolean := False;
11673 AW_Seen : Boolean := False;
11674 ER_Seen : Boolean := False;
11675 EW_Seen : Boolean := False;
11676 External_Seen : Boolean := False;
11677 Ghost_Seen : Boolean := False;
11678 Others_Seen : Boolean := False;
11679 Part_Of_Seen : Boolean := False;
11680 Relaxed_Initialization_Seen : Boolean := False;
11681 Synchronous_Seen : Boolean := False;
11683 -- Flags used to store the static value of all external states'
11686 AR_Val : Boolean := False;
11687 AW_Val : Boolean := False;
11688 ER_Val : Boolean := False;
11689 EW_Val : Boolean := False;
11691 State_Id : Entity_Id := Empty;
11692 -- The entity to be generated for the current state declaration
11694 procedure Analyze_External_Option (Opt : Node_Id);
11695 -- Verify the legality of option External
11697 procedure Analyze_External_Property
11699 Expr : Node_Id := Empty);
11700 -- Verify the legailty of a single external property. Prop
11701 -- denotes the external property. Expr is the expression used
11702 -- to set the property.
11704 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11705 -- Verify the legality of option Part_Of
11707 procedure Check_Duplicate_Option
11709 Status : in out Boolean);
11710 -- Flag Status denotes whether a particular option has been
11711 -- seen while processing a state. This routine verifies that
11712 -- Opt is not a duplicate option and sets the flag Status
11713 -- (SPARK RM 7.1.4(1)).
11715 procedure Check_Duplicate_Property
11717 Status : in out Boolean);
11718 -- Flag Status denotes whether a particular property has been
11719 -- seen while processing option External. This routine verifies
11720 -- that Prop is not a duplicate property and sets flag Status.
11721 -- Opt is not a duplicate property and sets the flag Status.
11722 -- (SPARK RM 7.1.4(2))
11724 procedure Check_Ghost_Synchronous;
11725 -- Ensure that the abstract state is not subject to both Ghost
11726 -- and Synchronous simple options. Emit an error if this is the
11729 procedure Create_Abstract_State
11733 Is_Null : Boolean);
11734 -- Generate an abstract state entity with name Nam and enter it
11735 -- into visibility. Decl is the "declaration" of the state as
11736 -- it appears in pragma Abstract_State. Loc is the location of
11737 -- the related state "declaration". Flag Is_Null should be set
11738 -- when the associated Abstract_State pragma defines a null
11741 -----------------------------
11742 -- Analyze_External_Option --
11743 -----------------------------
11745 procedure Analyze_External_Option (Opt : Node_Id) is
11746 Errors : constant Nat := Serious_Errors_Detected;
11748 Props : Node_Id := Empty;
11751 if Nkind (Opt) = N_Component_Association then
11752 Props := Expression (Opt);
11755 -- External state with properties
11757 if Present (Props) then
11759 -- Multiple properties appear as an aggregate
11761 if Nkind (Props) = N_Aggregate then
11763 -- Simple property form
11765 Prop := First (Expressions (Props));
11766 while Present (Prop) loop
11767 Analyze_External_Property (Prop);
11771 -- Property with expression form
11773 Prop := First (Component_Associations (Props));
11774 while Present (Prop) loop
11775 Analyze_External_Property
11776 (Prop => First (Choices (Prop)),
11777 Expr => Expression (Prop));
11785 Analyze_External_Property (Props);
11788 -- An external state defined without any properties defaults
11789 -- all properties to True.
11798 -- Once all external properties have been processed, verify
11799 -- their mutual interaction. Do not perform the check when
11800 -- at least one of the properties is illegal as this will
11801 -- produce a bogus error.
11803 if Errors = Serious_Errors_Detected then
11804 Check_External_Properties
11805 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11807 end Analyze_External_Option;
11809 -------------------------------
11810 -- Analyze_External_Property --
11811 -------------------------------
11813 procedure Analyze_External_Property
11815 Expr : Node_Id := Empty)
11817 Expr_Val : Boolean;
11820 -- Check the placement of "others" (if available)
11822 if Nkind (Prop) = N_Others_Choice then
11823 if Others_Seen then
11825 ("only one others choice allowed in option External",
11828 Others_Seen := True;
11831 elsif Others_Seen then
11833 ("others must be the last property in option External",
11836 -- The only remaining legal options are the four predefined
11837 -- external properties.
11839 elsif Nkind (Prop) = N_Identifier
11840 and then Chars (Prop) in Name_Async_Readers
11841 | Name_Async_Writers
11842 | Name_Effective_Reads
11843 | Name_Effective_Writes
11847 -- Otherwise the construct is not a valid property
11850 SPARK_Msg_N ("invalid external state property", Prop);
11854 -- Ensure that the expression of the external state property
11855 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11857 if Present (Expr) then
11858 Analyze_And_Resolve (Expr, Standard_Boolean);
11860 if Is_OK_Static_Expression (Expr) then
11861 Expr_Val := Is_True (Expr_Value (Expr));
11864 ("expression of external state property must be "
11869 -- The lack of expression defaults the property to True
11875 -- Named properties
11877 if Nkind (Prop) = N_Identifier then
11878 if Chars (Prop) = Name_Async_Readers then
11879 Check_Duplicate_Property (Prop, AR_Seen);
11880 AR_Val := Expr_Val;
11882 elsif Chars (Prop) = Name_Async_Writers then
11883 Check_Duplicate_Property (Prop, AW_Seen);
11884 AW_Val := Expr_Val;
11886 elsif Chars (Prop) = Name_Effective_Reads then
11887 Check_Duplicate_Property (Prop, ER_Seen);
11888 ER_Val := Expr_Val;
11891 Check_Duplicate_Property (Prop, EW_Seen);
11892 EW_Val := Expr_Val;
11895 -- The handling of property "others" must take into account
11896 -- all other named properties that have been encountered so
11897 -- far. Only those that have not been seen are affected by
11901 if not AR_Seen then
11902 AR_Val := Expr_Val;
11905 if not AW_Seen then
11906 AW_Val := Expr_Val;
11909 if not ER_Seen then
11910 ER_Val := Expr_Val;
11913 if not EW_Seen then
11914 EW_Val := Expr_Val;
11917 end Analyze_External_Property;
11919 ----------------------------
11920 -- Analyze_Part_Of_Option --
11921 ----------------------------
11923 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11924 Encap : constant Node_Id := Expression (Opt);
11925 Constits : Elist_Id;
11926 Encap_Id : Entity_Id;
11930 Check_Duplicate_Option (Opt, Part_Of_Seen);
11933 (Indic => First (Choices (Opt)),
11934 Item_Id => State_Id,
11936 Encap_Id => Encap_Id,
11939 -- The Part_Of indicator transforms the abstract state into
11940 -- a constituent of the encapsulating state or single
11941 -- concurrent type.
11944 pragma Assert (Present (Encap_Id));
11945 Constits := Part_Of_Constituents (Encap_Id);
11947 if No (Constits) then
11948 Constits := New_Elmt_List;
11949 Set_Part_Of_Constituents (Encap_Id, Constits);
11952 Append_Elmt (State_Id, Constits);
11953 Set_Encapsulating_State (State_Id, Encap_Id);
11955 end Analyze_Part_Of_Option;
11957 ----------------------------
11958 -- Check_Duplicate_Option --
11959 ----------------------------
11961 procedure Check_Duplicate_Option
11963 Status : in out Boolean)
11967 SPARK_Msg_N ("duplicate state option", Opt);
11971 end Check_Duplicate_Option;
11973 ------------------------------
11974 -- Check_Duplicate_Property --
11975 ------------------------------
11977 procedure Check_Duplicate_Property
11979 Status : in out Boolean)
11983 SPARK_Msg_N ("duplicate external property", Prop);
11987 end Check_Duplicate_Property;
11989 -----------------------------
11990 -- Check_Ghost_Synchronous --
11991 -----------------------------
11993 procedure Check_Ghost_Synchronous is
11995 -- A synchronized abstract state cannot be Ghost and vice
11996 -- versa (SPARK RM 6.9(19)).
11998 if Ghost_Seen and Synchronous_Seen then
11999 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12001 end Check_Ghost_Synchronous;
12003 ---------------------------
12004 -- Create_Abstract_State --
12005 ---------------------------
12007 procedure Create_Abstract_State
12014 -- The abstract state may be semi-declared when the related
12015 -- package was withed through a limited with clause. In that
12016 -- case reuse the entity to fully declare the state.
12018 if Present (Decl) and then Present (Entity (Decl)) then
12019 State_Id := Entity (Decl);
12021 -- Otherwise the elaboration of pragma Abstract_State
12022 -- declares the state.
12025 State_Id := Make_Defining_Identifier (Loc, Nam);
12027 if Present (Decl) then
12028 Set_Entity (Decl, State_Id);
12032 -- Null states never come from source
12034 Set_Comes_From_Source (State_Id, not Is_Null);
12035 Set_Parent (State_Id, State);
12036 Set_Ekind (State_Id, E_Abstract_State);
12037 Set_Etype (State_Id, Standard_Void_Type);
12038 Set_Encapsulating_State (State_Id, Empty);
12040 -- Set the SPARK mode from the current context
12042 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12043 Set_SPARK_Pragma_Inherited (State_Id);
12045 -- An abstract state declared within a Ghost region becomes
12046 -- Ghost (SPARK RM 6.9(2)).
12048 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12049 Set_Is_Ghost_Entity (State_Id);
12052 -- Establish a link between the state declaration and the
12053 -- abstract state entity. Note that a null state remains as
12054 -- N_Null and does not carry any linkages.
12056 if not Is_Null then
12057 if Present (Decl) then
12058 Set_Entity (Decl, State_Id);
12059 Set_Etype (Decl, Standard_Void_Type);
12062 -- Every non-null state must be defined, nameable and
12065 Push_Scope (Pack_Id);
12066 Generate_Definition (State_Id);
12067 Enter_Name (State_Id);
12070 end Create_Abstract_State;
12077 -- Start of processing for Analyze_Abstract_State
12080 -- A package with a null abstract state is not allowed to
12081 -- declare additional states.
12085 ("package & has null abstract state", State, Pack_Id);
12087 -- Null states appear as internally generated entities
12089 elsif Nkind (State) = N_Null then
12090 Create_Abstract_State
12091 (Nam => New_Internal_Name ('S'),
12093 Loc => Sloc (State),
12097 -- Catch a case where a null state appears in a list of
12098 -- non-null states.
12100 if Non_Null_Seen then
12102 ("package & has non-null abstract state",
12106 -- Simple state declaration
12108 elsif Nkind (State) = N_Identifier then
12109 Create_Abstract_State
12110 (Nam => Chars (State),
12112 Loc => Sloc (State),
12114 Non_Null_Seen := True;
12116 -- State declaration with various options. This construct
12117 -- appears as an extension aggregate in the tree.
12119 elsif Nkind (State) = N_Extension_Aggregate then
12120 if Nkind (Ancestor_Part (State)) = N_Identifier then
12121 Create_Abstract_State
12122 (Nam => Chars (Ancestor_Part (State)),
12123 Decl => Ancestor_Part (State),
12124 Loc => Sloc (Ancestor_Part (State)),
12126 Non_Null_Seen := True;
12129 ("state name must be an identifier",
12130 Ancestor_Part (State));
12133 -- Options External, Ghost and Synchronous appear as
12136 Opt := First (Expressions (State));
12137 while Present (Opt) loop
12138 if Nkind (Opt) = N_Identifier then
12142 if Chars (Opt) = Name_External then
12143 Check_Duplicate_Option (Opt, External_Seen);
12144 Analyze_External_Option (Opt);
12148 elsif Chars (Opt) = Name_Ghost then
12149 Check_Duplicate_Option (Opt, Ghost_Seen);
12150 Check_Ghost_Synchronous;
12152 if Present (State_Id) then
12153 Set_Is_Ghost_Entity (State_Id);
12158 elsif Chars (Opt) = Name_Synchronous then
12159 Check_Duplicate_Option (Opt, Synchronous_Seen);
12160 Check_Ghost_Synchronous;
12162 -- Relaxed_Initialization
12164 elsif Chars (Opt) = Name_Relaxed_Initialization then
12165 Check_Duplicate_Option
12166 (Opt, Relaxed_Initialization_Seen);
12168 -- Option Part_Of without an encapsulating state is
12169 -- illegal (SPARK RM 7.1.4(8)).
12171 elsif Chars (Opt) = Name_Part_Of then
12173 ("indicator Part_Of must denote abstract state, "
12174 & "single protected type or single task type",
12177 -- Do not emit an error message when a previous state
12178 -- declaration with options was not parenthesized as
12179 -- the option is actually another state declaration.
12181 -- with Abstract_State
12182 -- (State_1 with ..., -- missing parentheses
12183 -- (State_2 with ...),
12184 -- State_3) -- ok state declaration
12186 elsif Missing_Parentheses then
12189 -- Otherwise the option is not allowed. Note that it
12190 -- is not possible to distinguish between an option
12191 -- and a state declaration when a previous state with
12192 -- options not properly parentheses.
12194 -- with Abstract_State
12195 -- (State_1 with ..., -- missing parentheses
12196 -- State_2); -- could be an option
12200 ("simple option not allowed in state declaration",
12204 -- Catch a case where missing parentheses around a state
12205 -- declaration with options cause a subsequent state
12206 -- declaration with options to be treated as an option.
12208 -- with Abstract_State
12209 -- (State_1 with ..., -- missing parentheses
12210 -- (State_2 with ...))
12212 elsif Nkind (Opt) = N_Extension_Aggregate then
12213 Missing_Parentheses := True;
12215 ("state declaration must be parenthesized",
12216 Ancestor_Part (State));
12218 -- Otherwise the option is malformed
12221 SPARK_Msg_N ("malformed option", Opt);
12227 -- Options External and Part_Of appear as component
12230 Opt := First (Component_Associations (State));
12231 while Present (Opt) loop
12232 Opt_Nam := First (Choices (Opt));
12234 if Nkind (Opt_Nam) = N_Identifier then
12235 if Chars (Opt_Nam) = Name_External then
12236 Analyze_External_Option (Opt);
12238 elsif Chars (Opt_Nam) = Name_Part_Of then
12239 Analyze_Part_Of_Option (Opt);
12242 SPARK_Msg_N ("invalid state option", Opt);
12245 SPARK_Msg_N ("invalid state option", Opt);
12251 -- Any other attempt to declare a state is illegal
12254 Malformed_State_Error (State);
12258 -- Guard against a junk state. In such cases no entity is
12259 -- generated and the subsequent checks cannot be applied.
12261 if Present (State_Id) then
12263 -- Verify whether the state does not introduce an illegal
12264 -- hidden state within a package subject to a null abstract
12267 Check_No_Hidden_State (State_Id);
12269 -- Check whether the lack of option Part_Of agrees with the
12270 -- placement of the abstract state with respect to the state
12273 if not Part_Of_Seen then
12274 Check_Missing_Part_Of (State_Id);
12277 -- Associate the state with its related package
12279 if No (Abstract_States (Pack_Id)) then
12280 Set_Abstract_States (Pack_Id, New_Elmt_List);
12283 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12285 end Analyze_Abstract_State;
12287 ---------------------------
12288 -- Malformed_State_Error --
12289 ---------------------------
12291 procedure Malformed_State_Error (State : Node_Id) is
12293 Error_Msg_N ("malformed abstract state declaration", State);
12295 -- An abstract state with a simple option is being declared
12296 -- with "=>" rather than the legal "with". The state appears
12297 -- as a component association.
12299 if Nkind (State) = N_Component_Association then
12300 Error_Msg_N ("\use WITH to specify simple option", State);
12302 end Malformed_State_Error;
12306 Pack_Decl : Node_Id;
12307 Pack_Id : Entity_Id;
12311 -- Start of processing for Abstract_State
12315 Check_No_Identifiers;
12316 Check_Arg_Count (1);
12318 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12320 if Nkind (Pack_Decl) not in
12321 N_Generic_Package_Declaration | N_Package_Declaration
12327 Pack_Id := Defining_Entity (Pack_Decl);
12329 -- A pragma that applies to a Ghost entity becomes Ghost for the
12330 -- purposes of legality checks and removal of ignored Ghost code.
12332 Mark_Ghost_Pragma (N, Pack_Id);
12333 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12335 -- Chain the pragma on the contract for completeness
12337 Add_Contract_Item (N, Pack_Id);
12339 -- The legality checks of pragmas Abstract_State, Initializes, and
12340 -- Initial_Condition are affected by the SPARK mode in effect. In
12341 -- addition, these three pragmas are subject to an inherent order:
12343 -- 1) Abstract_State
12345 -- 3) Initial_Condition
12347 -- Analyze all these pragmas in the order outlined above
12349 Analyze_If_Present (Pragma_SPARK_Mode);
12350 States := Expression (Get_Argument (N, Pack_Id));
12352 -- Multiple non-null abstract states appear as an aggregate
12354 if Nkind (States) = N_Aggregate then
12355 State := First (Expressions (States));
12356 while Present (State) loop
12357 Analyze_Abstract_State (State, Pack_Id);
12361 -- An abstract state with a simple option is being illegaly
12362 -- declared with "=>" rather than "with". In this case the
12363 -- state declaration appears as a component association.
12365 if Present (Component_Associations (States)) then
12366 State := First (Component_Associations (States));
12367 while Present (State) loop
12368 Malformed_State_Error (State);
12373 -- Various forms of a single abstract state. Note that these may
12374 -- include malformed state declarations.
12377 Analyze_Abstract_State (States, Pack_Id);
12380 Analyze_If_Present (Pragma_Initializes);
12381 Analyze_If_Present (Pragma_Initial_Condition);
12382 end Abstract_State;
12390 -- Note: this pragma also has some specific processing in Par.Prag
12391 -- because we want to set the Ada version mode during parsing.
12393 when Pragma_Ada_83 =>
12395 Check_Arg_Count (0);
12397 -- We really should check unconditionally for proper configuration
12398 -- pragma placement, since we really don't want mixed Ada modes
12399 -- within a single unit, and the GNAT reference manual has always
12400 -- said this was a configuration pragma, but we did not check and
12401 -- are hesitant to add the check now.
12403 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12404 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12405 -- or Ada 2012 mode.
12407 if Ada_Version >= Ada_2005 then
12408 Check_Valid_Configuration_Pragma;
12411 -- Now set Ada 83 mode
12413 if Latest_Ada_Only then
12414 Error_Pragma ("??pragma% ignored");
12416 Ada_Version := Ada_83;
12417 Ada_Version_Explicit := Ada_83;
12418 Ada_Version_Pragma := N;
12427 -- Note: this pragma also has some specific processing in Par.Prag
12428 -- because we want to set the Ada 83 version mode during parsing.
12430 when Pragma_Ada_95 =>
12432 Check_Arg_Count (0);
12434 -- We really should check unconditionally for proper configuration
12435 -- pragma placement, since we really don't want mixed Ada modes
12436 -- within a single unit, and the GNAT reference manual has always
12437 -- said this was a configuration pragma, but we did not check and
12438 -- are hesitant to add the check now.
12440 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12441 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12443 if Ada_Version >= Ada_2005 then
12444 Check_Valid_Configuration_Pragma;
12447 -- Now set Ada 95 mode
12449 if Latest_Ada_Only then
12450 Error_Pragma ("??pragma% ignored");
12452 Ada_Version := Ada_95;
12453 Ada_Version_Explicit := Ada_95;
12454 Ada_Version_Pragma := N;
12457 ---------------------
12458 -- Ada_05/Ada_2005 --
12459 ---------------------
12462 -- pragma Ada_05 (LOCAL_NAME);
12464 -- pragma Ada_2005;
12465 -- pragma Ada_2005 (LOCAL_NAME):
12467 -- Note: these pragmas also have some specific processing in Par.Prag
12468 -- because we want to set the Ada 2005 version mode during parsing.
12470 -- The one argument form is used for managing the transition from
12471 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12472 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12473 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12474 -- mode, a preference rule is established which does not choose
12475 -- such an entity unless it is unambiguously specified. This avoids
12476 -- extra subprograms marked this way from generating ambiguities in
12477 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12478 -- intended for exclusive use in the GNAT run-time library.
12489 if Arg_Count = 1 then
12490 Check_Arg_Is_Local_Name (Arg1);
12491 E_Id := Get_Pragma_Arg (Arg1);
12493 if Etype (E_Id) = Any_Type then
12497 Set_Is_Ada_2005_Only (Entity (E_Id));
12498 Record_Rep_Item (Entity (E_Id), N);
12501 Check_Arg_Count (0);
12503 -- For Ada_2005 we unconditionally enforce the documented
12504 -- configuration pragma placement, since we do not want to
12505 -- tolerate mixed modes in a unit involving Ada 2005. That
12506 -- would cause real difficulties for those cases where there
12507 -- are incompatibilities between Ada 95 and Ada 2005.
12509 Check_Valid_Configuration_Pragma;
12511 -- Now set appropriate Ada mode
12513 if Latest_Ada_Only then
12514 Error_Pragma ("??pragma% ignored");
12516 Ada_Version := Ada_2005;
12517 Ada_Version_Explicit := Ada_2005;
12518 Ada_Version_Pragma := N;
12523 ---------------------
12524 -- Ada_12/Ada_2012 --
12525 ---------------------
12528 -- pragma Ada_12 (LOCAL_NAME);
12530 -- pragma Ada_2012;
12531 -- pragma Ada_2012 (LOCAL_NAME):
12533 -- Note: these pragmas also have some specific processing in Par.Prag
12534 -- because we want to set the Ada 2012 version mode during parsing.
12536 -- The one argument form is used for managing the transition from Ada
12537 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12538 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12539 -- mode will generate a warning. In addition, in any pre-Ada_2012
12540 -- mode, a preference rule is established which does not choose
12541 -- such an entity unless it is unambiguously specified. This avoids
12542 -- extra subprograms marked this way from generating ambiguities in
12543 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12544 -- intended for exclusive use in the GNAT run-time library.
12555 if Arg_Count = 1 then
12556 Check_Arg_Is_Local_Name (Arg1);
12557 E_Id := Get_Pragma_Arg (Arg1);
12559 if Etype (E_Id) = Any_Type then
12563 Set_Is_Ada_2012_Only (Entity (E_Id));
12564 Record_Rep_Item (Entity (E_Id), N);
12567 Check_Arg_Count (0);
12569 -- For Ada_2012 we unconditionally enforce the documented
12570 -- configuration pragma placement, since we do not want to
12571 -- tolerate mixed modes in a unit involving Ada 2012. That
12572 -- would cause real difficulties for those cases where there
12573 -- are incompatibilities between Ada 95 and Ada 2012. We could
12574 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12576 Check_Valid_Configuration_Pragma;
12578 -- Now set appropriate Ada mode
12580 Ada_Version := Ada_2012;
12581 Ada_Version_Explicit := Ada_2012;
12582 Ada_Version_Pragma := N;
12590 -- pragma Ada_2020;
12592 -- Note: this pragma also has some specific processing in Par.Prag
12593 -- because we want to set the Ada 2020 version mode during parsing.
12595 when Pragma_Ada_2020 =>
12598 Check_Arg_Count (0);
12600 Check_Valid_Configuration_Pragma;
12602 -- Now set appropriate Ada mode
12604 Ada_Version := Ada_2020;
12605 Ada_Version_Explicit := Ada_2020;
12606 Ada_Version_Pragma := N;
12608 -------------------------------------
12609 -- Aggregate_Individually_Assign --
12610 -------------------------------------
12612 -- pragma Aggregate_Individually_Assign;
12614 when Pragma_Aggregate_Individually_Assign =>
12616 Check_Arg_Count (0);
12617 Check_Valid_Configuration_Pragma;
12618 Aggregate_Individually_Assign := True;
12620 ----------------------
12621 -- All_Calls_Remote --
12622 ----------------------
12624 -- pragma All_Calls_Remote [(library_package_NAME)];
12626 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12627 Lib_Entity : Entity_Id;
12630 Check_Ada_83_Warning;
12631 Check_Valid_Library_Unit_Pragma;
12633 if Nkind (N) = N_Null_Statement then
12637 Lib_Entity := Find_Lib_Unit_Name;
12639 -- A pragma that applies to a Ghost entity becomes Ghost for the
12640 -- purposes of legality checks and removal of ignored Ghost code.
12642 Mark_Ghost_Pragma (N, Lib_Entity);
12644 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12646 if Present (Lib_Entity) and then not Debug_Flag_U then
12647 if not Is_Remote_Call_Interface (Lib_Entity) then
12648 Error_Pragma ("pragma% only apply to rci unit");
12650 -- Set flag for entity of the library unit
12653 Set_Has_All_Calls_Remote (Lib_Entity);
12656 end All_Calls_Remote;
12658 ---------------------------
12659 -- Allow_Integer_Address --
12660 ---------------------------
12662 -- pragma Allow_Integer_Address;
12664 when Pragma_Allow_Integer_Address =>
12666 Check_Valid_Configuration_Pragma;
12667 Check_Arg_Count (0);
12669 -- If Address is a private type, then set the flag to allow
12670 -- integer address values. If Address is not private, then this
12671 -- pragma has no purpose, so it is simply ignored. Not clear if
12672 -- there are any such targets now.
12674 if Opt.Address_Is_Private then
12675 Opt.Allow_Integer_Address := True;
12683 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12684 -- ARG ::= NAME | EXPRESSION
12686 -- The first two arguments are by convention intended to refer to an
12687 -- external tool and a tool-specific function. These arguments are
12690 when Pragma_Annotate => Annotate : declare
12695 --------------------------
12696 -- Inferred_String_Type --
12697 --------------------------
12699 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12700 -- Infer the type to use for a string literal or a concatentation
12701 -- of operands whose types can be inferred. For such expressions,
12702 -- returns the "narrowest" of the three predefined string types
12703 -- that can represent the characters occurring in the expression.
12704 -- For other expressions, returns Empty.
12706 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12708 case Nkind (Expr) is
12709 when N_String_Literal =>
12710 if Has_Wide_Wide_Character (Expr) then
12711 return Standard_Wide_Wide_String;
12712 elsif Has_Wide_Character (Expr) then
12713 return Standard_Wide_String;
12715 return Standard_String;
12718 when N_Op_Concat =>
12720 L_Type : constant Entity_Id
12721 := Preferred_String_Type (Left_Opnd (Expr));
12722 R_Type : constant Entity_Id
12723 := Preferred_String_Type (Right_Opnd (Expr));
12725 Type_Table : constant array (1 .. 4) of Entity_Id
12727 Standard_Wide_Wide_String,
12728 Standard_Wide_String,
12731 for Idx in Type_Table'Range loop
12732 if (L_Type = Type_Table (Idx)) or
12733 (R_Type = Type_Table (Idx))
12735 return Type_Table (Idx);
12738 raise Program_Error;
12744 end Preferred_String_Type;
12747 Check_At_Least_N_Arguments (1);
12749 Nam_Arg := Last (Pragma_Argument_Associations (N));
12751 -- Determine whether the last argument is "Entity => local_NAME"
12752 -- and if it is, perform the required semantic checks. Remove the
12753 -- argument from further processing.
12755 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12756 and then Chars (Nam_Arg) = Name_Entity
12758 Check_Arg_Is_Local_Name (Nam_Arg);
12759 Arg_Count := Arg_Count - 1;
12761 -- A pragma that applies to a Ghost entity becomes Ghost for
12762 -- the purposes of legality checks and removal of ignored Ghost
12765 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12766 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12768 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12771 -- Not allowed in compiler units (bootstrap issues)
12773 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12776 -- Continue the processing with last argument removed for now
12778 Check_Arg_Is_Identifier (Arg1);
12779 Check_No_Identifiers;
12782 -- The second parameter is optional, it is never analyzed
12787 -- Otherwise there is a second parameter
12790 -- The second parameter must be an identifier
12792 Check_Arg_Is_Identifier (Arg2);
12794 -- Process the remaining parameters (if any)
12796 Arg := Next (Arg2);
12797 while Present (Arg) loop
12798 Expr := Get_Pragma_Arg (Arg);
12801 if Is_Entity_Name (Expr) then
12804 -- For string literals and concatenations of string literals
12805 -- we assume Standard_String as the type, unless the string
12806 -- contains wide or wide_wide characters.
12808 elsif Present (Preferred_String_Type (Expr)) then
12809 Resolve (Expr, Preferred_String_Type (Expr));
12811 elsif Is_Overloaded (Expr) then
12812 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12823 -------------------------------------------------
12824 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12825 -------------------------------------------------
12828 -- ( [Check => ] Boolean_EXPRESSION
12829 -- [, [Message =>] Static_String_EXPRESSION]);
12831 -- pragma Assert_And_Cut
12832 -- ( [Check => ] Boolean_EXPRESSION
12833 -- [, [Message =>] Static_String_EXPRESSION]);
12836 -- ( [Check => ] Boolean_EXPRESSION
12837 -- [, [Message =>] Static_String_EXPRESSION]);
12839 -- pragma Loop_Invariant
12840 -- ( [Check => ] Boolean_EXPRESSION
12841 -- [, [Message =>] Static_String_EXPRESSION]);
12844 | Pragma_Assert_And_Cut
12846 | Pragma_Loop_Invariant
12849 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12850 -- Determine whether expression Expr contains a Loop_Entry
12851 -- attribute reference.
12853 -------------------------
12854 -- Contains_Loop_Entry --
12855 -------------------------
12857 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12858 Has_Loop_Entry : Boolean := False;
12860 function Process (N : Node_Id) return Traverse_Result;
12861 -- Process function for traversal to look for Loop_Entry
12867 function Process (N : Node_Id) return Traverse_Result is
12869 if Nkind (N) = N_Attribute_Reference
12870 and then Attribute_Name (N) = Name_Loop_Entry
12872 Has_Loop_Entry := True;
12879 procedure Traverse is new Traverse_Proc (Process);
12881 -- Start of processing for Contains_Loop_Entry
12885 return Has_Loop_Entry;
12886 end Contains_Loop_Entry;
12891 New_Args : List_Id;
12893 -- Start of processing for Assert
12896 -- Assert is an Ada 2005 RM-defined pragma
12898 if Prag_Id = Pragma_Assert then
12901 -- The remaining ones are GNAT pragmas
12907 Check_At_Least_N_Arguments (1);
12908 Check_At_Most_N_Arguments (2);
12909 Check_Arg_Order ((Name_Check, Name_Message));
12910 Check_Optional_Identifier (Arg1, Name_Check);
12911 Expr := Get_Pragma_Arg (Arg1);
12913 -- Special processing for Loop_Invariant, Loop_Variant or for
12914 -- other cases where a Loop_Entry attribute is present. If the
12915 -- assertion pragma contains attribute Loop_Entry, ensure that
12916 -- the related pragma is within a loop.
12918 if Prag_Id = Pragma_Loop_Invariant
12919 or else Prag_Id = Pragma_Loop_Variant
12920 or else Contains_Loop_Entry (Expr)
12922 Check_Loop_Pragma_Placement;
12924 -- Perform preanalysis to deal with embedded Loop_Entry
12927 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12930 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12931 -- a corresponding Check pragma:
12933 -- pragma Check (name, condition [, msg]);
12935 -- Where name is the identifier matching the pragma name. So
12936 -- rewrite pragma in this manner, transfer the message argument
12937 -- if present, and analyze the result
12939 -- Note: When dealing with a semantically analyzed tree, the
12940 -- information that a Check node N corresponds to a source Assert,
12941 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12942 -- pragma kind of Original_Node(N).
12944 New_Args := New_List (
12945 Make_Pragma_Argument_Association (Loc,
12946 Expression => Make_Identifier (Loc, Pname)),
12947 Make_Pragma_Argument_Association (Sloc (Expr),
12948 Expression => Expr));
12950 if Arg_Count > 1 then
12951 Check_Optional_Identifier (Arg2, Name_Message);
12953 -- Provide semantic annotations for optional argument, for
12954 -- ASIS use, before rewriting.
12955 -- Is this still needed???
12957 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12958 Append_To (New_Args, New_Copy_Tree (Arg2));
12961 -- Rewrite as Check pragma
12965 Chars => Name_Check,
12966 Pragma_Argument_Associations => New_Args));
12971 ----------------------
12972 -- Assertion_Policy --
12973 ----------------------
12975 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12977 -- The following form is Ada 2012 only, but we allow it in all modes
12979 -- Pragma Assertion_Policy (
12980 -- ASSERTION_KIND => POLICY_IDENTIFIER
12981 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12983 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12985 -- RM_ASSERTION_KIND ::= Assert |
12986 -- Static_Predicate |
12987 -- Dynamic_Predicate |
12992 -- Type_Invariant |
12993 -- Type_Invariant'Class
12995 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12997 -- Contract_Cases |
12999 -- Default_Initial_Condition |
13001 -- Initial_Condition |
13002 -- Loop_Invariant |
13008 -- Statement_Assertions
13010 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13011 -- ID_ASSERTION_KIND list contains implementation-defined additions
13012 -- recognized by GNAT. The effect is to control the behavior of
13013 -- identically named aspects and pragmas, depending on the specified
13014 -- policy identifier:
13016 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13018 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13019 -- implementation-defined addition that results in totally ignoring
13020 -- the corresponding assertion. If Disable is specified, then the
13021 -- argument of the assertion is not even analyzed. This is useful
13022 -- when the aspect/pragma argument references entities in a with'ed
13023 -- package that is replaced by a dummy package in the final build.
13025 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13026 -- and Type_Invariant'Class were recognized by the parser and
13027 -- transformed into references to the special internal identifiers
13028 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13029 -- processing is required here.
13031 when Pragma_Assertion_Policy => Assertion_Policy : declare
13032 procedure Resolve_Suppressible (Policy : Node_Id);
13033 -- Converts the assertion policy 'Suppressible' to either Check or
13034 -- Ignore based on whether checks are suppressed via -gnatp.
13036 --------------------------
13037 -- Resolve_Suppressible --
13038 --------------------------
13040 procedure Resolve_Suppressible (Policy : Node_Id) is
13041 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13045 -- Transform policy argument Suppressible into either Ignore or
13046 -- Check depending on whether checks are enabled or suppressed.
13048 if Chars (Arg) = Name_Suppressible then
13049 if Suppress_Checks then
13050 Nam := Name_Ignore;
13055 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13057 end Resolve_Suppressible;
13069 -- This can always appear as a configuration pragma
13071 if Is_Configuration_Pragma then
13074 -- It can also appear in a declarative part or package spec in Ada
13075 -- 2012 mode. We allow this in other modes, but in that case we
13076 -- consider that we have an Ada 2012 pragma on our hands.
13079 Check_Is_In_Decl_Part_Or_Package_Spec;
13083 -- One argument case with no identifier (first form above)
13086 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13087 or else Chars (Arg1) = No_Name)
13089 Check_Arg_Is_One_Of (Arg1,
13090 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13092 Resolve_Suppressible (Arg1);
13094 -- Treat one argument Assertion_Policy as equivalent to:
13096 -- pragma Check_Policy (Assertion, policy)
13098 -- So rewrite pragma in that manner and link on to the chain
13099 -- of Check_Policy pragmas, marking the pragma as analyzed.
13101 Policy := Get_Pragma_Arg (Arg1);
13105 Chars => Name_Check_Policy,
13106 Pragma_Argument_Associations => New_List (
13107 Make_Pragma_Argument_Association (Loc,
13108 Expression => Make_Identifier (Loc, Name_Assertion)),
13110 Make_Pragma_Argument_Association (Loc,
13112 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13115 -- Here if we have two or more arguments
13118 Check_At_Least_N_Arguments (1);
13121 -- Loop through arguments
13124 while Present (Arg) loop
13125 LocP := Sloc (Arg);
13127 -- Kind must be specified
13129 if Nkind (Arg) /= N_Pragma_Argument_Association
13130 or else Chars (Arg) = No_Name
13133 ("missing assertion kind for pragma%", Arg);
13136 -- Check Kind and Policy have allowed forms
13138 Kind := Chars (Arg);
13139 Policy := Get_Pragma_Arg (Arg);
13141 if not Is_Valid_Assertion_Kind (Kind) then
13143 ("invalid assertion kind for pragma%", Arg);
13146 Check_Arg_Is_One_Of (Arg,
13147 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13149 Resolve_Suppressible (Arg);
13151 if Kind = Name_Ghost then
13153 -- The Ghost policy must be either Check or Ignore
13154 -- (SPARK RM 6.9(6)).
13156 if Chars (Policy) not in Name_Check | Name_Ignore then
13158 ("argument of pragma % Ghost must be Check or "
13159 & "Ignore", Policy);
13162 -- Pragma Assertion_Policy specifying a Ghost policy
13163 -- cannot occur within a Ghost subprogram or package
13164 -- (SPARK RM 6.9(14)).
13166 if Ghost_Mode > None then
13168 ("pragma % cannot appear within ghost subprogram or "
13173 -- Rewrite the Assertion_Policy pragma as a series of
13174 -- Check_Policy pragmas of the form:
13176 -- Check_Policy (Kind, Policy);
13178 -- Note: the insertion of the pragmas cannot be done with
13179 -- Insert_Action because in the configuration case, there
13180 -- are no scopes on the scope stack and the mechanism will
13183 Insert_Before_And_Analyze (N,
13185 Chars => Name_Check_Policy,
13186 Pragma_Argument_Associations => New_List (
13187 Make_Pragma_Argument_Association (LocP,
13188 Expression => Make_Identifier (LocP, Kind)),
13189 Make_Pragma_Argument_Association (LocP,
13190 Expression => Policy))));
13195 -- Rewrite the Assertion_Policy pragma as null since we have
13196 -- now inserted all the equivalent Check pragmas.
13198 Rewrite (N, Make_Null_Statement (Loc));
13201 end Assertion_Policy;
13203 ------------------------------
13204 -- Assume_No_Invalid_Values --
13205 ------------------------------
13207 -- pragma Assume_No_Invalid_Values (On | Off);
13209 when Pragma_Assume_No_Invalid_Values =>
13211 Check_Valid_Configuration_Pragma;
13212 Check_Arg_Count (1);
13213 Check_No_Identifiers;
13214 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13216 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13217 Assume_No_Invalid_Values := True;
13219 Assume_No_Invalid_Values := False;
13222 --------------------------
13223 -- Attribute_Definition --
13224 --------------------------
13226 -- pragma Attribute_Definition
13227 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13228 -- [Entity =>] LOCAL_NAME,
13229 -- [Expression =>] EXPRESSION | NAME);
13231 when Pragma_Attribute_Definition => Attribute_Definition : declare
13232 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13237 Check_Arg_Count (3);
13238 Check_Optional_Identifier (Arg1, "attribute");
13239 Check_Optional_Identifier (Arg2, "entity");
13240 Check_Optional_Identifier (Arg3, "expression");
13242 if Nkind (Attribute_Designator) /= N_Identifier then
13243 Error_Msg_N ("attribute name expected", Attribute_Designator);
13247 Check_Arg_Is_Local_Name (Arg2);
13249 -- If the attribute is not recognized, then issue a warning (not
13250 -- an error), and ignore the pragma.
13252 Aname := Chars (Attribute_Designator);
13254 if not Is_Attribute_Name (Aname) then
13255 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13259 -- Otherwise, rewrite the pragma as an attribute definition clause
13262 Make_Attribute_Definition_Clause (Loc,
13263 Name => Get_Pragma_Arg (Arg2),
13265 Expression => Get_Pragma_Arg (Arg3)));
13267 end Attribute_Definition;
13269 ------------------------------------------------------------------
13270 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13272 ------------------------------------------------------------------
13274 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13275 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13276 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13277 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13278 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13280 when Pragma_Async_Readers
13281 | Pragma_Async_Writers
13282 | Pragma_Effective_Reads
13283 | Pragma_Effective_Writes
13284 | Pragma_No_Caching
13286 Async_Effective : declare
13287 Obj_Or_Type_Decl : Node_Id;
13288 Obj_Or_Type_Id : Entity_Id;
13291 Check_No_Identifiers;
13292 Check_At_Most_N_Arguments (1);
13294 Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
13296 -- Pragma must apply to a object declaration or to a type
13297 -- declaration (only the former in the No_Caching case).
13298 -- Original_Node is necessary to account for untagged derived
13299 -- types that are rewritten as subtypes of their
13300 -- respective root types.
13302 if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then
13303 if Prag_Id = Pragma_No_Caching
13304 or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in
13305 N_Full_Type_Declaration |
13306 N_Private_Type_Declaration |
13307 N_Formal_Type_Declaration |
13308 N_Task_Type_Declaration |
13309 N_Protected_Type_Declaration
13316 Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
13318 -- Perform minimal verification to ensure that the argument is at
13319 -- least a variable or a type. Subsequent finer grained checks
13320 -- will be done at the end of the declarative region that
13321 -- contains the pragma.
13323 if Ekind (Obj_Or_Type_Id) = E_Variable
13324 or else Is_Type (Obj_Or_Type_Id)
13327 -- In the case of a type, pragma is a type-related
13328 -- representation item and so requires checks common to
13329 -- all type-related representation items.
13331 if Is_Type (Obj_Or_Type_Id)
13332 and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
13337 -- A pragma that applies to a Ghost entity becomes Ghost for
13338 -- the purposes of legality checks and removal of ignored Ghost
13341 Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
13343 -- Chain the pragma on the contract for further processing by
13344 -- Analyze_External_Property_In_Decl_Part.
13346 Add_Contract_Item (N, Obj_Or_Type_Id);
13348 -- Analyze the Boolean expression (if any)
13350 if Present (Arg1) then
13351 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13354 -- Otherwise the external property applies to a constant
13358 ("pragma % must apply to a volatile type or object");
13360 end Async_Effective;
13366 -- pragma Asynchronous (LOCAL_NAME);
13368 when Pragma_Asynchronous => Asynchronous : declare
13371 Formal : Entity_Id;
13376 procedure Process_Async_Pragma;
13377 -- Common processing for procedure and access-to-procedure case
13379 --------------------------
13380 -- Process_Async_Pragma --
13381 --------------------------
13383 procedure Process_Async_Pragma is
13386 Set_Is_Asynchronous (Nm);
13390 -- The formals should be of mode IN (RM E.4.1(6))
13393 while Present (S) loop
13394 Formal := Defining_Identifier (S);
13396 if Nkind (Formal) = N_Defining_Identifier
13397 and then Ekind (Formal) /= E_In_Parameter
13400 ("pragma% procedure can only have IN parameter",
13407 Set_Is_Asynchronous (Nm);
13408 end Process_Async_Pragma;
13410 -- Start of processing for pragma Asynchronous
13413 Check_Ada_83_Warning;
13414 Check_No_Identifiers;
13415 Check_Arg_Count (1);
13416 Check_Arg_Is_Local_Name (Arg1);
13418 if Debug_Flag_U then
13422 C_Ent := Cunit_Entity (Current_Sem_Unit);
13423 Analyze (Get_Pragma_Arg (Arg1));
13424 Nm := Entity (Get_Pragma_Arg (Arg1));
13426 -- A pragma that applies to a Ghost entity becomes Ghost for the
13427 -- purposes of legality checks and removal of ignored Ghost code.
13429 Mark_Ghost_Pragma (N, Nm);
13431 if not Is_Remote_Call_Interface (C_Ent)
13432 and then not Is_Remote_Types (C_Ent)
13434 -- This pragma should only appear in an RCI or Remote Types
13435 -- unit (RM E.4.1(4)).
13438 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13441 if Ekind (Nm) = E_Procedure
13442 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13444 if not Is_Remote_Call_Interface (Nm) then
13446 ("pragma% cannot be applied on non-remote procedure",
13450 L := Parameter_Specifications (Parent (Nm));
13451 Process_Async_Pragma;
13454 elsif Ekind (Nm) = E_Function then
13456 ("pragma% cannot be applied to function", Arg1);
13458 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13459 if Is_Record_Type (Nm) then
13461 -- A record type that is the Equivalent_Type for a remote
13462 -- access-to-subprogram type.
13464 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13467 -- A non-expanded RAS type (distribution is not enabled)
13469 Decl := Declaration_Node (Nm);
13472 if Nkind (Decl) = N_Full_Type_Declaration
13473 and then Nkind (Type_Definition (Decl)) =
13474 N_Access_Procedure_Definition
13476 L := Parameter_Specifications (Type_Definition (Decl));
13477 Process_Async_Pragma;
13479 if Is_Asynchronous (Nm)
13480 and then Expander_Active
13481 and then Get_PCS_Name /= Name_No_DSA
13483 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13488 ("pragma% cannot reference access-to-function type",
13492 -- Only other possibility is Access-to-class-wide type
13494 elsif Is_Access_Type (Nm)
13495 and then Is_Class_Wide_Type (Designated_Type (Nm))
13497 Check_First_Subtype (Arg1);
13498 Set_Is_Asynchronous (Nm);
13499 if Expander_Active then
13500 RACW_Type_Is_Asynchronous (Nm);
13504 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13512 -- pragma Atomic (LOCAL_NAME);
13514 when Pragma_Atomic =>
13515 Process_Atomic_Independent_Shared_Volatile;
13517 -----------------------
13518 -- Atomic_Components --
13519 -----------------------
13521 -- pragma Atomic_Components (array_LOCAL_NAME);
13523 -- This processing is shared by Volatile_Components
13525 when Pragma_Atomic_Components
13526 | Pragma_Volatile_Components
13528 Atomic_Components : declare
13534 Check_Ada_83_Warning;
13535 Check_No_Identifiers;
13536 Check_Arg_Count (1);
13537 Check_Arg_Is_Local_Name (Arg1);
13538 E_Id := Get_Pragma_Arg (Arg1);
13540 if Etype (E_Id) = Any_Type then
13544 E := Entity (E_Id);
13546 -- A pragma that applies to a Ghost entity becomes Ghost for the
13547 -- purposes of legality checks and removal of ignored Ghost code.
13549 Mark_Ghost_Pragma (N, E);
13550 Check_Duplicate_Pragma (E);
13552 if Rep_Item_Too_Early (E, N)
13554 Rep_Item_Too_Late (E, N)
13559 D := Declaration_Node (E);
13561 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13563 (Nkind (D) = N_Object_Declaration
13564 and then Ekind (E) in E_Constant | E_Variable
13565 and then Nkind (Object_Definition (D)) =
13566 N_Constrained_Array_Definition)
13568 (Ada_Version >= Ada_2020
13569 and then Nkind (D) = N_Formal_Type_Declaration)
13571 -- The flag is set on the base type, or on the object
13573 if Nkind (D) = N_Full_Type_Declaration then
13574 E := Base_Type (E);
13577 -- Atomic implies both Independent and Volatile
13579 if Prag_Id = Pragma_Atomic_Components then
13580 if Ada_Version >= Ada_2020 then
13582 (Component_Type (Etype (E)), VFA => False);
13585 Set_Has_Atomic_Components (E);
13586 Set_Has_Independent_Components (E);
13589 Set_Has_Volatile_Components (E);
13592 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13594 end Atomic_Components;
13596 --------------------
13597 -- Attach_Handler --
13598 --------------------
13600 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13602 when Pragma_Attach_Handler =>
13603 Check_Ada_83_Warning;
13604 Check_No_Identifiers;
13605 Check_Arg_Count (2);
13607 if No_Run_Time_Mode then
13608 Error_Msg_CRT ("Attach_Handler pragma", N);
13610 Check_Interrupt_Or_Attach_Handler;
13612 -- The expression that designates the attribute may depend on a
13613 -- discriminant, and is therefore a per-object expression, to
13614 -- be expanded in the init proc. If expansion is enabled, then
13615 -- perform semantic checks on a copy only.
13620 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13623 -- In Relaxed_RM_Semantics mode, we allow any static
13624 -- integer value, for compatibility with other compilers.
13626 if Relaxed_RM_Semantics
13627 and then Nkind (Parg2) = N_Integer_Literal
13629 Typ := Standard_Integer;
13631 Typ := RTE (RE_Interrupt_ID);
13634 if Expander_Active then
13635 Temp := New_Copy_Tree (Parg2);
13636 Set_Parent (Temp, N);
13637 Preanalyze_And_Resolve (Temp, Typ);
13640 Resolve (Parg2, Typ);
13644 Process_Interrupt_Or_Attach_Handler;
13647 --------------------
13648 -- C_Pass_By_Copy --
13649 --------------------
13651 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13653 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13659 Check_Valid_Configuration_Pragma;
13660 Check_Arg_Count (1);
13661 Check_Optional_Identifier (Arg1, "max_size");
13663 Arg := Get_Pragma_Arg (Arg1);
13664 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13666 Val := Expr_Value (Arg);
13670 ("maximum size for pragma% must be positive", Arg1);
13672 elsif UI_Is_In_Int_Range (Val) then
13673 Default_C_Record_Mechanism := UI_To_Int (Val);
13675 -- If a giant value is given, Int'Last will do well enough.
13676 -- If sometime someone complains that a record larger than
13677 -- two gigabytes is not copied, we will worry about it then.
13680 Default_C_Record_Mechanism := Mechanism_Type'Last;
13682 end C_Pass_By_Copy;
13688 -- pragma Check ([Name =>] CHECK_KIND,
13689 -- [Check =>] Boolean_EXPRESSION
13690 -- [,[Message =>] String_EXPRESSION]);
13692 -- CHECK_KIND ::= IDENTIFIER |
13695 -- Invariant'Class |
13696 -- Type_Invariant'Class
13698 -- The identifiers Assertions and Statement_Assertions are not
13699 -- allowed, since they have special meaning for Check_Policy.
13701 -- WARNING: The code below manages Ghost regions. Return statements
13702 -- must be replaced by gotos which jump to the end of the code and
13703 -- restore the Ghost mode.
13705 when Pragma_Check => Check : declare
13706 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13707 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13708 -- Save the Ghost-related attributes to restore on exit
13714 pragma Warnings (Off, Str);
13717 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13718 -- the mode now to ensure that any nodes generated during analysis
13719 -- and expansion are marked as Ghost.
13721 Set_Ghost_Mode (N);
13724 Check_At_Least_N_Arguments (2);
13725 Check_At_Most_N_Arguments (3);
13726 Check_Optional_Identifier (Arg1, Name_Name);
13727 Check_Optional_Identifier (Arg2, Name_Check);
13729 if Arg_Count = 3 then
13730 Check_Optional_Identifier (Arg3, Name_Message);
13731 Str := Get_Pragma_Arg (Arg3);
13734 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13735 Check_Arg_Is_Identifier (Arg1);
13736 Cname := Chars (Get_Pragma_Arg (Arg1));
13738 -- Check forbidden name Assertions or Statement_Assertions
13741 when Name_Assertions =>
13743 ("""Assertions"" is not allowed as a check kind for "
13744 & "pragma%", Arg1);
13746 when Name_Statement_Assertions =>
13748 ("""Statement_Assertions"" is not allowed as a check kind "
13749 & "for pragma%", Arg1);
13755 -- Check applicable policy. We skip this if Checked/Ignored status
13756 -- is already set (e.g. in the case of a pragma from an aspect).
13758 if Is_Checked (N) or else Is_Ignored (N) then
13761 -- For a non-source pragma that is a rewriting of another pragma,
13762 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13764 elsif Is_Rewrite_Substitution (N)
13765 and then Nkind (Original_Node (N)) = N_Pragma
13767 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13768 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13770 -- Otherwise query the applicable policy at this point
13773 case Check_Kind (Cname) is
13774 when Name_Ignore =>
13775 Set_Is_Ignored (N, True);
13776 Set_Is_Checked (N, False);
13779 Set_Is_Ignored (N, False);
13780 Set_Is_Checked (N, True);
13782 -- For disable, rewrite pragma as null statement and skip
13783 -- rest of the analysis of the pragma.
13785 when Name_Disable =>
13786 Rewrite (N, Make_Null_Statement (Loc));
13790 -- No other possibilities
13793 raise Program_Error;
13797 -- If check kind was not Disable, then continue pragma analysis
13799 Expr := Get_Pragma_Arg (Arg2);
13801 -- Mark the pragma (or, if rewritten from an aspect, the original
13802 -- aspect) as enabled. Nothing to do for an internally generated
13803 -- check for a dynamic predicate.
13806 and then not Split_PPC (N)
13807 and then Cname /= Name_Dynamic_Predicate
13809 Set_SCO_Pragma_Enabled (Loc);
13812 -- Deal with analyzing the string argument. If checks are not
13813 -- on we don't want any expansion (since such expansion would
13814 -- not get properly deleted) but we do want to analyze (to get
13815 -- proper references). The Preanalyze_And_Resolve routine does
13816 -- just what we want. Ditto if pragma is active, because it will
13817 -- be rewritten as an if-statement whose analysis will complete
13818 -- analysis and expansion of the string message. This makes a
13819 -- difference in the unusual case where the expression for the
13820 -- string may have a side effect, such as raising an exception.
13821 -- This is mandated by RM 11.4.2, which specifies that the string
13822 -- expression is only evaluated if the check fails and
13823 -- Assertion_Error is to be raised.
13825 if Arg_Count = 3 then
13826 Preanalyze_And_Resolve (Str, Standard_String);
13829 -- Now you might think we could just do the same with the Boolean
13830 -- expression if checks are off (and expansion is on) and then
13831 -- rewrite the check as a null statement. This would work but we
13832 -- would lose the useful warnings about an assertion being bound
13833 -- to fail even if assertions are turned off.
13835 -- So instead we wrap the boolean expression in an if statement
13836 -- that looks like:
13838 -- if False and then condition then
13842 -- The reason we do this rewriting during semantic analysis rather
13843 -- than as part of normal expansion is that we cannot analyze and
13844 -- expand the code for the boolean expression directly, or it may
13845 -- cause insertion of actions that would escape the attempt to
13846 -- suppress the check code.
13848 -- Note that the Sloc for the if statement corresponds to the
13849 -- argument condition, not the pragma itself. The reason for
13850 -- this is that we may generate a warning if the condition is
13851 -- False at compile time, and we do not want to delete this
13852 -- warning when we delete the if statement.
13854 if Expander_Active and Is_Ignored (N) then
13855 Eloc := Sloc (Expr);
13858 Make_If_Statement (Eloc,
13860 Make_And_Then (Eloc,
13861 Left_Opnd => Make_Identifier (Eloc, Name_False),
13862 Right_Opnd => Expr),
13863 Then_Statements => New_List (
13864 Make_Null_Statement (Eloc))));
13866 -- Now go ahead and analyze the if statement
13868 In_Assertion_Expr := In_Assertion_Expr + 1;
13870 -- One rather special treatment. If we are now in Eliminated
13871 -- overflow mode, then suppress overflow checking since we do
13872 -- not want to drag in the bignum stuff if we are in Ignore
13873 -- mode anyway. This is particularly important if we are using
13874 -- a configurable run time that does not support bignum ops.
13876 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13878 Svo : constant Boolean :=
13879 Scope_Suppress.Suppress (Overflow_Check);
13881 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13882 Scope_Suppress.Suppress (Overflow_Check) := True;
13884 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13885 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13888 -- Not that special case
13894 -- All done with this check
13896 In_Assertion_Expr := In_Assertion_Expr - 1;
13898 -- Check is active or expansion not active. In these cases we can
13899 -- just go ahead and analyze the boolean with no worries.
13902 In_Assertion_Expr := In_Assertion_Expr + 1;
13903 Analyze_And_Resolve (Expr, Any_Boolean);
13904 In_Assertion_Expr := In_Assertion_Expr - 1;
13907 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13910 --------------------------
13911 -- Check_Float_Overflow --
13912 --------------------------
13914 -- pragma Check_Float_Overflow;
13916 when Pragma_Check_Float_Overflow =>
13918 Check_Valid_Configuration_Pragma;
13919 Check_Arg_Count (0);
13920 Check_Float_Overflow := not Machine_Overflows_On_Target;
13926 -- pragma Check_Name (check_IDENTIFIER);
13928 when Pragma_Check_Name =>
13930 Check_No_Identifiers;
13931 Check_Valid_Configuration_Pragma;
13932 Check_Arg_Count (1);
13933 Check_Arg_Is_Identifier (Arg1);
13936 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13939 for J in Check_Names.First .. Check_Names.Last loop
13940 if Check_Names.Table (J) = Nam then
13945 Check_Names.Append (Nam);
13952 -- This is the old style syntax, which is still allowed in all modes:
13954 -- pragma Check_Policy ([Name =>] CHECK_KIND
13955 -- [Policy =>] POLICY_IDENTIFIER);
13957 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13959 -- CHECK_KIND ::= IDENTIFIER |
13962 -- Type_Invariant'Class |
13965 -- This is the new style syntax, compatible with Assertion_Policy
13966 -- and also allowed in all modes.
13968 -- Pragma Check_Policy (
13969 -- CHECK_KIND => POLICY_IDENTIFIER
13970 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13972 -- Note: the identifiers Name and Policy are not allowed as
13973 -- Check_Kind values. This avoids ambiguities between the old and
13974 -- new form syntax.
13976 when Pragma_Check_Policy => Check_Policy : declare
13981 Check_At_Least_N_Arguments (1);
13983 -- A Check_Policy pragma can appear either as a configuration
13984 -- pragma, or in a declarative part or a package spec (see RM
13985 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13986 -- followed for Check_Policy).
13988 if not Is_Configuration_Pragma then
13989 Check_Is_In_Decl_Part_Or_Package_Spec;
13992 -- Figure out if we have the old or new syntax. We have the
13993 -- old syntax if the first argument has no identifier, or the
13994 -- identifier is Name.
13996 if Nkind (Arg1) /= N_Pragma_Argument_Association
13997 or else Chars (Arg1) in No_Name | Name_Name
14001 Check_Arg_Count (2);
14002 Check_Optional_Identifier (Arg1, Name_Name);
14003 Kind := Get_Pragma_Arg (Arg1);
14004 Rewrite_Assertion_Kind (Kind,
14005 From_Policy => Comes_From_Source (N));
14006 Check_Arg_Is_Identifier (Arg1);
14008 -- Check forbidden check kind
14010 if Chars (Kind) in Name_Name | Name_Policy then
14011 Error_Msg_Name_2 := Chars (Kind);
14013 ("pragma% does not allow% as check name", Arg1);
14018 Check_Optional_Identifier (Arg2, Name_Policy);
14019 Check_Arg_Is_One_Of
14021 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14023 -- And chain pragma on the Check_Policy_List for search
14025 Set_Next_Pragma (N, Opt.Check_Policy_List);
14026 Opt.Check_Policy_List := N;
14028 -- For the new syntax, what we do is to convert each argument to
14029 -- an old syntax equivalent. We do that because we want to chain
14030 -- old style Check_Policy pragmas for the search (we don't want
14031 -- to have to deal with multiple arguments in the search).
14042 while Present (Arg) loop
14043 LocP := Sloc (Arg);
14044 Argx := Get_Pragma_Arg (Arg);
14046 -- Kind must be specified
14048 if Nkind (Arg) /= N_Pragma_Argument_Association
14049 or else Chars (Arg) = No_Name
14052 ("missing assertion kind for pragma%", Arg);
14055 -- Construct equivalent old form syntax Check_Policy
14056 -- pragma and insert it to get remaining checks.
14060 Chars => Name_Check_Policy,
14061 Pragma_Argument_Associations => New_List (
14062 Make_Pragma_Argument_Association (LocP,
14064 Make_Identifier (LocP, Chars (Arg))),
14065 Make_Pragma_Argument_Association (Sloc (Argx),
14066 Expression => Argx)));
14070 -- For a configuration pragma, insert old form in
14071 -- the corresponding file.
14073 if Is_Configuration_Pragma then
14074 Insert_After (N, New_P);
14078 Insert_Action (N, New_P);
14082 -- Rewrite original Check_Policy pragma to null, since we
14083 -- have converted it into a series of old syntax pragmas.
14085 Rewrite (N, Make_Null_Statement (Loc));
14095 -- pragma Comment (static_string_EXPRESSION)
14097 -- Processing for pragma Comment shares the circuitry for pragma
14098 -- Ident. The only differences are that Ident enforces a limit of 31
14099 -- characters on its argument, and also enforces limitations on
14100 -- placement for DEC compatibility. Pragma Comment shares neither of
14101 -- these restrictions.
14103 -------------------
14104 -- Common_Object --
14105 -------------------
14107 -- pragma Common_Object (
14108 -- [Internal =>] LOCAL_NAME
14109 -- [, [External =>] EXTERNAL_SYMBOL]
14110 -- [, [Size =>] EXTERNAL_SYMBOL]);
14112 -- Processing for this pragma is shared with Psect_Object
14114 ----------------------------------------------
14115 -- Compile_Time_Error, Compile_Time_Warning --
14116 ----------------------------------------------
14118 -- pragma Compile_Time_Error
14119 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14121 -- pragma Compile_Time_Warning
14122 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14124 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14126 Process_Compile_Time_Warning_Or_Error;
14128 ---------------------------
14129 -- Compiler_Unit_Warning --
14130 ---------------------------
14132 -- pragma Compiler_Unit_Warning;
14136 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14137 -- errors not warnings. This means that we had introduced a big extra
14138 -- inertia to compiler changes, since even if we implemented a new
14139 -- feature, and even if all versions to be used for bootstrapping
14140 -- implemented this new feature, we could not use it, since old
14141 -- compilers would give errors for using this feature in units
14142 -- having Compiler_Unit pragmas.
14144 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14145 -- problem. We no longer have any units mentioning Compiler_Unit,
14146 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14147 -- and thus generates a warning which can be ignored. So that deals
14148 -- with the problem of old compilers not implementing the newer form
14151 -- Newer compilers recognize the new pragma, but generate warning
14152 -- messages instead of errors, which again can be ignored in the
14153 -- case of an old compiler which implements a wanted new feature
14154 -- but at the time felt like warning about it for older compilers.
14156 -- We retain Compiler_Unit so that new compilers can be used to build
14157 -- older run-times that use this pragma. That's an unusual case, but
14158 -- it's easy enough to handle, so why not?
14160 when Pragma_Compiler_Unit
14161 | Pragma_Compiler_Unit_Warning
14164 Check_Arg_Count (0);
14166 -- Only recognized in main unit
14168 if Current_Sem_Unit = Main_Unit then
14169 Compiler_Unit := True;
14172 -----------------------------
14173 -- Complete_Representation --
14174 -----------------------------
14176 -- pragma Complete_Representation;
14178 when Pragma_Complete_Representation =>
14180 Check_Arg_Count (0);
14182 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14184 ("pragma & must appear within record representation clause");
14187 ----------------------------
14188 -- Complex_Representation --
14189 ----------------------------
14191 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14193 when Pragma_Complex_Representation => Complex_Representation : declare
14200 Check_Arg_Count (1);
14201 Check_Optional_Identifier (Arg1, Name_Entity);
14202 Check_Arg_Is_Local_Name (Arg1);
14203 E_Id := Get_Pragma_Arg (Arg1);
14205 if Etype (E_Id) = Any_Type then
14209 E := Entity (E_Id);
14211 if not Is_Record_Type (E) then
14213 ("argument for pragma% must be record type", Arg1);
14216 Ent := First_Entity (E);
14219 or else No (Next_Entity (Ent))
14220 or else Present (Next_Entity (Next_Entity (Ent)))
14221 or else not Is_Floating_Point_Type (Etype (Ent))
14222 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14225 ("record for pragma% must have two fields of the same "
14226 & "floating-point type", Arg1);
14229 Set_Has_Complex_Representation (Base_Type (E));
14231 -- We need to treat the type has having a non-standard
14232 -- representation, for back-end purposes, even though in
14233 -- general a complex will have the default representation
14234 -- of a record with two real components.
14236 Set_Has_Non_Standard_Rep (Base_Type (E));
14238 end Complex_Representation;
14240 -------------------------
14241 -- Component_Alignment --
14242 -------------------------
14244 -- pragma Component_Alignment (
14245 -- [Form =>] ALIGNMENT_CHOICE
14246 -- [, [Name =>] type_LOCAL_NAME]);
14248 -- ALIGNMENT_CHOICE ::=
14250 -- | Component_Size_4
14254 when Pragma_Component_Alignment => Component_AlignmentP : declare
14255 Args : Args_List (1 .. 2);
14256 Names : constant Name_List (1 .. 2) := (
14260 Form : Node_Id renames Args (1);
14261 Name : Node_Id renames Args (2);
14263 Atype : Component_Alignment_Kind;
14268 Gather_Associations (Names, Args);
14271 Error_Pragma ("missing Form argument for pragma%");
14274 Check_Arg_Is_Identifier (Form);
14276 -- Get proper alignment, note that Default = Component_Size on all
14277 -- machines we have so far, and we want to set this value rather
14278 -- than the default value to indicate that it has been explicitly
14279 -- set (and thus will not get overridden by the default component
14280 -- alignment for the current scope)
14282 if Chars (Form) = Name_Component_Size then
14283 Atype := Calign_Component_Size;
14285 elsif Chars (Form) = Name_Component_Size_4 then
14286 Atype := Calign_Component_Size_4;
14288 elsif Chars (Form) = Name_Default then
14289 Atype := Calign_Component_Size;
14291 elsif Chars (Form) = Name_Storage_Unit then
14292 Atype := Calign_Storage_Unit;
14296 ("invalid Form parameter for pragma%", Form);
14299 -- The pragma appears in a configuration file
14301 if No (Parent (N)) then
14302 Check_Valid_Configuration_Pragma;
14304 -- Capture the component alignment in a global variable when
14305 -- the pragma appears in a configuration file. Note that the
14306 -- scope stack is empty at this point and cannot be used to
14307 -- store the alignment value.
14309 Configuration_Component_Alignment := Atype;
14311 -- Case with no name, supplied, affects scope table entry
14313 elsif No (Name) then
14315 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14317 -- Case of name supplied
14320 Check_Arg_Is_Local_Name (Name);
14322 Typ := Entity (Name);
14325 or else Rep_Item_Too_Early (Typ, N)
14329 Typ := Underlying_Type (Typ);
14332 if not Is_Record_Type (Typ)
14333 and then not Is_Array_Type (Typ)
14336 ("Name parameter of pragma% must identify record or "
14337 & "array type", Name);
14340 -- An explicit Component_Alignment pragma overrides an
14341 -- implicit pragma Pack, but not an explicit one.
14343 if not Has_Pragma_Pack (Base_Type (Typ)) then
14344 Set_Is_Packed (Base_Type (Typ), False);
14345 Set_Component_Alignment (Base_Type (Typ), Atype);
14348 end Component_AlignmentP;
14350 --------------------------------
14351 -- Constant_After_Elaboration --
14352 --------------------------------
14354 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14356 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14358 Obj_Decl : Node_Id;
14359 Obj_Id : Entity_Id;
14363 Check_No_Identifiers;
14364 Check_At_Most_N_Arguments (1);
14366 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14368 if Nkind (Obj_Decl) /= N_Object_Declaration then
14373 Obj_Id := Defining_Entity (Obj_Decl);
14375 -- The object declaration must be a library-level variable which
14376 -- is either explicitly initialized or obtains a value during the
14377 -- elaboration of a package body (SPARK RM 3.3.1).
14379 if Ekind (Obj_Id) = E_Variable then
14380 if not Is_Library_Level_Entity (Obj_Id) then
14382 ("pragma % must apply to a library level variable");
14386 -- Otherwise the pragma applies to a constant, which is illegal
14389 Error_Pragma ("pragma % must apply to a variable declaration");
14393 -- A pragma that applies to a Ghost entity becomes Ghost for the
14394 -- purposes of legality checks and removal of ignored Ghost code.
14396 Mark_Ghost_Pragma (N, Obj_Id);
14398 -- Chain the pragma on the contract for completeness
14400 Add_Contract_Item (N, Obj_Id);
14402 -- Analyze the Boolean expression (if any)
14404 if Present (Arg1) then
14405 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14407 end Constant_After_Elaboration;
14409 --------------------
14410 -- Contract_Cases --
14411 --------------------
14413 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14415 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14417 -- CASE_GUARD ::= boolean_EXPRESSION | others
14419 -- CONSEQUENCE ::= boolean_EXPRESSION
14421 -- Characteristics:
14423 -- * Analysis - The annotation undergoes initial checks to verify
14424 -- the legal placement and context. Secondary checks preanalyze the
14427 -- Analyze_Contract_Cases_In_Decl_Part
14429 -- * Expansion - The annotation is expanded during the expansion of
14430 -- the related subprogram [body] contract as performed in:
14432 -- Expand_Subprogram_Contract
14434 -- * Template - The annotation utilizes the generic template of the
14435 -- related subprogram [body] when it is:
14437 -- aspect on subprogram declaration
14438 -- aspect on stand-alone subprogram body
14439 -- pragma on stand-alone subprogram body
14441 -- The annotation must prepare its own template when it is:
14443 -- pragma on subprogram declaration
14445 -- * Globals - Capture of global references must occur after full
14448 -- * Instance - The annotation is instantiated automatically when
14449 -- the related generic subprogram [body] is instantiated except for
14450 -- the "pragma on subprogram declaration" case. In that scenario
14451 -- the annotation must instantiate itself.
14453 when Pragma_Contract_Cases => Contract_Cases : declare
14454 Spec_Id : Entity_Id;
14455 Subp_Decl : Node_Id;
14456 Subp_Spec : Node_Id;
14460 Check_No_Identifiers;
14461 Check_Arg_Count (1);
14463 -- Ensure the proper placement of the pragma. Contract_Cases must
14464 -- be associated with a subprogram declaration or a body that acts
14468 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14472 if Nkind (Subp_Decl) = N_Entry_Declaration then
14475 -- Generic subprogram
14477 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14480 -- Body acts as spec
14482 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14483 and then No (Corresponding_Spec (Subp_Decl))
14487 -- Body stub acts as spec
14489 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14490 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14496 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14497 Subp_Spec := Specification (Subp_Decl);
14499 -- Pragma Contract_Cases is forbidden on null procedures, as
14500 -- this may lead to potential ambiguities in behavior when
14501 -- interface null procedures are involved.
14503 if Nkind (Subp_Spec) = N_Procedure_Specification
14504 and then Null_Present (Subp_Spec)
14506 Error_Msg_N (Fix_Error
14507 ("pragma % cannot apply to null procedure"), N);
14516 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14518 -- A pragma that applies to a Ghost entity becomes Ghost for the
14519 -- purposes of legality checks and removal of ignored Ghost code.
14521 Mark_Ghost_Pragma (N, Spec_Id);
14522 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14524 -- Chain the pragma on the contract for further processing by
14525 -- Analyze_Contract_Cases_In_Decl_Part.
14527 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14529 -- Fully analyze the pragma when it appears inside an entry
14530 -- or subprogram body because it cannot benefit from forward
14533 if Nkind (Subp_Decl) in N_Entry_Body
14534 | N_Subprogram_Body
14535 | N_Subprogram_Body_Stub
14537 -- The legality checks of pragma Contract_Cases are affected by
14538 -- the SPARK mode in effect and the volatility of the context.
14539 -- Analyze all pragmas in a specific order.
14541 Analyze_If_Present (Pragma_SPARK_Mode);
14542 Analyze_If_Present (Pragma_Volatile_Function);
14543 Analyze_Contract_Cases_In_Decl_Part (N);
14545 end Contract_Cases;
14551 -- pragma Controlled (first_subtype_LOCAL_NAME);
14553 when Pragma_Controlled => Controlled : declare
14557 Check_No_Identifiers;
14558 Check_Arg_Count (1);
14559 Check_Arg_Is_Local_Name (Arg1);
14560 Arg := Get_Pragma_Arg (Arg1);
14562 if not Is_Entity_Name (Arg)
14563 or else not Is_Access_Type (Entity (Arg))
14565 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14567 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14575 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14576 -- [Entity =>] LOCAL_NAME);
14578 when Pragma_Convention => Convention : declare
14581 pragma Warnings (Off, C);
14582 pragma Warnings (Off, E);
14585 Check_Arg_Order ((Name_Convention, Name_Entity));
14586 Check_Ada_83_Warning;
14587 Check_Arg_Count (2);
14588 Process_Convention (C, E);
14590 -- A pragma that applies to a Ghost entity becomes Ghost for the
14591 -- purposes of legality checks and removal of ignored Ghost code.
14593 Mark_Ghost_Pragma (N, E);
14596 ---------------------------
14597 -- Convention_Identifier --
14598 ---------------------------
14600 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14601 -- [Convention =>] convention_IDENTIFIER);
14603 when Pragma_Convention_Identifier => Convention_Identifier : declare
14609 Check_Arg_Order ((Name_Name, Name_Convention));
14610 Check_Arg_Count (2);
14611 Check_Optional_Identifier (Arg1, Name_Name);
14612 Check_Optional_Identifier (Arg2, Name_Convention);
14613 Check_Arg_Is_Identifier (Arg1);
14614 Check_Arg_Is_Identifier (Arg2);
14615 Idnam := Chars (Get_Pragma_Arg (Arg1));
14616 Cname := Chars (Get_Pragma_Arg (Arg2));
14618 if Is_Convention_Name (Cname) then
14619 Record_Convention_Identifier
14620 (Idnam, Get_Convention_Id (Cname));
14623 ("second arg for % pragma must be convention", Arg2);
14625 end Convention_Identifier;
14631 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14633 when Pragma_CPP_Class =>
14636 if Warn_On_Obsolescent_Feature then
14638 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14639 & "effect; replace it by pragma import?j?", N);
14642 Check_Arg_Count (1);
14646 Chars => Name_Import,
14647 Pragma_Argument_Associations => New_List (
14648 Make_Pragma_Argument_Association (Loc,
14649 Expression => Make_Identifier (Loc, Name_CPP)),
14650 New_Copy (First (Pragma_Argument_Associations (N))))));
14653 ---------------------
14654 -- CPP_Constructor --
14655 ---------------------
14657 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14658 -- [, [External_Name =>] static_string_EXPRESSION ]
14659 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14661 when Pragma_CPP_Constructor => CPP_Constructor : declare
14664 Def_Id : Entity_Id;
14665 Tag_Typ : Entity_Id;
14669 Check_At_Least_N_Arguments (1);
14670 Check_At_Most_N_Arguments (3);
14671 Check_Optional_Identifier (Arg1, Name_Entity);
14672 Check_Arg_Is_Local_Name (Arg1);
14674 Id := Get_Pragma_Arg (Arg1);
14675 Find_Program_Unit_Name (Id);
14677 -- If we did not find the name, we are done
14679 if Etype (Id) = Any_Type then
14683 Def_Id := Entity (Id);
14685 -- Check if already defined as constructor
14687 if Is_Constructor (Def_Id) then
14689 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14693 if Ekind (Def_Id) = E_Function
14694 and then (Is_CPP_Class (Etype (Def_Id))
14695 or else (Is_Class_Wide_Type (Etype (Def_Id))
14697 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14699 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14701 ("'C'P'P constructor must be defined in the scope of "
14702 & "its returned type", Arg1);
14705 if Arg_Count >= 2 then
14706 Set_Imported (Def_Id);
14707 Set_Is_Public (Def_Id);
14708 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14711 Set_Has_Completion (Def_Id);
14712 Set_Is_Constructor (Def_Id);
14713 Set_Convention (Def_Id, Convention_CPP);
14715 -- Imported C++ constructors are not dispatching primitives
14716 -- because in C++ they don't have a dispatch table slot.
14717 -- However, in Ada the constructor has the profile of a
14718 -- function that returns a tagged type and therefore it has
14719 -- been treated as a primitive operation during semantic
14720 -- analysis. We now remove it from the list of primitive
14721 -- operations of the type.
14723 if Is_Tagged_Type (Etype (Def_Id))
14724 and then not Is_Class_Wide_Type (Etype (Def_Id))
14725 and then Is_Dispatching_Operation (Def_Id)
14727 Tag_Typ := Etype (Def_Id);
14729 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14730 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14734 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14735 Set_Is_Dispatching_Operation (Def_Id, False);
14738 -- For backward compatibility, if the constructor returns a
14739 -- class wide type, and we internally change the return type to
14740 -- the corresponding root type.
14742 if Is_Class_Wide_Type (Etype (Def_Id)) then
14743 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14747 ("pragma% requires function returning a 'C'P'P_Class type",
14750 end CPP_Constructor;
14756 when Pragma_CPP_Virtual =>
14759 if Warn_On_Obsolescent_Feature then
14761 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14765 --------------------
14767 --------------------
14769 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
14773 -- [, EXPRESSION]]);
14775 when Pragma_CUDA_Execute => CUDA_Execute : declare
14777 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
14778 -- Returns True if N is an acceptable argument for CUDA_Execute,
14779 -- False otherwise.
14781 ------------------------
14782 -- Is_Acceptable_Dim3 --
14783 ------------------------
14785 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
14788 if Is_RTE (Etype (N), RE_Dim3)
14789 or else Is_Integer_Type (Etype (N))
14794 if Nkind (N) = N_Aggregate
14795 and then List_Length (Expressions (N)) = 3
14797 Expr := First (Expressions (N));
14798 while Present (Expr) loop
14799 Analyze_And_Resolve (Expr, Any_Integer);
14806 end Is_Acceptable_Dim3;
14810 Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
14811 Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
14812 Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
14813 Shared_Memory : Node_Id;
14816 -- Start of processing for CUDA_Execute
14820 Check_At_Least_N_Arguments (3);
14821 Check_At_Most_N_Arguments (5);
14823 Analyze_And_Resolve (Kernel_Call);
14824 if Nkind (Kernel_Call) /= N_Function_Call
14825 or else Etype (Kernel_Call) /= Standard_Void_Type
14827 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
14828 -- GNAT sees Kernel_Call as an N_Function_Call since
14829 -- Kernel_Call "looks" like an expression. However, only
14830 -- procedures can be kernels, so to make things easier for the
14831 -- user the error message complains about Kernel_Call not being
14832 -- a procedure call.
14834 Error_Msg_N ("first argument of & must be a procedure call", N);
14837 Analyze (Grid_Dimensions);
14838 if not Is_Acceptable_Dim3 (Grid_Dimensions) then
14840 ("second argument of & must be an Integer, Dim3 or aggregate "
14841 & "containing 3 Integers", N);
14844 Analyze (Block_Dimensions);
14845 if not Is_Acceptable_Dim3 (Block_Dimensions) then
14847 ("third argument of & must be an Integer, Dim3 or aggregate "
14848 & "containing 3 Integers", N);
14851 if Present (Arg4) then
14852 Shared_Memory := Get_Pragma_Arg (Arg4);
14853 Analyze_And_Resolve (Shared_Memory, Any_Integer);
14855 if Present (Arg5) then
14856 Stream := Get_Pragma_Arg (Arg5);
14857 Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
14866 -- pragma CUDA_Global (IDENTIFIER);
14868 when Pragma_CUDA_Global => CUDA_Global : declare
14869 Arg_Node : Node_Id;
14870 Kernel_Proc : Entity_Id;
14871 Pack_Id : Entity_Id;
14874 Check_At_Least_N_Arguments (1);
14875 Check_At_Most_N_Arguments (1);
14876 Check_Optional_Identifier (Arg1, Name_Entity);
14877 Check_Arg_Is_Local_Name (Arg1);
14879 Arg_Node := Get_Pragma_Arg (Arg1);
14880 Analyze (Arg_Node);
14882 Kernel_Proc := Entity (Arg_Node);
14883 Pack_Id := Scope (Kernel_Proc);
14885 if Ekind (Kernel_Proc) /= E_Procedure then
14886 Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
14888 elsif Ekind (Pack_Id) /= E_Package
14889 or else not Is_Library_Level_Entity (Pack_Id)
14892 ("& must reside in a library-level package", N, Kernel_Proc);
14895 Set_Is_CUDA_Kernel (Kernel_Proc);
14896 Add_CUDA_Kernel (Pack_Id, Kernel_Proc);
14904 when Pragma_CPP_Vtable =>
14907 if Warn_On_Obsolescent_Feature then
14909 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14917 -- pragma CPU (EXPRESSION);
14919 when Pragma_CPU => CPU : declare
14920 P : constant Node_Id := Parent (N);
14926 Check_No_Identifiers;
14927 Check_Arg_Count (1);
14928 Arg := Get_Pragma_Arg (Arg1);
14932 if Nkind (P) = N_Subprogram_Body then
14933 Check_In_Main_Program;
14935 Analyze_And_Resolve (Arg, Any_Integer);
14937 Ent := Defining_Unit_Name (Specification (P));
14939 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14940 Ent := Defining_Identifier (Ent);
14945 if not Is_OK_Static_Expression (Arg) then
14946 Flag_Non_Static_Expr
14947 ("main subprogram affinity is not static!", Arg);
14950 -- If constraint error, then we already signalled an error
14952 elsif Raises_Constraint_Error (Arg) then
14955 -- Otherwise check in range
14959 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14960 -- This is the entity System.Multiprocessors.CPU_Range;
14962 Val : constant Uint := Expr_Value (Arg);
14965 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14967 Val > Expr_Value (Type_High_Bound (CPU_Id))
14970 ("main subprogram CPU is out of range", Arg1);
14976 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14980 elsif Nkind (P) = N_Task_Definition then
14981 Ent := Defining_Identifier (Parent (P));
14983 -- The expression must be analyzed in the special manner
14984 -- described in "Handling of Default and Per-Object
14985 -- Expressions" in sem.ads.
14987 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14989 -- See comment in Sem_Ch13 about the following restrictions
14991 if Is_OK_Static_Expression (Arg) then
14992 if Expr_Value (Arg) = Uint_0 then
14993 Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
14996 Check_Restriction (No_Dynamic_CPU_Assignment, N);
14999 -- Anything else is incorrect
15005 -- Check duplicate pragma before we chain the pragma in the Rep
15006 -- Item chain of Ent.
15008 Check_Duplicate_Pragma (Ent);
15009 Record_Rep_Item (Ent, N);
15012 --------------------
15013 -- Deadline_Floor --
15014 --------------------
15016 -- pragma Deadline_Floor (time_span_EXPRESSION);
15018 when Pragma_Deadline_Floor => Deadline_Floor : declare
15019 P : constant Node_Id := Parent (N);
15025 Check_No_Identifiers;
15026 Check_Arg_Count (1);
15028 Arg := Get_Pragma_Arg (Arg1);
15030 -- The expression must be analyzed in the special manner described
15031 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15033 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15035 -- Only protected types allowed
15037 if Nkind (P) /= N_Protected_Definition then
15041 Ent := Defining_Identifier (Parent (P));
15043 -- Check duplicate pragma before we chain the pragma in the Rep
15044 -- Item chain of Ent.
15046 Check_Duplicate_Pragma (Ent);
15047 Record_Rep_Item (Ent, N);
15049 end Deadline_Floor;
15055 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15057 when Pragma_Debug => Debug : declare
15064 -- The condition for executing the call is that the expander
15065 -- is active and that we are not ignoring this debug pragma.
15070 (Expander_Active and then not Is_Ignored (N)),
15073 if not Is_Ignored (N) then
15074 Set_SCO_Pragma_Enabled (Loc);
15077 if Arg_Count = 2 then
15079 Make_And_Then (Loc,
15080 Left_Opnd => Relocate_Node (Cond),
15081 Right_Opnd => Get_Pragma_Arg (Arg1));
15082 Call := Get_Pragma_Arg (Arg2);
15084 Call := Get_Pragma_Arg (Arg1);
15087 if Nkind (Call) in N_Expanded_Name
15090 | N_Indexed_Component
15091 | N_Selected_Component
15093 -- If this pragma Debug comes from source, its argument was
15094 -- parsed as a name form (which is syntactically identical).
15095 -- In a generic context a parameterless call will be left as
15096 -- an expanded name (if global) or selected_component if local.
15097 -- Change it to a procedure call statement now.
15099 Change_Name_To_Procedure_Call_Statement (Call);
15101 elsif Nkind (Call) = N_Procedure_Call_Statement then
15103 -- Already in the form of a procedure call statement: nothing
15104 -- to do (could happen in case of an internally generated
15110 -- All other cases: diagnose error
15113 ("argument of pragma ""Debug"" is not procedure call",
15118 -- Rewrite into a conditional with an appropriate condition. We
15119 -- wrap the procedure call in a block so that overhead from e.g.
15120 -- use of the secondary stack does not generate execution overhead
15121 -- for suppressed conditions.
15123 -- Normally the analysis that follows will freeze the subprogram
15124 -- being called. However, if the call is to a null procedure,
15125 -- we want to freeze it before creating the block, because the
15126 -- analysis that follows may be done with expansion disabled, in
15127 -- which case the body will not be generated, leading to spurious
15130 if Nkind (Call) = N_Procedure_Call_Statement
15131 and then Is_Entity_Name (Name (Call))
15133 Analyze (Name (Call));
15134 Freeze_Before (N, Entity (Name (Call)));
15138 Make_Implicit_If_Statement (N,
15140 Then_Statements => New_List (
15141 Make_Block_Statement (Loc,
15142 Handled_Statement_Sequence =>
15143 Make_Handled_Sequence_Of_Statements (Loc,
15144 Statements => New_List (Relocate_Node (Call)))))));
15147 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15148 -- after analysis of the normally rewritten node, to capture all
15149 -- references to entities, which avoids issuing wrong warnings
15150 -- about unused entities.
15152 if GNATprove_Mode then
15153 Rewrite (N, Make_Null_Statement (Loc));
15161 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15163 when Pragma_Debug_Policy =>
15165 Check_Arg_Count (1);
15166 Check_No_Identifiers;
15167 Check_Arg_Is_Identifier (Arg1);
15169 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15170 -- rewrite it that way, and let the rest of the checking come
15171 -- from analyzing the rewritten pragma.
15175 Chars => Name_Check_Policy,
15176 Pragma_Argument_Associations => New_List (
15177 Make_Pragma_Argument_Association (Loc,
15178 Expression => Make_Identifier (Loc, Name_Debug)),
15180 Make_Pragma_Argument_Association (Loc,
15181 Expression => Get_Pragma_Arg (Arg1)))));
15184 -------------------------------
15185 -- Default_Initial_Condition --
15186 -------------------------------
15188 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15190 when Pragma_Default_Initial_Condition => DIC : declare
15197 Check_No_Identifiers;
15198 Check_At_Most_N_Arguments (1);
15202 while Present (Stmt) loop
15204 -- Skip prior pragmas, but check for duplicates
15206 if Nkind (Stmt) = N_Pragma then
15207 if Pragma_Name (Stmt) = Pname then
15214 -- Skip internally generated code. Note that derived type
15215 -- declarations of untagged types with discriminants are
15216 -- rewritten as private type declarations.
15218 elsif not Comes_From_Source (Stmt)
15219 and then Nkind (Stmt) /= N_Private_Type_Declaration
15223 -- The associated private type [extension] has been found, stop
15226 elsif Nkind (Stmt) in N_Private_Extension_Declaration
15227 | N_Private_Type_Declaration
15229 Typ := Defining_Entity (Stmt);
15232 -- The pragma does not apply to a legal construct, issue an
15233 -- error and stop the analysis.
15240 Stmt := Prev (Stmt);
15243 -- The pragma does not apply to a legal construct, issue an error
15244 -- and stop the analysis.
15251 -- A pragma that applies to a Ghost entity becomes Ghost for the
15252 -- purposes of legality checks and removal of ignored Ghost code.
15254 Mark_Ghost_Pragma (N, Typ);
15256 -- The pragma signals that the type defines its own DIC assertion
15259 Set_Has_Own_DIC (Typ);
15261 -- Chain the pragma on the rep item chain for further processing
15263 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15265 -- Create the declaration of the procedure which verifies the
15266 -- assertion expression of pragma DIC at runtime.
15268 Build_DIC_Procedure_Declaration (Typ);
15271 ----------------------------------
15272 -- Default_Scalar_Storage_Order --
15273 ----------------------------------
15275 -- pragma Default_Scalar_Storage_Order
15276 -- (High_Order_First | Low_Order_First);
15278 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15279 Default : Character;
15283 Check_Arg_Count (1);
15285 -- Default_Scalar_Storage_Order can appear as a configuration
15286 -- pragma, or in a declarative part of a package spec.
15288 if not Is_Configuration_Pragma then
15289 Check_Is_In_Decl_Part_Or_Package_Spec;
15292 Check_No_Identifiers;
15293 Check_Arg_Is_One_Of
15294 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15295 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15296 Default := Fold_Upper (Name_Buffer (1));
15298 if not Support_Nondefault_SSO_On_Target
15299 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15301 if Warn_On_Unrecognized_Pragma then
15303 ("non-default Scalar_Storage_Order not supported "
15304 & "on target?g?", N);
15306 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15309 -- Here set the specified default
15312 Opt.Default_SSO := Default;
15316 --------------------------
15317 -- Default_Storage_Pool --
15318 --------------------------
15320 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15322 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15327 Check_Arg_Count (1);
15329 -- Default_Storage_Pool can appear as a configuration pragma, or
15330 -- in a declarative part of a package spec.
15332 if not Is_Configuration_Pragma then
15333 Check_Is_In_Decl_Part_Or_Package_Spec;
15336 if From_Aspect_Specification (N) then
15338 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15340 if not In_Open_Scopes (E) then
15342 ("aspect must apply to package or subprogram", N);
15347 if Present (Arg1) then
15348 Pool := Get_Pragma_Arg (Arg1);
15350 -- Case of Default_Storage_Pool (null);
15352 if Nkind (Pool) = N_Null then
15355 -- This is an odd case, this is not really an expression,
15356 -- so we don't have a type for it. So just set the type to
15359 Set_Etype (Pool, Empty);
15361 -- Case of Default_Storage_Pool (Standard);
15363 elsif Nkind (Pool) = N_Identifier
15364 and then Chars (Pool) = Name_Standard
15368 if Entity (Pool) /= Standard_Standard then
15370 ("package Standard is not directly visible", Arg1);
15373 -- Case of Default_Storage_Pool (storage_pool_NAME);
15376 -- If it's a configuration pragma, then the only allowed
15377 -- argument is "null".
15379 if Is_Configuration_Pragma then
15380 Error_Pragma_Arg ("NULL or Standard expected", Arg1);
15383 -- The expected type for a non-"null" argument is
15384 -- Root_Storage_Pool'Class, and the pool must be a variable.
15386 Analyze_And_Resolve
15387 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15389 if Is_Variable (Pool) then
15391 -- A pragma that applies to a Ghost entity becomes Ghost
15392 -- for the purposes of legality checks and removal of
15393 -- ignored Ghost code.
15395 Mark_Ghost_Pragma (N, Entity (Pool));
15399 ("default storage pool must be a variable", Arg1);
15403 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15404 -- access type will use this information to set the appropriate
15405 -- attributes of the access type. If the pragma appears in a
15406 -- generic unit it is ignored, given that it may refer to a
15409 if not Inside_A_Generic then
15410 Default_Pool := Pool;
15413 end Default_Storage_Pool;
15419 -- pragma Depends (DEPENDENCY_RELATION);
15421 -- DEPENDENCY_RELATION ::=
15423 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15425 -- DEPENDENCY_CLAUSE ::=
15426 -- OUTPUT_LIST =>[+] INPUT_LIST
15427 -- | NULL_DEPENDENCY_CLAUSE
15429 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15431 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15433 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15435 -- OUTPUT ::= NAME | FUNCTION_RESULT
15438 -- where FUNCTION_RESULT is a function Result attribute_reference
15440 -- Characteristics:
15442 -- * Analysis - The annotation undergoes initial checks to verify
15443 -- the legal placement and context. Secondary checks fully analyze
15444 -- the dependency clauses in:
15446 -- Analyze_Depends_In_Decl_Part
15448 -- * Expansion - None.
15450 -- * Template - The annotation utilizes the generic template of the
15451 -- related subprogram [body] when it is:
15453 -- aspect on subprogram declaration
15454 -- aspect on stand-alone subprogram body
15455 -- pragma on stand-alone subprogram body
15457 -- The annotation must prepare its own template when it is:
15459 -- pragma on subprogram declaration
15461 -- * Globals - Capture of global references must occur after full
15464 -- * Instance - The annotation is instantiated automatically when
15465 -- the related generic subprogram [body] is instantiated except for
15466 -- the "pragma on subprogram declaration" case. In that scenario
15467 -- the annotation must instantiate itself.
15469 when Pragma_Depends => Depends : declare
15471 Spec_Id : Entity_Id;
15472 Subp_Decl : Node_Id;
15475 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15479 -- Chain the pragma on the contract for further processing by
15480 -- Analyze_Depends_In_Decl_Part.
15482 Add_Contract_Item (N, Spec_Id);
15484 -- Fully analyze the pragma when it appears inside an entry
15485 -- or subprogram body because it cannot benefit from forward
15488 if Nkind (Subp_Decl) in N_Entry_Body
15489 | N_Subprogram_Body
15490 | N_Subprogram_Body_Stub
15492 -- The legality checks of pragmas Depends and Global are
15493 -- affected by the SPARK mode in effect and the volatility
15494 -- of the context. In addition these two pragmas are subject
15495 -- to an inherent order:
15500 -- Analyze all these pragmas in the order outlined above
15502 Analyze_If_Present (Pragma_SPARK_Mode);
15503 Analyze_If_Present (Pragma_Volatile_Function);
15504 Analyze_If_Present (Pragma_Global);
15505 Analyze_Depends_In_Decl_Part (N);
15510 ---------------------
15511 -- Detect_Blocking --
15512 ---------------------
15514 -- pragma Detect_Blocking;
15516 when Pragma_Detect_Blocking =>
15518 Check_Arg_Count (0);
15519 Check_Valid_Configuration_Pragma;
15520 Detect_Blocking := True;
15522 ------------------------------------
15523 -- Disable_Atomic_Synchronization --
15524 ------------------------------------
15526 -- pragma Disable_Atomic_Synchronization [(Entity)];
15528 when Pragma_Disable_Atomic_Synchronization =>
15530 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15532 -------------------
15533 -- Discard_Names --
15534 -------------------
15536 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15538 when Pragma_Discard_Names => Discard_Names : declare
15543 Check_Ada_83_Warning;
15545 -- Deal with configuration pragma case
15547 if Arg_Count = 0 and then Is_Configuration_Pragma then
15548 Global_Discard_Names := True;
15551 -- Otherwise, check correct appropriate context
15554 Check_Is_In_Decl_Part_Or_Package_Spec;
15556 if Arg_Count = 0 then
15558 -- If there is no parameter, then from now on this pragma
15559 -- applies to any enumeration, exception or tagged type
15560 -- defined in the current declarative part, and recursively
15561 -- to any nested scope.
15563 Set_Discard_Names (Current_Scope);
15567 Check_Arg_Count (1);
15568 Check_Optional_Identifier (Arg1, Name_On);
15569 Check_Arg_Is_Local_Name (Arg1);
15571 E_Id := Get_Pragma_Arg (Arg1);
15573 if Etype (E_Id) = Any_Type then
15577 E := Entity (E_Id);
15579 -- A pragma that applies to a Ghost entity becomes Ghost for
15580 -- the purposes of legality checks and removal of ignored
15583 Mark_Ghost_Pragma (N, E);
15585 if (Is_First_Subtype (E)
15587 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15588 or else Ekind (E) = E_Exception
15590 Set_Discard_Names (E);
15591 Record_Rep_Item (E, N);
15595 ("inappropriate entity for pragma%", Arg1);
15601 ------------------------
15602 -- Dispatching_Domain --
15603 ------------------------
15605 -- pragma Dispatching_Domain (EXPRESSION);
15607 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15608 P : constant Node_Id := Parent (N);
15614 Check_No_Identifiers;
15615 Check_Arg_Count (1);
15617 -- This pragma is born obsolete, but not the aspect
15619 if not From_Aspect_Specification (N) then
15621 (No_Obsolescent_Features, Pragma_Identifier (N));
15624 if Nkind (P) = N_Task_Definition then
15625 Arg := Get_Pragma_Arg (Arg1);
15626 Ent := Defining_Identifier (Parent (P));
15628 -- A pragma that applies to a Ghost entity becomes Ghost for
15629 -- the purposes of legality checks and removal of ignored Ghost
15632 Mark_Ghost_Pragma (N, Ent);
15634 -- The expression must be analyzed in the special manner
15635 -- described in "Handling of Default and Per-Object
15636 -- Expressions" in sem.ads.
15638 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15640 -- Check duplicate pragma before we chain the pragma in the Rep
15641 -- Item chain of Ent.
15643 Check_Duplicate_Pragma (Ent);
15644 Record_Rep_Item (Ent, N);
15646 -- Anything else is incorrect
15651 end Dispatching_Domain;
15657 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15659 when Pragma_Elaborate => Elaborate : declare
15664 -- Pragma must be in context items list of a compilation unit
15666 if not Is_In_Context_Clause then
15670 -- Must be at least one argument
15672 if Arg_Count = 0 then
15673 Error_Pragma ("pragma% requires at least one argument");
15676 -- In Ada 83 mode, there can be no items following it in the
15677 -- context list except other pragmas and implicit with clauses
15678 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15679 -- placement rule does not apply.
15681 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15683 while Present (Citem) loop
15684 if Nkind (Citem) = N_Pragma
15685 or else (Nkind (Citem) = N_With_Clause
15686 and then Implicit_With (Citem))
15691 ("(Ada 83) pragma% must be at end of context clause");
15698 -- Finally, the arguments must all be units mentioned in a with
15699 -- clause in the same context clause. Note we already checked (in
15700 -- Par.Prag) that the arguments are all identifiers or selected
15704 Outer : while Present (Arg) loop
15705 Citem := First (List_Containing (N));
15706 Inner : while Citem /= N loop
15707 if Nkind (Citem) = N_With_Clause
15708 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15710 Set_Elaborate_Present (Citem, True);
15711 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15713 -- With the pragma present, elaboration calls on
15714 -- subprograms from the named unit need no further
15715 -- checks, as long as the pragma appears in the current
15716 -- compilation unit. If the pragma appears in some unit
15717 -- in the context, there might still be a need for an
15718 -- Elaborate_All_Desirable from the current compilation
15719 -- to the named unit, so we keep the check enabled. This
15720 -- does not apply in SPARK mode, where we allow pragma
15721 -- Elaborate, but we don't trust it to be right so we
15722 -- will still insist on the Elaborate_All.
15724 if Legacy_Elaboration_Checks
15725 and then In_Extended_Main_Source_Unit (N)
15726 and then SPARK_Mode /= On
15728 Set_Suppress_Elaboration_Warnings
15729 (Entity (Name (Citem)));
15740 ("argument of pragma% is not withed unit", Arg);
15747 -------------------
15748 -- Elaborate_All --
15749 -------------------
15751 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15753 when Pragma_Elaborate_All => Elaborate_All : declare
15758 Check_Ada_83_Warning;
15760 -- Pragma must be in context items list of a compilation unit
15762 if not Is_In_Context_Clause then
15766 -- Must be at least one argument
15768 if Arg_Count = 0 then
15769 Error_Pragma ("pragma% requires at least one argument");
15772 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15773 -- have to appear at the end of the context clause, but may
15774 -- appear mixed in with other items, even in Ada 83 mode.
15776 -- Final check: the arguments must all be units mentioned in
15777 -- a with clause in the same context clause. Note that we
15778 -- already checked (in Par.Prag) that all the arguments are
15779 -- either identifiers or selected components.
15782 Outr : while Present (Arg) loop
15783 Citem := First (List_Containing (N));
15784 Innr : while Citem /= N loop
15785 if Nkind (Citem) = N_With_Clause
15786 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15788 Set_Elaborate_All_Present (Citem, True);
15789 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15791 -- Suppress warnings and elaboration checks on the named
15792 -- unit if the pragma is in the current compilation, as
15793 -- for pragma Elaborate.
15795 if Legacy_Elaboration_Checks
15796 and then In_Extended_Main_Source_Unit (N)
15798 Set_Suppress_Elaboration_Warnings
15799 (Entity (Name (Citem)));
15809 Set_Error_Posted (N);
15811 ("argument of pragma% is not withed unit", Arg);
15818 --------------------
15819 -- Elaborate_Body --
15820 --------------------
15822 -- pragma Elaborate_Body [( library_unit_NAME )];
15824 when Pragma_Elaborate_Body => Elaborate_Body : declare
15825 Cunit_Node : Node_Id;
15826 Cunit_Ent : Entity_Id;
15829 Check_Ada_83_Warning;
15830 Check_Valid_Library_Unit_Pragma;
15832 if Nkind (N) = N_Null_Statement then
15836 Cunit_Node := Cunit (Current_Sem_Unit);
15837 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15839 -- A pragma that applies to a Ghost entity becomes Ghost for the
15840 -- purposes of legality checks and removal of ignored Ghost code.
15842 Mark_Ghost_Pragma (N, Cunit_Ent);
15844 if Nkind (Unit (Cunit_Node)) in
15845 N_Package_Body | N_Subprogram_Body
15847 Error_Pragma ("pragma% must refer to a spec, not a body");
15849 Set_Body_Required (Cunit_Node);
15850 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15852 -- If we are in dynamic elaboration mode, then we suppress
15853 -- elaboration warnings for the unit, since it is definitely
15854 -- fine NOT to do dynamic checks at the first level (and such
15855 -- checks will be suppressed because no elaboration boolean
15856 -- is created for Elaborate_Body packages).
15858 -- But in the static model of elaboration, Elaborate_Body is
15859 -- definitely NOT good enough to ensure elaboration safety on
15860 -- its own, since the body may WITH other units that are not
15861 -- safe from an elaboration point of view, so a client must
15862 -- still do an Elaborate_All on such units.
15864 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15865 -- Elaborate_Body always suppressed elab warnings.
15867 if Legacy_Elaboration_Checks
15868 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15870 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15873 end Elaborate_Body;
15875 ------------------------
15876 -- Elaboration_Checks --
15877 ------------------------
15879 -- pragma Elaboration_Checks (Static | Dynamic);
15881 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15882 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15883 -- Emit an error if the current context list already contains
15884 -- a previous Elaboration_Checks pragma. This routine raises
15885 -- Pragma_Exit if a duplicate is found.
15887 procedure Ignore_Elaboration_Checks_Pragma;
15888 -- Warn that the effects of the pragma are ignored. This routine
15889 -- raises Pragma_Exit.
15891 -----------------------------------------------
15892 -- Check_Duplicate_Elaboration_Checks_Pragma --
15893 -----------------------------------------------
15895 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15900 while Present (Item) loop
15901 if Nkind (Item) = N_Pragma
15902 and then Pragma_Name (Item) = Name_Elaboration_Checks
15912 end Check_Duplicate_Elaboration_Checks_Pragma;
15914 --------------------------------------
15915 -- Ignore_Elaboration_Checks_Pragma --
15916 --------------------------------------
15918 procedure Ignore_Elaboration_Checks_Pragma is
15920 Error_Msg_Name_1 := Pname;
15921 Error_Msg_N ("??effects of pragma % are ignored", N);
15923 ("\place pragma on initial declaration of library unit", N);
15926 end Ignore_Elaboration_Checks_Pragma;
15930 Context : constant Node_Id := Parent (N);
15933 -- Start of processing for Elaboration_Checks
15937 Check_Arg_Count (1);
15938 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15940 -- The pragma appears in a configuration file
15942 if No (Context) then
15943 Check_Valid_Configuration_Pragma;
15944 Check_Duplicate_Elaboration_Checks_Pragma;
15946 -- The pragma acts as a configuration pragma in a compilation unit
15948 -- pragma Elaboration_Checks (...);
15949 -- package Pack is ...;
15951 elsif Nkind (Context) = N_Compilation_Unit
15952 and then List_Containing (N) = Context_Items (Context)
15954 Check_Valid_Configuration_Pragma;
15955 Check_Duplicate_Elaboration_Checks_Pragma;
15957 Unt := Unit (Context);
15959 -- The pragma must appear on the initial declaration of a unit.
15960 -- If this is not the case, warn that the effects of the pragma
15963 if Nkind (Unt) = N_Package_Body then
15964 Ignore_Elaboration_Checks_Pragma;
15966 -- Check the Acts_As_Spec flag of the compilation units itself
15967 -- to determine whether the subprogram body completes since it
15968 -- has not been analyzed yet. This is safe because compilation
15969 -- units are not overloadable.
15971 elsif Nkind (Unt) = N_Subprogram_Body
15972 and then not Acts_As_Spec (Context)
15974 Ignore_Elaboration_Checks_Pragma;
15976 elsif Nkind (Unt) = N_Subunit then
15977 Ignore_Elaboration_Checks_Pragma;
15980 -- Otherwise the pragma does not appear at the configuration level
15987 -- At this point the pragma is not a duplicate, and appears in the
15988 -- proper context. Set the elaboration model in effect.
15990 Dynamic_Elaboration_Checks :=
15991 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15992 end Elaboration_Checks;
15998 -- pragma Eliminate (
15999 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16000 -- [Entity =>] IDENTIFIER |
16001 -- SELECTED_COMPONENT |
16003 -- [, Source_Location => SOURCE_TRACE]);
16005 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16006 -- SOURCE_TRACE ::= STRING_LITERAL
16008 when Pragma_Eliminate => Eliminate : declare
16009 Args : Args_List (1 .. 5);
16010 Names : constant Name_List (1 .. 5) := (
16013 Name_Parameter_Types,
16015 Name_Source_Location);
16017 -- Note : Parameter_Types and Result_Type are leftovers from
16018 -- prior implementations of the pragma. They are not generated
16019 -- by the gnatelim tool, and play no role in selecting which
16020 -- of a set of overloaded names is chosen for elimination.
16022 Unit_Name : Node_Id renames Args (1);
16023 Entity : Node_Id renames Args (2);
16024 Parameter_Types : Node_Id renames Args (3);
16025 Result_Type : Node_Id renames Args (4);
16026 Source_Location : Node_Id renames Args (5);
16030 Check_Valid_Configuration_Pragma;
16031 Gather_Associations (Names, Args);
16033 if No (Unit_Name) then
16034 Error_Pragma ("missing Unit_Name argument for pragma%");
16038 and then (Present (Parameter_Types)
16040 Present (Result_Type)
16042 Present (Source_Location))
16044 Error_Pragma ("missing Entity argument for pragma%");
16047 if (Present (Parameter_Types)
16049 Present (Result_Type))
16051 Present (Source_Location)
16054 ("parameter profile and source location cannot be used "
16055 & "together in pragma%");
16058 Process_Eliminate_Pragma
16067 -----------------------------------
16068 -- Enable_Atomic_Synchronization --
16069 -----------------------------------
16071 -- pragma Enable_Atomic_Synchronization [(Entity)];
16073 when Pragma_Enable_Atomic_Synchronization =>
16075 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16082 -- [ Convention =>] convention_IDENTIFIER,
16083 -- [ Entity =>] LOCAL_NAME
16084 -- [, [External_Name =>] static_string_EXPRESSION ]
16085 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16087 when Pragma_Export => Export : declare
16089 Def_Id : Entity_Id;
16091 pragma Warnings (Off, C);
16094 Check_Ada_83_Warning;
16098 Name_External_Name,
16101 Check_At_Least_N_Arguments (2);
16102 Check_At_Most_N_Arguments (4);
16104 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16105 -- pragma Export (Entity, "external name");
16107 if Relaxed_RM_Semantics
16108 and then Arg_Count = 2
16109 and then Nkind (Expression (Arg2)) = N_String_Literal
16112 Def_Id := Get_Pragma_Arg (Arg1);
16115 if not Is_Entity_Name (Def_Id) then
16116 Error_Pragma_Arg ("entity name required", Arg1);
16119 Def_Id := Entity (Def_Id);
16120 Set_Exported (Def_Id, Arg1);
16123 Process_Convention (C, Def_Id);
16125 -- A pragma that applies to a Ghost entity becomes Ghost for
16126 -- the purposes of legality checks and removal of ignored Ghost
16129 Mark_Ghost_Pragma (N, Def_Id);
16131 if Ekind (Def_Id) /= E_Constant then
16132 Note_Possible_Modification
16133 (Get_Pragma_Arg (Arg2), Sure => False);
16136 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16137 Set_Exported (Def_Id, Arg2);
16140 -- If the entity is a deferred constant, propagate the information
16141 -- to the full view, because gigi elaborates the full view only.
16143 if Ekind (Def_Id) = E_Constant
16144 and then Present (Full_View (Def_Id))
16147 Id2 : constant Entity_Id := Full_View (Def_Id);
16149 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16150 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16151 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16156 ---------------------
16157 -- Export_Function --
16158 ---------------------
16160 -- pragma Export_Function (
16161 -- [Internal =>] LOCAL_NAME
16162 -- [, [External =>] EXTERNAL_SYMBOL]
16163 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16164 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16165 -- [, [Mechanism =>] MECHANISM]
16166 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16168 -- EXTERNAL_SYMBOL ::=
16170 -- | static_string_EXPRESSION
16172 -- PARAMETER_TYPES ::=
16174 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16176 -- TYPE_DESIGNATOR ::=
16178 -- | subtype_Name ' Access
16182 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16184 -- MECHANISM_ASSOCIATION ::=
16185 -- [formal_parameter_NAME =>] MECHANISM_NAME
16187 -- MECHANISM_NAME ::=
16191 when Pragma_Export_Function => Export_Function : declare
16192 Args : Args_List (1 .. 6);
16193 Names : constant Name_List (1 .. 6) := (
16196 Name_Parameter_Types,
16199 Name_Result_Mechanism);
16201 Internal : Node_Id renames Args (1);
16202 External : Node_Id renames Args (2);
16203 Parameter_Types : Node_Id renames Args (3);
16204 Result_Type : Node_Id renames Args (4);
16205 Mechanism : Node_Id renames Args (5);
16206 Result_Mechanism : Node_Id renames Args (6);
16210 Gather_Associations (Names, Args);
16211 Process_Extended_Import_Export_Subprogram_Pragma (
16212 Arg_Internal => Internal,
16213 Arg_External => External,
16214 Arg_Parameter_Types => Parameter_Types,
16215 Arg_Result_Type => Result_Type,
16216 Arg_Mechanism => Mechanism,
16217 Arg_Result_Mechanism => Result_Mechanism);
16218 end Export_Function;
16220 -------------------
16221 -- Export_Object --
16222 -------------------
16224 -- pragma Export_Object (
16225 -- [Internal =>] LOCAL_NAME
16226 -- [, [External =>] EXTERNAL_SYMBOL]
16227 -- [, [Size =>] EXTERNAL_SYMBOL]);
16229 -- EXTERNAL_SYMBOL ::=
16231 -- | static_string_EXPRESSION
16233 -- PARAMETER_TYPES ::=
16235 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16237 -- TYPE_DESIGNATOR ::=
16239 -- | subtype_Name ' Access
16243 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16245 -- MECHANISM_ASSOCIATION ::=
16246 -- [formal_parameter_NAME =>] MECHANISM_NAME
16248 -- MECHANISM_NAME ::=
16252 when Pragma_Export_Object => Export_Object : declare
16253 Args : Args_List (1 .. 3);
16254 Names : constant Name_List (1 .. 3) := (
16259 Internal : Node_Id renames Args (1);
16260 External : Node_Id renames Args (2);
16261 Size : Node_Id renames Args (3);
16265 Gather_Associations (Names, Args);
16266 Process_Extended_Import_Export_Object_Pragma (
16267 Arg_Internal => Internal,
16268 Arg_External => External,
16272 ----------------------
16273 -- Export_Procedure --
16274 ----------------------
16276 -- pragma Export_Procedure (
16277 -- [Internal =>] LOCAL_NAME
16278 -- [, [External =>] EXTERNAL_SYMBOL]
16279 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16280 -- [, [Mechanism =>] MECHANISM]);
16282 -- EXTERNAL_SYMBOL ::=
16284 -- | static_string_EXPRESSION
16286 -- PARAMETER_TYPES ::=
16288 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16290 -- TYPE_DESIGNATOR ::=
16292 -- | subtype_Name ' Access
16296 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16298 -- MECHANISM_ASSOCIATION ::=
16299 -- [formal_parameter_NAME =>] MECHANISM_NAME
16301 -- MECHANISM_NAME ::=
16305 when Pragma_Export_Procedure => Export_Procedure : declare
16306 Args : Args_List (1 .. 4);
16307 Names : constant Name_List (1 .. 4) := (
16310 Name_Parameter_Types,
16313 Internal : Node_Id renames Args (1);
16314 External : Node_Id renames Args (2);
16315 Parameter_Types : Node_Id renames Args (3);
16316 Mechanism : Node_Id renames Args (4);
16320 Gather_Associations (Names, Args);
16321 Process_Extended_Import_Export_Subprogram_Pragma (
16322 Arg_Internal => Internal,
16323 Arg_External => External,
16324 Arg_Parameter_Types => Parameter_Types,
16325 Arg_Mechanism => Mechanism);
16326 end Export_Procedure;
16332 -- pragma Export_Value (
16333 -- [Value =>] static_integer_EXPRESSION,
16334 -- [Link_Name =>] static_string_EXPRESSION);
16336 when Pragma_Export_Value =>
16338 Check_Arg_Order ((Name_Value, Name_Link_Name));
16339 Check_Arg_Count (2);
16341 Check_Optional_Identifier (Arg1, Name_Value);
16342 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16344 Check_Optional_Identifier (Arg2, Name_Link_Name);
16345 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16347 -----------------------------
16348 -- Export_Valued_Procedure --
16349 -----------------------------
16351 -- pragma Export_Valued_Procedure (
16352 -- [Internal =>] LOCAL_NAME
16353 -- [, [External =>] EXTERNAL_SYMBOL,]
16354 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16355 -- [, [Mechanism =>] MECHANISM]);
16357 -- EXTERNAL_SYMBOL ::=
16359 -- | static_string_EXPRESSION
16361 -- PARAMETER_TYPES ::=
16363 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16365 -- TYPE_DESIGNATOR ::=
16367 -- | subtype_Name ' Access
16371 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16373 -- MECHANISM_ASSOCIATION ::=
16374 -- [formal_parameter_NAME =>] MECHANISM_NAME
16376 -- MECHANISM_NAME ::=
16380 when Pragma_Export_Valued_Procedure =>
16381 Export_Valued_Procedure : declare
16382 Args : Args_List (1 .. 4);
16383 Names : constant Name_List (1 .. 4) := (
16386 Name_Parameter_Types,
16389 Internal : Node_Id renames Args (1);
16390 External : Node_Id renames Args (2);
16391 Parameter_Types : Node_Id renames Args (3);
16392 Mechanism : Node_Id renames Args (4);
16396 Gather_Associations (Names, Args);
16397 Process_Extended_Import_Export_Subprogram_Pragma (
16398 Arg_Internal => Internal,
16399 Arg_External => External,
16400 Arg_Parameter_Types => Parameter_Types,
16401 Arg_Mechanism => Mechanism);
16402 end Export_Valued_Procedure;
16404 -------------------
16405 -- Extend_System --
16406 -------------------
16408 -- pragma Extend_System ([Name =>] Identifier);
16410 when Pragma_Extend_System =>
16412 Check_Valid_Configuration_Pragma;
16413 Check_Arg_Count (1);
16414 Check_Optional_Identifier (Arg1, Name_Name);
16415 Check_Arg_Is_Identifier (Arg1);
16417 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16420 and then Name_Buffer (1 .. 4) = "aux_"
16422 if Present (System_Extend_Pragma_Arg) then
16423 if Chars (Get_Pragma_Arg (Arg1)) =
16424 Chars (Expression (System_Extend_Pragma_Arg))
16428 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16429 Error_Pragma ("pragma% conflicts with that #");
16433 System_Extend_Pragma_Arg := Arg1;
16435 if not GNAT_Mode then
16436 System_Extend_Unit := Arg1;
16440 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16443 ------------------------
16444 -- Extensions_Allowed --
16445 ------------------------
16447 -- pragma Extensions_Allowed (ON | OFF);
16449 when Pragma_Extensions_Allowed =>
16451 Check_Arg_Count (1);
16452 Check_No_Identifiers;
16453 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16455 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16456 Extensions_Allowed := True;
16457 Ada_Version := Ada_Version_Type'Last;
16460 Extensions_Allowed := False;
16461 Ada_Version := Ada_Version_Explicit;
16462 Ada_Version_Pragma := Empty;
16465 ------------------------
16466 -- Extensions_Visible --
16467 ------------------------
16469 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16471 -- Characteristics:
16473 -- * Analysis - The annotation is fully analyzed immediately upon
16474 -- elaboration as its expression must be static.
16476 -- * Expansion - None.
16478 -- * Template - The annotation utilizes the generic template of the
16479 -- related subprogram [body] when it is:
16481 -- aspect on subprogram declaration
16482 -- aspect on stand-alone subprogram body
16483 -- pragma on stand-alone subprogram body
16485 -- The annotation must prepare its own template when it is:
16487 -- pragma on subprogram declaration
16489 -- * Globals - Capture of global references must occur after full
16492 -- * Instance - The annotation is instantiated automatically when
16493 -- the related generic subprogram [body] is instantiated except for
16494 -- the "pragma on subprogram declaration" case. In that scenario
16495 -- the annotation must instantiate itself.
16497 when Pragma_Extensions_Visible => Extensions_Visible : declare
16498 Formal : Entity_Id;
16499 Has_OK_Formal : Boolean := False;
16500 Spec_Id : Entity_Id;
16501 Subp_Decl : Node_Id;
16505 Check_No_Identifiers;
16506 Check_At_Most_N_Arguments (1);
16509 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16511 -- Abstract subprogram declaration
16513 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16516 -- Generic subprogram declaration
16518 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16521 -- Body acts as spec
16523 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16524 and then No (Corresponding_Spec (Subp_Decl))
16528 -- Body stub acts as spec
16530 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16531 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16535 -- Subprogram declaration
16537 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16540 -- Otherwise the pragma is associated with an illegal construct
16543 Error_Pragma ("pragma % must apply to a subprogram");
16547 -- Mark the pragma as Ghost if the related subprogram is also
16548 -- Ghost. This also ensures that any expansion performed further
16549 -- below will produce Ghost nodes.
16551 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16552 Mark_Ghost_Pragma (N, Spec_Id);
16554 -- Chain the pragma on the contract for completeness
16556 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16558 -- The legality checks of pragma Extension_Visible are affected
16559 -- by the SPARK mode in effect. Analyze all pragmas in specific
16562 Analyze_If_Present (Pragma_SPARK_Mode);
16564 -- Examine the formals of the related subprogram
16566 Formal := First_Formal (Spec_Id);
16567 while Present (Formal) loop
16569 -- At least one of the formals is of a specific tagged type,
16570 -- the pragma is legal.
16572 if Is_Specific_Tagged_Type (Etype (Formal)) then
16573 Has_OK_Formal := True;
16576 -- A generic subprogram with at least one formal of a private
16577 -- type ensures the legality of the pragma because the actual
16578 -- may be specifically tagged. Note that this is verified by
16579 -- the check above at instantiation time.
16581 elsif Is_Private_Type (Etype (Formal))
16582 and then Is_Generic_Type (Etype (Formal))
16584 Has_OK_Formal := True;
16588 Next_Formal (Formal);
16591 if not Has_OK_Formal then
16592 Error_Msg_Name_1 := Pname;
16593 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16595 ("\subprogram & lacks parameter of specific tagged or "
16596 & "generic private type", N, Spec_Id);
16601 -- Analyze the Boolean expression (if any)
16603 if Present (Arg1) then
16604 Check_Static_Boolean_Expression
16605 (Expression (Get_Argument (N, Spec_Id)));
16607 end Extensions_Visible;
16613 -- pragma External (
16614 -- [ Convention =>] convention_IDENTIFIER,
16615 -- [ Entity =>] LOCAL_NAME
16616 -- [, [External_Name =>] static_string_EXPRESSION ]
16617 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16619 when Pragma_External => External : declare
16622 pragma Warnings (Off, C);
16629 Name_External_Name,
16631 Check_At_Least_N_Arguments (2);
16632 Check_At_Most_N_Arguments (4);
16633 Process_Convention (C, E);
16635 -- A pragma that applies to a Ghost entity becomes Ghost for the
16636 -- purposes of legality checks and removal of ignored Ghost code.
16638 Mark_Ghost_Pragma (N, E);
16640 Note_Possible_Modification
16641 (Get_Pragma_Arg (Arg2), Sure => False);
16642 Process_Interface_Name (E, Arg3, Arg4, N);
16643 Set_Exported (E, Arg2);
16646 --------------------------
16647 -- External_Name_Casing --
16648 --------------------------
16650 -- pragma External_Name_Casing (
16651 -- UPPERCASE | LOWERCASE
16652 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16654 when Pragma_External_Name_Casing =>
16656 Check_No_Identifiers;
16658 if Arg_Count = 2 then
16659 Check_Arg_Is_One_Of
16660 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16662 case Chars (Get_Pragma_Arg (Arg2)) is
16664 Opt.External_Name_Exp_Casing := As_Is;
16666 when Name_Uppercase =>
16667 Opt.External_Name_Exp_Casing := Uppercase;
16669 when Name_Lowercase =>
16670 Opt.External_Name_Exp_Casing := Lowercase;
16677 Check_Arg_Count (1);
16680 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16682 case Chars (Get_Pragma_Arg (Arg1)) is
16683 when Name_Uppercase =>
16684 Opt.External_Name_Imp_Casing := Uppercase;
16686 when Name_Lowercase =>
16687 Opt.External_Name_Imp_Casing := Lowercase;
16697 -- pragma Fast_Math;
16699 when Pragma_Fast_Math =>
16701 Check_No_Identifiers;
16702 Check_Valid_Configuration_Pragma;
16705 --------------------------
16706 -- Favor_Top_Level --
16707 --------------------------
16709 -- pragma Favor_Top_Level (type_NAME);
16711 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16716 Check_No_Identifiers;
16717 Check_Arg_Count (1);
16718 Check_Arg_Is_Local_Name (Arg1);
16719 Typ := Entity (Get_Pragma_Arg (Arg1));
16721 -- A pragma that applies to a Ghost entity becomes Ghost for the
16722 -- purposes of legality checks and removal of ignored Ghost code.
16724 Mark_Ghost_Pragma (N, Typ);
16726 -- If it's an access-to-subprogram type (in particular, not a
16727 -- subtype), set the flag on that type.
16729 if Is_Access_Subprogram_Type (Typ) then
16730 Set_Can_Use_Internal_Rep (Typ, False);
16732 -- Otherwise it's an error (name denotes the wrong sort of entity)
16736 ("access-to-subprogram type expected",
16737 Get_Pragma_Arg (Arg1));
16739 end Favor_Top_Level;
16741 ---------------------------
16742 -- Finalize_Storage_Only --
16743 ---------------------------
16745 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16747 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16748 Assoc : constant Node_Id := Arg1;
16749 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16754 Check_No_Identifiers;
16755 Check_Arg_Count (1);
16756 Check_Arg_Is_Local_Name (Arg1);
16758 Find_Type (Type_Id);
16759 Typ := Entity (Type_Id);
16762 or else Rep_Item_Too_Early (Typ, N)
16766 Typ := Underlying_Type (Typ);
16769 if not Is_Controlled (Typ) then
16770 Error_Pragma ("pragma% must specify controlled type");
16773 Check_First_Subtype (Arg1);
16775 if Finalize_Storage_Only (Typ) then
16776 Error_Pragma ("duplicate pragma%, only one allowed");
16778 elsif not Rep_Item_Too_Late (Typ, N) then
16779 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16781 end Finalize_Storage;
16787 -- pragma Ghost [ (boolean_EXPRESSION) ];
16789 when Pragma_Ghost => Ghost : declare
16793 Orig_Stmt : Node_Id;
16794 Prev_Id : Entity_Id;
16799 Check_No_Identifiers;
16800 Check_At_Most_N_Arguments (1);
16804 while Present (Stmt) loop
16806 -- Skip prior pragmas, but check for duplicates
16808 if Nkind (Stmt) = N_Pragma then
16809 if Pragma_Name (Stmt) = Pname then
16816 -- Task unit declared without a definition cannot be subject to
16817 -- pragma Ghost (SPARK RM 6.9(19)).
16819 elsif Nkind (Stmt) in
16820 N_Single_Task_Declaration | N_Task_Type_Declaration
16822 Error_Pragma ("pragma % cannot apply to a task type");
16825 -- Skip internally generated code
16827 elsif not Comes_From_Source (Stmt) then
16828 Orig_Stmt := Original_Node (Stmt);
16830 -- When pragma Ghost applies to an untagged derivation, the
16831 -- derivation is transformed into a [sub]type declaration.
16834 N_Full_Type_Declaration | N_Subtype_Declaration
16835 and then Comes_From_Source (Orig_Stmt)
16836 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16837 and then Nkind (Type_Definition (Orig_Stmt)) =
16838 N_Derived_Type_Definition
16840 Id := Defining_Entity (Stmt);
16843 -- When pragma Ghost applies to an object declaration which
16844 -- is initialized by means of a function call that returns
16845 -- on the secondary stack, the object declaration becomes a
16848 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16849 and then Comes_From_Source (Orig_Stmt)
16850 and then Nkind (Orig_Stmt) = N_Object_Declaration
16852 Id := Defining_Entity (Stmt);
16855 -- When pragma Ghost applies to an expression function, the
16856 -- expression function is transformed into a subprogram.
16858 elsif Nkind (Stmt) = N_Subprogram_Declaration
16859 and then Comes_From_Source (Orig_Stmt)
16860 and then Nkind (Orig_Stmt) = N_Expression_Function
16862 Id := Defining_Entity (Stmt);
16866 -- The pragma applies to a legal construct, stop the traversal
16868 elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
16869 | N_Full_Type_Declaration
16870 | N_Generic_Subprogram_Declaration
16871 | N_Object_Declaration
16872 | N_Private_Extension_Declaration
16873 | N_Private_Type_Declaration
16874 | N_Subprogram_Declaration
16875 | N_Subtype_Declaration
16877 Id := Defining_Entity (Stmt);
16880 -- The pragma does not apply to a legal construct, issue an
16881 -- error and stop the analysis.
16885 ("pragma % must apply to an object, package, subprogram "
16890 Stmt := Prev (Stmt);
16893 Context := Parent (N);
16895 -- Handle compilation units
16897 if Nkind (Context) = N_Compilation_Unit_Aux then
16898 Context := Unit (Parent (Context));
16901 -- Protected and task types cannot be subject to pragma Ghost
16902 -- (SPARK RM 6.9(19)).
16904 if Nkind (Context) in N_Protected_Body | N_Protected_Definition
16906 Error_Pragma ("pragma % cannot apply to a protected type");
16909 elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
16910 Error_Pragma ("pragma % cannot apply to a task type");
16916 -- When pragma Ghost is associated with a [generic] package, it
16917 -- appears in the visible declarations.
16919 if Nkind (Context) = N_Package_Specification
16920 and then Present (Visible_Declarations (Context))
16921 and then List_Containing (N) = Visible_Declarations (Context)
16923 Id := Defining_Entity (Context);
16925 -- Pragma Ghost applies to a stand-alone subprogram body
16927 elsif Nkind (Context) = N_Subprogram_Body
16928 and then No (Corresponding_Spec (Context))
16930 Id := Defining_Entity (Context);
16932 -- Pragma Ghost applies to a subprogram declaration that acts
16933 -- as a compilation unit.
16935 elsif Nkind (Context) = N_Subprogram_Declaration then
16936 Id := Defining_Entity (Context);
16938 -- Pragma Ghost applies to a generic subprogram
16940 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16941 Id := Defining_Entity (Specification (Context));
16947 ("pragma % must apply to an object, package, subprogram or "
16952 -- Handle completions of types and constants that are subject to
16955 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16956 Prev_Id := Incomplete_Or_Partial_View (Id);
16958 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16959 Error_Msg_Name_1 := Pname;
16961 -- The full declaration of a deferred constant cannot be
16962 -- subject to pragma Ghost unless the deferred declaration
16963 -- is also Ghost (SPARK RM 6.9(9)).
16965 if Ekind (Prev_Id) = E_Constant then
16966 Error_Msg_Name_1 := Pname;
16967 Error_Msg_NE (Fix_Error
16968 ("pragma % must apply to declaration of deferred "
16969 & "constant &"), N, Id);
16972 -- Pragma Ghost may appear on the full view of an incomplete
16973 -- type because the incomplete declaration lacks aspects and
16974 -- cannot be subject to pragma Ghost.
16976 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16979 -- The full declaration of a type cannot be subject to
16980 -- pragma Ghost unless the partial view is also Ghost
16981 -- (SPARK RM 6.9(9)).
16984 Error_Msg_NE (Fix_Error
16985 ("pragma % must apply to partial view of type &"),
16991 -- A synchronized object cannot be subject to pragma Ghost
16992 -- (SPARK RM 6.9(19)).
16994 elsif Ekind (Id) = E_Variable then
16995 if Is_Protected_Type (Etype (Id)) then
16996 Error_Pragma ("pragma % cannot apply to a protected object");
16999 elsif Is_Task_Type (Etype (Id)) then
17000 Error_Pragma ("pragma % cannot apply to a task object");
17005 -- Analyze the Boolean expression (if any)
17007 if Present (Arg1) then
17008 Expr := Get_Pragma_Arg (Arg1);
17010 Analyze_And_Resolve (Expr, Standard_Boolean);
17012 if Is_OK_Static_Expression (Expr) then
17014 -- "Ghostness" cannot be turned off once enabled within a
17015 -- region (SPARK RM 6.9(6)).
17017 if Is_False (Expr_Value (Expr))
17018 and then Ghost_Mode > None
17021 ("pragma % with value False cannot appear in enabled "
17026 -- Otherwise the expression is not static
17030 ("expression of pragma % must be static", Expr);
17035 Set_Is_Ghost_Entity (Id);
17042 -- pragma Global (GLOBAL_SPECIFICATION);
17044 -- GLOBAL_SPECIFICATION ::=
17047 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17049 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17051 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17052 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17053 -- GLOBAL_ITEM ::= NAME
17055 -- Characteristics:
17057 -- * Analysis - The annotation undergoes initial checks to verify
17058 -- the legal placement and context. Secondary checks fully analyze
17059 -- the dependency clauses in:
17061 -- Analyze_Global_In_Decl_Part
17063 -- * Expansion - None.
17065 -- * Template - The annotation utilizes the generic template of the
17066 -- related subprogram [body] when it is:
17068 -- aspect on subprogram declaration
17069 -- aspect on stand-alone subprogram body
17070 -- pragma on stand-alone subprogram body
17072 -- The annotation must prepare its own template when it is:
17074 -- pragma on subprogram declaration
17076 -- * Globals - Capture of global references must occur after full
17079 -- * Instance - The annotation is instantiated automatically when
17080 -- the related generic subprogram [body] is instantiated except for
17081 -- the "pragma on subprogram declaration" case. In that scenario
17082 -- the annotation must instantiate itself.
17084 when Pragma_Global => Global : declare
17086 Spec_Id : Entity_Id;
17087 Subp_Decl : Node_Id;
17090 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17094 -- Chain the pragma on the contract for further processing by
17095 -- Analyze_Global_In_Decl_Part.
17097 Add_Contract_Item (N, Spec_Id);
17099 -- Fully analyze the pragma when it appears inside an entry
17100 -- or subprogram body because it cannot benefit from forward
17103 if Nkind (Subp_Decl) in N_Entry_Body
17104 | N_Subprogram_Body
17105 | N_Subprogram_Body_Stub
17107 -- The legality checks of pragmas Depends and Global are
17108 -- affected by the SPARK mode in effect and the volatility
17109 -- of the context. In addition these two pragmas are subject
17110 -- to an inherent order:
17115 -- Analyze all these pragmas in the order outlined above
17117 Analyze_If_Present (Pragma_SPARK_Mode);
17118 Analyze_If_Present (Pragma_Volatile_Function);
17119 Analyze_Global_In_Decl_Part (N);
17120 Analyze_If_Present (Pragma_Depends);
17129 -- pragma Ident (static_string_EXPRESSION)
17131 -- Note: pragma Comment shares this processing. Pragma Ident is
17132 -- identical in effect to pragma Commment.
17134 when Pragma_Comment
17142 Check_Arg_Count (1);
17143 Check_No_Identifiers;
17144 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17147 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17154 GP := Parent (Parent (N));
17157 N_Package_Declaration | N_Generic_Package_Declaration
17162 -- If we have a compilation unit, then record the ident value,
17163 -- checking for improper duplication.
17165 if Nkind (GP) = N_Compilation_Unit then
17166 CS := Ident_String (Current_Sem_Unit);
17168 if Present (CS) then
17170 -- If we have multiple instances, concatenate them.
17172 Start_String (Strval (CS));
17173 Store_String_Char (' ');
17174 Store_String_Chars (Strval (Str));
17175 Set_Strval (CS, End_String);
17178 Set_Ident_String (Current_Sem_Unit, Str);
17181 -- For subunits, we just ignore the Ident, since in GNAT these
17182 -- are not separate object files, and hence not separate units
17183 -- in the unit table.
17185 elsif Nkind (GP) = N_Subunit then
17191 -------------------
17192 -- Ignore_Pragma --
17193 -------------------
17195 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17197 -- Entirely handled in the parser, nothing to do here
17199 when Pragma_Ignore_Pragma =>
17202 ----------------------------
17203 -- Implementation_Defined --
17204 ----------------------------
17206 -- pragma Implementation_Defined (LOCAL_NAME);
17208 -- Marks previously declared entity as implementation defined. For
17209 -- an overloaded entity, applies to the most recent homonym.
17211 -- pragma Implementation_Defined;
17213 -- The form with no arguments appears anywhere within a scope, most
17214 -- typically a package spec, and indicates that all entities that are
17215 -- defined within the package spec are Implementation_Defined.
17217 when Pragma_Implementation_Defined => Implementation_Defined : declare
17222 Check_No_Identifiers;
17224 -- Form with no arguments
17226 if Arg_Count = 0 then
17227 Set_Is_Implementation_Defined (Current_Scope);
17229 -- Form with one argument
17232 Check_Arg_Count (1);
17233 Check_Arg_Is_Local_Name (Arg1);
17234 Ent := Entity (Get_Pragma_Arg (Arg1));
17235 Set_Is_Implementation_Defined (Ent);
17237 end Implementation_Defined;
17243 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17245 -- IMPLEMENTATION_KIND ::=
17246 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17248 -- "By_Any" and "Optional" are treated as synonyms in order to
17249 -- support Ada 2012 aspect Synchronization.
17251 when Pragma_Implemented => Implemented : declare
17252 Proc_Id : Entity_Id;
17257 Check_Arg_Count (2);
17258 Check_No_Identifiers;
17259 Check_Arg_Is_Identifier (Arg1);
17260 Check_Arg_Is_Local_Name (Arg1);
17261 Check_Arg_Is_One_Of (Arg2,
17264 Name_By_Protected_Procedure,
17267 -- Extract the name of the local procedure
17269 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17271 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17272 -- primitive procedure of a synchronized tagged type.
17274 if Ekind (Proc_Id) = E_Procedure
17275 and then Is_Primitive (Proc_Id)
17276 and then Present (First_Formal (Proc_Id))
17278 Typ := Etype (First_Formal (Proc_Id));
17280 if Is_Tagged_Type (Typ)
17283 -- Check for a protected, a synchronized or a task interface
17285 ((Is_Interface (Typ)
17286 and then Is_Synchronized_Interface (Typ))
17288 -- Check for a protected type or a task type that implements
17292 (Is_Concurrent_Record_Type (Typ)
17293 and then Present (Interfaces (Typ)))
17295 -- In analysis-only mode, examine original protected type
17298 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17299 and then Present (Interface_List (Parent (Typ))))
17301 -- Check for a private record extension with keyword
17305 (Ekind (Typ) in E_Record_Type_With_Private
17306 | E_Record_Subtype_With_Private
17307 and then Synchronized_Present (Parent (Typ))))
17312 ("controlling formal must be of synchronized tagged type",
17317 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17318 -- By_Protected_Procedure to the primitive procedure of a task
17321 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17322 and then Is_Interface (Typ)
17323 and then Is_Task_Interface (Typ)
17326 ("implementation kind By_Protected_Procedure cannot be "
17327 & "applied to a task interface primitive", Arg2);
17331 -- Procedures declared inside a protected type must be accepted
17333 elsif Ekind (Proc_Id) = E_Procedure
17334 and then Is_Protected_Type (Scope (Proc_Id))
17338 -- The first argument is not a primitive procedure
17342 ("pragma % must be applied to a primitive procedure", Arg1);
17346 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17347 -- By_Protected_Procedure to a procedure that has aspect Yield
17349 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17350 and then Has_Yield_Aspect (Proc_Id)
17353 ("implementation kind By_Protected_Procedure cannot be "
17354 & "applied to entities with aspect 'Yield", Arg2);
17358 Record_Rep_Item (Proc_Id, N);
17361 ----------------------
17362 -- Implicit_Packing --
17363 ----------------------
17365 -- pragma Implicit_Packing;
17367 when Pragma_Implicit_Packing =>
17369 Check_Arg_Count (0);
17370 Implicit_Packing := True;
17377 -- [Convention =>] convention_IDENTIFIER,
17378 -- [Entity =>] LOCAL_NAME
17379 -- [, [External_Name =>] static_string_EXPRESSION ]
17380 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17382 when Pragma_Import =>
17383 Check_Ada_83_Warning;
17387 Name_External_Name,
17390 Check_At_Least_N_Arguments (2);
17391 Check_At_Most_N_Arguments (4);
17392 Process_Import_Or_Interface;
17394 ---------------------
17395 -- Import_Function --
17396 ---------------------
17398 -- pragma Import_Function (
17399 -- [Internal =>] LOCAL_NAME,
17400 -- [, [External =>] EXTERNAL_SYMBOL]
17401 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17402 -- [, [Result_Type =>] SUBTYPE_MARK]
17403 -- [, [Mechanism =>] MECHANISM]
17404 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17406 -- EXTERNAL_SYMBOL ::=
17408 -- | static_string_EXPRESSION
17410 -- PARAMETER_TYPES ::=
17412 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17414 -- TYPE_DESIGNATOR ::=
17416 -- | subtype_Name ' Access
17420 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17422 -- MECHANISM_ASSOCIATION ::=
17423 -- [formal_parameter_NAME =>] MECHANISM_NAME
17425 -- MECHANISM_NAME ::=
17429 when Pragma_Import_Function => Import_Function : declare
17430 Args : Args_List (1 .. 6);
17431 Names : constant Name_List (1 .. 6) := (
17434 Name_Parameter_Types,
17437 Name_Result_Mechanism);
17439 Internal : Node_Id renames Args (1);
17440 External : Node_Id renames Args (2);
17441 Parameter_Types : Node_Id renames Args (3);
17442 Result_Type : Node_Id renames Args (4);
17443 Mechanism : Node_Id renames Args (5);
17444 Result_Mechanism : Node_Id renames Args (6);
17448 Gather_Associations (Names, Args);
17449 Process_Extended_Import_Export_Subprogram_Pragma (
17450 Arg_Internal => Internal,
17451 Arg_External => External,
17452 Arg_Parameter_Types => Parameter_Types,
17453 Arg_Result_Type => Result_Type,
17454 Arg_Mechanism => Mechanism,
17455 Arg_Result_Mechanism => Result_Mechanism);
17456 end Import_Function;
17458 -------------------
17459 -- Import_Object --
17460 -------------------
17462 -- pragma Import_Object (
17463 -- [Internal =>] LOCAL_NAME
17464 -- [, [External =>] EXTERNAL_SYMBOL]
17465 -- [, [Size =>] EXTERNAL_SYMBOL]);
17467 -- EXTERNAL_SYMBOL ::=
17469 -- | static_string_EXPRESSION
17471 when Pragma_Import_Object => Import_Object : declare
17472 Args : Args_List (1 .. 3);
17473 Names : constant Name_List (1 .. 3) := (
17478 Internal : Node_Id renames Args (1);
17479 External : Node_Id renames Args (2);
17480 Size : Node_Id renames Args (3);
17484 Gather_Associations (Names, Args);
17485 Process_Extended_Import_Export_Object_Pragma (
17486 Arg_Internal => Internal,
17487 Arg_External => External,
17491 ----------------------
17492 -- Import_Procedure --
17493 ----------------------
17495 -- pragma Import_Procedure (
17496 -- [Internal =>] LOCAL_NAME
17497 -- [, [External =>] EXTERNAL_SYMBOL]
17498 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17499 -- [, [Mechanism =>] MECHANISM]);
17501 -- EXTERNAL_SYMBOL ::=
17503 -- | static_string_EXPRESSION
17505 -- PARAMETER_TYPES ::=
17507 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17509 -- TYPE_DESIGNATOR ::=
17511 -- | subtype_Name ' Access
17515 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17517 -- MECHANISM_ASSOCIATION ::=
17518 -- [formal_parameter_NAME =>] MECHANISM_NAME
17520 -- MECHANISM_NAME ::=
17524 when Pragma_Import_Procedure => Import_Procedure : declare
17525 Args : Args_List (1 .. 4);
17526 Names : constant Name_List (1 .. 4) := (
17529 Name_Parameter_Types,
17532 Internal : Node_Id renames Args (1);
17533 External : Node_Id renames Args (2);
17534 Parameter_Types : Node_Id renames Args (3);
17535 Mechanism : Node_Id renames Args (4);
17539 Gather_Associations (Names, Args);
17540 Process_Extended_Import_Export_Subprogram_Pragma (
17541 Arg_Internal => Internal,
17542 Arg_External => External,
17543 Arg_Parameter_Types => Parameter_Types,
17544 Arg_Mechanism => Mechanism);
17545 end Import_Procedure;
17547 -----------------------------
17548 -- Import_Valued_Procedure --
17549 -----------------------------
17551 -- pragma Import_Valued_Procedure (
17552 -- [Internal =>] LOCAL_NAME
17553 -- [, [External =>] EXTERNAL_SYMBOL]
17554 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17555 -- [, [Mechanism =>] MECHANISM]);
17557 -- EXTERNAL_SYMBOL ::=
17559 -- | static_string_EXPRESSION
17561 -- PARAMETER_TYPES ::=
17563 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17565 -- TYPE_DESIGNATOR ::=
17567 -- | subtype_Name ' Access
17571 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17573 -- MECHANISM_ASSOCIATION ::=
17574 -- [formal_parameter_NAME =>] MECHANISM_NAME
17576 -- MECHANISM_NAME ::=
17580 when Pragma_Import_Valued_Procedure =>
17581 Import_Valued_Procedure : declare
17582 Args : Args_List (1 .. 4);
17583 Names : constant Name_List (1 .. 4) := (
17586 Name_Parameter_Types,
17589 Internal : Node_Id renames Args (1);
17590 External : Node_Id renames Args (2);
17591 Parameter_Types : Node_Id renames Args (3);
17592 Mechanism : Node_Id renames Args (4);
17596 Gather_Associations (Names, Args);
17597 Process_Extended_Import_Export_Subprogram_Pragma (
17598 Arg_Internal => Internal,
17599 Arg_External => External,
17600 Arg_Parameter_Types => Parameter_Types,
17601 Arg_Mechanism => Mechanism);
17602 end Import_Valued_Procedure;
17608 -- pragma Independent (LOCAL_NAME);
17610 when Pragma_Independent =>
17611 Process_Atomic_Independent_Shared_Volatile;
17613 ----------------------------
17614 -- Independent_Components --
17615 ----------------------------
17617 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17619 when Pragma_Independent_Components => Independent_Components : declare
17626 Check_Ada_83_Warning;
17628 Check_No_Identifiers;
17629 Check_Arg_Count (1);
17630 Check_Arg_Is_Local_Name (Arg1);
17631 E_Id := Get_Pragma_Arg (Arg1);
17633 if Etype (E_Id) = Any_Type then
17637 E := Entity (E_Id);
17639 -- A record type with a self-referential component of anonymous
17640 -- access type is given an incomplete view in order to handle the
17643 -- type Rec is record
17644 -- Self : access Rec;
17650 -- type Ptr is access Rec;
17651 -- type Rec is record
17655 -- Since the incomplete view is now the initial view of the type,
17656 -- the argument of the pragma will reference the incomplete view,
17657 -- but this view is illegal according to the semantics of the
17660 -- Obtain the full view of an internally-generated incomplete type
17661 -- only. This way an attempt to associate the pragma with a source
17662 -- incomplete type is still caught.
17664 if Ekind (E) = E_Incomplete_Type
17665 and then not Comes_From_Source (E)
17666 and then Present (Full_View (E))
17668 E := Full_View (E);
17671 -- A pragma that applies to a Ghost entity becomes Ghost for the
17672 -- purposes of legality checks and removal of ignored Ghost code.
17674 Mark_Ghost_Pragma (N, E);
17676 -- Check duplicate before we chain ourselves
17678 Check_Duplicate_Pragma (E);
17680 -- Check appropriate entity
17682 if Rep_Item_Too_Early (E, N)
17684 Rep_Item_Too_Late (E, N)
17689 D := Declaration_Node (E);
17691 -- The flag is set on the base type, or on the object
17693 if Nkind (D) = N_Full_Type_Declaration
17694 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17696 Set_Has_Independent_Components (Base_Type (E));
17697 Record_Independence_Check (N, Base_Type (E));
17699 -- For record type, set all components independent
17701 if Is_Record_Type (E) then
17702 C := First_Component (E);
17703 while Present (C) loop
17704 Set_Is_Independent (C);
17705 Next_Component (C);
17709 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17710 and then Nkind (D) = N_Object_Declaration
17711 and then Nkind (Object_Definition (D)) =
17712 N_Constrained_Array_Definition
17714 Set_Has_Independent_Components (E);
17715 Record_Independence_Check (N, E);
17718 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17720 end Independent_Components;
17722 -----------------------
17723 -- Initial_Condition --
17724 -----------------------
17726 -- pragma Initial_Condition (boolean_EXPRESSION);
17728 -- Characteristics:
17730 -- * Analysis - The annotation undergoes initial checks to verify
17731 -- the legal placement and context. Secondary checks preanalyze the
17734 -- Analyze_Initial_Condition_In_Decl_Part
17736 -- * Expansion - The annotation is expanded during the expansion of
17737 -- the package body whose declaration is subject to the annotation
17740 -- Expand_Pragma_Initial_Condition
17742 -- * Template - The annotation utilizes the generic template of the
17743 -- related package declaration.
17745 -- * Globals - Capture of global references must occur after full
17748 -- * Instance - The annotation is instantiated automatically when
17749 -- the related generic package is instantiated.
17751 when Pragma_Initial_Condition => Initial_Condition : declare
17752 Pack_Decl : Node_Id;
17753 Pack_Id : Entity_Id;
17757 Check_No_Identifiers;
17758 Check_Arg_Count (1);
17760 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17762 if Nkind (Pack_Decl) not in
17763 N_Generic_Package_Declaration | N_Package_Declaration
17769 Pack_Id := Defining_Entity (Pack_Decl);
17771 -- A pragma that applies to a Ghost entity becomes Ghost for the
17772 -- purposes of legality checks and removal of ignored Ghost code.
17774 Mark_Ghost_Pragma (N, Pack_Id);
17776 -- Chain the pragma on the contract for further processing by
17777 -- Analyze_Initial_Condition_In_Decl_Part.
17779 Add_Contract_Item (N, Pack_Id);
17781 -- The legality checks of pragmas Abstract_State, Initializes, and
17782 -- Initial_Condition are affected by the SPARK mode in effect. In
17783 -- addition, these three pragmas are subject to an inherent order:
17785 -- 1) Abstract_State
17787 -- 3) Initial_Condition
17789 -- Analyze all these pragmas in the order outlined above
17791 Analyze_If_Present (Pragma_SPARK_Mode);
17792 Analyze_If_Present (Pragma_Abstract_State);
17793 Analyze_If_Present (Pragma_Initializes);
17794 end Initial_Condition;
17796 ------------------------
17797 -- Initialize_Scalars --
17798 ------------------------
17800 -- pragma Initialize_Scalars
17801 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17803 -- TYPE_VALUE_PAIR ::=
17804 -- SCALAR_TYPE => static_EXPRESSION
17810 -- | Long_Long_Float
17822 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17823 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17824 -- This collection holds the individual pairs which specify the
17825 -- invalid values of their respective scalar types.
17827 procedure Analyze_Float_Value
17828 (Scal_Typ : Float_Scalar_Id;
17829 Val_Expr : Node_Id);
17830 -- Analyze a type value pair associated with float type Scal_Typ
17831 -- and expression Val_Expr.
17833 procedure Analyze_Integer_Value
17834 (Scal_Typ : Integer_Scalar_Id;
17835 Val_Expr : Node_Id);
17836 -- Analyze a type value pair associated with integer type Scal_Typ
17837 -- and expression Val_Expr.
17839 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17840 -- Analyze type value pair Pair
17842 -------------------------
17843 -- Analyze_Float_Value --
17844 -------------------------
17846 procedure Analyze_Float_Value
17847 (Scal_Typ : Float_Scalar_Id;
17848 Val_Expr : Node_Id)
17851 Analyze_And_Resolve (Val_Expr, Any_Real);
17853 if Is_OK_Static_Expression (Val_Expr) then
17854 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17857 Error_Msg_Name_1 := Scal_Typ;
17858 Error_Msg_N ("value for type % must be static", Val_Expr);
17860 end Analyze_Float_Value;
17862 ---------------------------
17863 -- Analyze_Integer_Value --
17864 ---------------------------
17866 procedure Analyze_Integer_Value
17867 (Scal_Typ : Integer_Scalar_Id;
17868 Val_Expr : Node_Id)
17871 Analyze_And_Resolve (Val_Expr, Any_Integer);
17873 if (Scal_Typ = Name_Signed_128
17874 or else Scal_Typ = Name_Unsigned_128)
17875 and then Ttypes.System_Max_Integer_Size < 128
17877 Error_Msg_Name_1 := Scal_Typ;
17878 Error_Msg_N ("value cannot be set for type %", Val_Expr);
17880 elsif Is_OK_Static_Expression (Val_Expr) then
17881 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17884 Error_Msg_Name_1 := Scal_Typ;
17885 Error_Msg_N ("value for type % must be static", Val_Expr);
17887 end Analyze_Integer_Value;
17889 -----------------------------
17890 -- Analyze_Type_Value_Pair --
17891 -----------------------------
17893 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17894 Scal_Typ : constant Name_Id := Chars (Pair);
17895 Val_Expr : constant Node_Id := Expression (Pair);
17896 Prev_Pair : Node_Id;
17899 if Scal_Typ in Scalar_Id then
17900 Prev_Pair := Seen (Scal_Typ);
17902 -- Prevent multiple attempts to set a value for a scalar
17905 if Present (Prev_Pair) then
17906 Error_Msg_Name_1 := Scal_Typ;
17908 ("cannot specify multiple invalid values for type %",
17911 Error_Msg_Sloc := Sloc (Prev_Pair);
17912 Error_Msg_N ("previous value set #", Pair);
17914 -- Ignore the effects of the pair, but do not halt the
17915 -- analysis of the pragma altogether.
17919 -- Otherwise capture the first pair for this scalar type
17922 Seen (Scal_Typ) := Pair;
17925 if Scal_Typ in Float_Scalar_Id then
17926 Analyze_Float_Value (Scal_Typ, Val_Expr);
17928 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17929 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17932 -- Otherwise the scalar family is illegal
17935 Error_Msg_Name_1 := Pname;
17937 ("argument of pragma % must denote valid scalar family",
17940 end Analyze_Type_Value_Pair;
17944 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17947 -- Start of processing for Do_Initialize_Scalars
17951 Check_Valid_Configuration_Pragma;
17952 Check_Restriction (No_Initialize_Scalars, N);
17954 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17957 if Restriction_Active (No_Initialize_Scalars) then
17960 -- Initialize_Scalars creates false positives in CodePeer, and
17961 -- incorrect negative results in GNATprove mode, so ignore this
17962 -- pragma in these modes.
17964 elsif CodePeer_Mode or GNATprove_Mode then
17967 -- Otherwise analyze the pragma
17970 if Present (Pairs) then
17972 -- Install Standard in order to provide access to primitive
17973 -- types in case the expressions contain attributes such as
17976 Push_Scope (Standard_Standard);
17978 Pair := First (Pairs);
17979 while Present (Pair) loop
17980 Analyze_Type_Value_Pair (Pair);
17989 Init_Or_Norm_Scalars := True;
17990 Initialize_Scalars := True;
17992 end Do_Initialize_Scalars;
17998 -- pragma Initializes (INITIALIZATION_LIST);
18000 -- INITIALIZATION_LIST ::=
18002 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18004 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18009 -- | (INPUT {, INPUT})
18013 -- Characteristics:
18015 -- * Analysis - The annotation undergoes initial checks to verify
18016 -- the legal placement and context. Secondary checks preanalyze the
18019 -- Analyze_Initializes_In_Decl_Part
18021 -- * Expansion - None.
18023 -- * Template - The annotation utilizes the generic template of the
18024 -- related package declaration.
18026 -- * Globals - Capture of global references must occur after full
18029 -- * Instance - The annotation is instantiated automatically when
18030 -- the related generic package is instantiated.
18032 when Pragma_Initializes => Initializes : declare
18033 Pack_Decl : Node_Id;
18034 Pack_Id : Entity_Id;
18038 Check_No_Identifiers;
18039 Check_Arg_Count (1);
18041 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18043 if Nkind (Pack_Decl) not in
18044 N_Generic_Package_Declaration | N_Package_Declaration
18050 Pack_Id := Defining_Entity (Pack_Decl);
18052 -- A pragma that applies to a Ghost entity becomes Ghost for the
18053 -- purposes of legality checks and removal of ignored Ghost code.
18055 Mark_Ghost_Pragma (N, Pack_Id);
18056 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18058 -- Chain the pragma on the contract for further processing by
18059 -- Analyze_Initializes_In_Decl_Part.
18061 Add_Contract_Item (N, Pack_Id);
18063 -- The legality checks of pragmas Abstract_State, Initializes, and
18064 -- Initial_Condition are affected by the SPARK mode in effect. In
18065 -- addition, these three pragmas are subject to an inherent order:
18067 -- 1) Abstract_State
18069 -- 3) Initial_Condition
18071 -- Analyze all these pragmas in the order outlined above
18073 Analyze_If_Present (Pragma_SPARK_Mode);
18074 Analyze_If_Present (Pragma_Abstract_State);
18075 Analyze_If_Present (Pragma_Initial_Condition);
18082 -- pragma Inline ( NAME {, NAME} );
18084 when Pragma_Inline =>
18086 -- Pragma always active unless in GNATprove mode. It is disabled
18087 -- in GNATprove mode because frontend inlining is applied
18088 -- independently of pragmas Inline and Inline_Always for
18089 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18092 if not GNATprove_Mode then
18094 -- Inline status is Enabled if option -gnatn is specified.
18095 -- However this status determines only the value of the
18096 -- Is_Inlined flag on the subprogram and does not prevent
18097 -- the pragma itself from being recorded for later use,
18098 -- in particular for a later modification of Is_Inlined
18099 -- independently of the -gnatn option.
18101 -- In other words, if -gnatn is specified for a unit, then
18102 -- all Inline pragmas processed for the compilation of this
18103 -- unit, including those in the spec of other units, are
18104 -- activated, so subprograms will be inlined across units.
18106 -- If -gnatn is not specified, no Inline pragma is activated
18107 -- here, which means that subprograms will not be inlined
18108 -- across units. The Is_Inlined flag will nevertheless be
18109 -- set later when bodies are analyzed, so subprograms will
18110 -- be inlined within the unit.
18112 if Inline_Active then
18113 Process_Inline (Enabled);
18115 Process_Inline (Disabled);
18119 -------------------
18120 -- Inline_Always --
18121 -------------------
18123 -- pragma Inline_Always ( NAME {, NAME} );
18125 when Pragma_Inline_Always =>
18128 -- Pragma always active unless in CodePeer mode or GNATprove
18129 -- mode. It is disabled in CodePeer mode because inlining is
18130 -- not helpful, and enabling it caused walk order issues. It
18131 -- is disabled in GNATprove mode because frontend inlining is
18132 -- applied independently of pragmas Inline and Inline_Always for
18133 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18136 if not CodePeer_Mode and not GNATprove_Mode then
18137 Process_Inline (Enabled);
18140 --------------------
18141 -- Inline_Generic --
18142 --------------------
18144 -- pragma Inline_Generic (NAME {, NAME});
18146 when Pragma_Inline_Generic =>
18148 Process_Generic_List;
18150 ----------------------
18151 -- Inspection_Point --
18152 ----------------------
18154 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18156 when Pragma_Inspection_Point => Inspection_Point : declare
18163 if Arg_Count > 0 then
18166 Exp := Get_Pragma_Arg (Arg);
18169 if not Is_Entity_Name (Exp)
18170 or else not Is_Object (Entity (Exp))
18172 Error_Pragma_Arg ("object name required", Arg);
18176 exit when No (Arg);
18179 end Inspection_Point;
18185 -- pragma Interface (
18186 -- [ Convention =>] convention_IDENTIFIER,
18187 -- [ Entity =>] LOCAL_NAME
18188 -- [, [External_Name =>] static_string_EXPRESSION ]
18189 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18191 when Pragma_Interface =>
18196 Name_External_Name,
18198 Check_At_Least_N_Arguments (2);
18199 Check_At_Most_N_Arguments (4);
18200 Process_Import_Or_Interface;
18202 -- In Ada 2005, the permission to use Interface (a reserved word)
18203 -- as a pragma name is considered an obsolescent feature, and this
18204 -- pragma was already obsolescent in Ada 95.
18206 if Ada_Version >= Ada_95 then
18208 (No_Obsolescent_Features, Pragma_Identifier (N));
18210 if Warn_On_Obsolescent_Feature then
18212 ("pragma Interface is an obsolescent feature?j?", N);
18214 ("|use pragma Import instead?j?", N);
18218 --------------------
18219 -- Interface_Name --
18220 --------------------
18222 -- pragma Interface_Name (
18223 -- [ Entity =>] LOCAL_NAME
18224 -- [,[External_Name =>] static_string_EXPRESSION ]
18225 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18227 when Pragma_Interface_Name => Interface_Name : declare
18229 Def_Id : Entity_Id;
18230 Hom_Id : Entity_Id;
18236 ((Name_Entity, Name_External_Name, Name_Link_Name));
18237 Check_At_Least_N_Arguments (2);
18238 Check_At_Most_N_Arguments (3);
18239 Id := Get_Pragma_Arg (Arg1);
18242 -- This is obsolete from Ada 95 on, but it is an implementation
18243 -- defined pragma, so we do not consider that it violates the
18244 -- restriction (No_Obsolescent_Features).
18246 if Ada_Version >= Ada_95 then
18247 if Warn_On_Obsolescent_Feature then
18249 ("pragma Interface_Name is an obsolescent feature?j?", N);
18251 ("|use pragma Import instead?j?", N);
18255 if not Is_Entity_Name (Id) then
18257 ("first argument for pragma% must be entity name", Arg1);
18258 elsif Etype (Id) = Any_Type then
18261 Def_Id := Entity (Id);
18264 -- Special DEC-compatible processing for the object case, forces
18265 -- object to be imported.
18267 if Ekind (Def_Id) = E_Variable then
18268 Kill_Size_Check_Code (Def_Id);
18269 Note_Possible_Modification (Id, Sure => False);
18271 -- Initialization is not allowed for imported variable
18273 if Present (Expression (Parent (Def_Id)))
18274 and then Comes_From_Source (Expression (Parent (Def_Id)))
18276 Error_Msg_Sloc := Sloc (Def_Id);
18278 ("no initialization allowed for declaration of& #",
18282 -- For compatibility, support VADS usage of providing both
18283 -- pragmas Interface and Interface_Name to obtain the effect
18284 -- of a single Import pragma.
18286 if Is_Imported (Def_Id)
18287 and then Present (First_Rep_Item (Def_Id))
18288 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18289 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18294 Set_Imported (Def_Id);
18297 Set_Is_Public (Def_Id);
18298 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18301 -- Otherwise must be subprogram
18303 elsif not Is_Subprogram (Def_Id) then
18305 ("argument of pragma% is not subprogram", Arg1);
18308 Check_At_Most_N_Arguments (3);
18312 -- Loop through homonyms
18315 Def_Id := Get_Base_Subprogram (Hom_Id);
18317 if Is_Imported (Def_Id) then
18318 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18322 exit when From_Aspect_Specification (N);
18323 Hom_Id := Homonym (Hom_Id);
18325 exit when No (Hom_Id)
18326 or else Scope (Hom_Id) /= Current_Scope;
18331 ("argument of pragma% is not imported subprogram",
18335 end Interface_Name;
18337 -----------------------
18338 -- Interrupt_Handler --
18339 -----------------------
18341 -- pragma Interrupt_Handler (handler_NAME);
18343 when Pragma_Interrupt_Handler =>
18344 Check_Ada_83_Warning;
18345 Check_Arg_Count (1);
18346 Check_No_Identifiers;
18348 if No_Run_Time_Mode then
18349 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18351 Check_Interrupt_Or_Attach_Handler;
18352 Process_Interrupt_Or_Attach_Handler;
18355 ------------------------
18356 -- Interrupt_Priority --
18357 ------------------------
18359 -- pragma Interrupt_Priority [(EXPRESSION)];
18361 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18362 P : constant Node_Id := Parent (N);
18367 Check_Ada_83_Warning;
18369 if Arg_Count /= 0 then
18370 Arg := Get_Pragma_Arg (Arg1);
18371 Check_Arg_Count (1);
18372 Check_No_Identifiers;
18374 -- The expression must be analyzed in the special manner
18375 -- described in "Handling of Default and Per-Object
18376 -- Expressions" in sem.ads.
18378 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18381 if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
18386 Ent := Defining_Identifier (Parent (P));
18388 -- Check duplicate pragma before we chain the pragma in the Rep
18389 -- Item chain of Ent.
18391 Check_Duplicate_Pragma (Ent);
18392 Record_Rep_Item (Ent, N);
18394 -- Check the No_Task_At_Interrupt_Priority restriction
18396 if Nkind (P) = N_Task_Definition then
18397 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18400 end Interrupt_Priority;
18402 ---------------------
18403 -- Interrupt_State --
18404 ---------------------
18406 -- pragma Interrupt_State (
18407 -- [Name =>] INTERRUPT_ID,
18408 -- [State =>] INTERRUPT_STATE);
18410 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18411 -- INTERRUPT_STATE => System | Runtime | User
18413 -- Note: if the interrupt id is given as an identifier, then it must
18414 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18415 -- given as a static integer expression which must be in the range of
18416 -- Ada.Interrupts.Interrupt_ID.
18418 when Pragma_Interrupt_State => Interrupt_State : declare
18419 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18420 -- This is the entity Ada.Interrupts.Interrupt_ID;
18422 State_Type : Character;
18423 -- Set to 's'/'r'/'u' for System/Runtime/User
18426 -- Index to entry in Interrupt_States table
18429 -- Value of interrupt
18431 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18432 -- The first argument to the pragma
18434 Int_Ent : Entity_Id;
18435 -- Interrupt entity in Ada.Interrupts.Names
18439 Check_Arg_Order ((Name_Name, Name_State));
18440 Check_Arg_Count (2);
18442 Check_Optional_Identifier (Arg1, Name_Name);
18443 Check_Optional_Identifier (Arg2, Name_State);
18444 Check_Arg_Is_Identifier (Arg2);
18446 -- First argument is identifier
18448 if Nkind (Arg1X) = N_Identifier then
18450 -- Search list of names in Ada.Interrupts.Names
18452 Int_Ent := First_Entity (RTE (RE_Names));
18454 if No (Int_Ent) then
18455 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18457 elsif Chars (Int_Ent) = Chars (Arg1X) then
18458 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18462 Next_Entity (Int_Ent);
18465 -- First argument is not an identifier, so it must be a static
18466 -- expression of type Ada.Interrupts.Interrupt_ID.
18469 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18470 Int_Val := Expr_Value (Arg1X);
18472 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18474 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18477 ("value not in range of type "
18478 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18484 case Chars (Get_Pragma_Arg (Arg2)) is
18485 when Name_Runtime => State_Type := 'r';
18486 when Name_System => State_Type := 's';
18487 when Name_User => State_Type := 'u';
18490 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18493 -- Check if entry is already stored
18495 IST_Num := Interrupt_States.First;
18497 -- If entry not found, add it
18499 if IST_Num > Interrupt_States.Last then
18500 Interrupt_States.Append
18501 ((Interrupt_Number => UI_To_Int (Int_Val),
18502 Interrupt_State => State_Type,
18503 Pragma_Loc => Loc));
18506 -- Case of entry for the same entry
18508 elsif Int_Val = Interrupt_States.Table (IST_Num).
18511 -- If state matches, done, no need to make redundant entry
18514 State_Type = Interrupt_States.Table (IST_Num).
18517 -- Otherwise if state does not match, error
18520 Interrupt_States.Table (IST_Num).Pragma_Loc;
18522 ("state conflicts with that given #", Arg2);
18526 IST_Num := IST_Num + 1;
18528 end Interrupt_State;
18534 -- pragma Invariant
18535 -- ([Entity =>] type_LOCAL_NAME,
18536 -- [Check =>] EXPRESSION
18537 -- [,[Message =>] String_Expression]);
18539 when Pragma_Invariant => Invariant : declare
18546 Check_At_Least_N_Arguments (2);
18547 Check_At_Most_N_Arguments (3);
18548 Check_Optional_Identifier (Arg1, Name_Entity);
18549 Check_Optional_Identifier (Arg2, Name_Check);
18551 if Arg_Count = 3 then
18552 Check_Optional_Identifier (Arg3, Name_Message);
18553 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18556 Check_Arg_Is_Local_Name (Arg1);
18558 Typ_Arg := Get_Pragma_Arg (Arg1);
18559 Find_Type (Typ_Arg);
18560 Typ := Entity (Typ_Arg);
18562 -- Nothing to do of the related type is erroneous in some way
18564 if Typ = Any_Type then
18567 -- AI12-0041: Invariants are allowed in interface types
18569 elsif Is_Interface (Typ) then
18572 -- An invariant must apply to a private type, or appear in the
18573 -- private part of a package spec and apply to a completion.
18574 -- a class-wide invariant can only appear on a private declaration
18575 -- or private extension, not a completion.
18577 -- A [class-wide] invariant may be associated a [limited] private
18578 -- type or a private extension.
18580 elsif Ekind (Typ) in E_Limited_Private_Type
18582 | E_Record_Type_With_Private
18586 -- A non-class-wide invariant may be associated with the full view
18587 -- of a [limited] private type or a private extension.
18589 elsif Has_Private_Declaration (Typ)
18590 and then not Class_Present (N)
18594 -- A class-wide invariant may appear on the partial view only
18596 elsif Class_Present (N) then
18598 ("pragma % only allowed for private type", Arg1);
18601 -- A regular invariant may appear on both views
18605 ("pragma % only allowed for private type or corresponding "
18606 & "full view", Arg1);
18610 -- An invariant associated with an abstract type (this includes
18611 -- interfaces) must be class-wide.
18613 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18615 ("pragma % not allowed for abstract type", Arg1);
18619 -- A pragma that applies to a Ghost entity becomes Ghost for the
18620 -- purposes of legality checks and removal of ignored Ghost code.
18622 Mark_Ghost_Pragma (N, Typ);
18624 -- The pragma defines a type-specific invariant, the type is said
18625 -- to have invariants of its "own".
18627 Set_Has_Own_Invariants (Typ);
18629 -- If the invariant is class-wide, then it can be inherited by
18630 -- derived or interface implementing types. The type is said to
18631 -- have "inheritable" invariants.
18633 if Class_Present (N) then
18634 Set_Has_Inheritable_Invariants (Typ);
18637 -- Chain the pragma on to the rep item chain, for processing when
18638 -- the type is frozen.
18640 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18642 -- Create the declaration of the invariant procedure that will
18643 -- verify the invariant at run time. Interfaces are treated as the
18644 -- partial view of a private type in order to achieve uniformity
18645 -- with the general case. As a result, an interface receives only
18646 -- a "partial" invariant procedure, which is never called.
18648 Build_Invariant_Procedure_Declaration
18650 Partial_Invariant => Is_Interface (Typ));
18657 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18659 when Pragma_Keep_Names => Keep_Names : declare
18664 Check_Arg_Count (1);
18665 Check_Optional_Identifier (Arg1, Name_On);
18666 Check_Arg_Is_Local_Name (Arg1);
18668 Arg := Get_Pragma_Arg (Arg1);
18671 if Etype (Arg) = Any_Type then
18675 if not Is_Entity_Name (Arg)
18676 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18679 ("pragma% requires a local enumeration type", Arg1);
18682 Set_Discard_Names (Entity (Arg), False);
18689 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18691 when Pragma_License =>
18694 -- Do not analyze pragma any further in CodePeer mode, to avoid
18695 -- extraneous errors in this implementation-dependent pragma,
18696 -- which has a different profile on other compilers.
18698 if CodePeer_Mode then
18702 Check_Arg_Count (1);
18703 Check_No_Identifiers;
18704 Check_Valid_Configuration_Pragma;
18705 Check_Arg_Is_Identifier (Arg1);
18708 Sind : constant Source_File_Index :=
18709 Source_Index (Current_Sem_Unit);
18712 case Chars (Get_Pragma_Arg (Arg1)) is
18714 Set_License (Sind, GPL);
18716 when Name_Modified_GPL =>
18717 Set_License (Sind, Modified_GPL);
18719 when Name_Restricted =>
18720 Set_License (Sind, Restricted);
18722 when Name_Unrestricted =>
18723 Set_License (Sind, Unrestricted);
18726 Error_Pragma_Arg ("invalid license name", Arg1);
18734 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18736 when Pragma_Link_With => Link_With : declare
18742 if Operating_Mode = Generate_Code
18743 and then In_Extended_Main_Source_Unit (N)
18745 Check_At_Least_N_Arguments (1);
18746 Check_No_Identifiers;
18747 Check_Is_In_Decl_Part_Or_Package_Spec;
18748 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18752 while Present (Arg) loop
18753 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18755 -- Store argument, converting sequences of spaces to a
18756 -- single null character (this is one of the differences
18757 -- in processing between Link_With and Linker_Options).
18759 Arg_Store : declare
18760 C : constant Char_Code := Get_Char_Code (' ');
18761 S : constant String_Id :=
18762 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18763 L : constant Nat := String_Length (S);
18766 procedure Skip_Spaces;
18767 -- Advance F past any spaces
18773 procedure Skip_Spaces is
18775 while F <= L and then Get_String_Char (S, F) = C loop
18780 -- Start of processing for Arg_Store
18783 Skip_Spaces; -- skip leading spaces
18785 -- Loop through characters, changing any embedded
18786 -- sequence of spaces to a single null character (this
18787 -- is how Link_With/Linker_Options differ)
18790 if Get_String_Char (S, F) = C then
18793 Store_String_Char (ASCII.NUL);
18796 Store_String_Char (Get_String_Char (S, F));
18804 if Present (Arg) then
18805 Store_String_Char (ASCII.NUL);
18809 Store_Linker_Option_String (End_String);
18817 -- pragma Linker_Alias (
18818 -- [Entity =>] LOCAL_NAME
18819 -- [Target =>] static_string_EXPRESSION);
18821 when Pragma_Linker_Alias =>
18823 Check_Arg_Order ((Name_Entity, Name_Target));
18824 Check_Arg_Count (2);
18825 Check_Optional_Identifier (Arg1, Name_Entity);
18826 Check_Optional_Identifier (Arg2, Name_Target);
18827 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18828 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18830 -- The only processing required is to link this item on to the
18831 -- list of rep items for the given entity. This is accomplished
18832 -- by the call to Rep_Item_Too_Late (when no error is detected
18833 -- and False is returned).
18835 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18838 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18841 ------------------------
18842 -- Linker_Constructor --
18843 ------------------------
18845 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18847 -- Code is shared with Linker_Destructor
18849 -----------------------
18850 -- Linker_Destructor --
18851 -----------------------
18853 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18855 when Pragma_Linker_Constructor
18856 | Pragma_Linker_Destructor
18858 Linker_Constructor : declare
18864 Check_Arg_Count (1);
18865 Check_No_Identifiers;
18866 Check_Arg_Is_Local_Name (Arg1);
18867 Arg1_X := Get_Pragma_Arg (Arg1);
18869 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18871 if not Is_Library_Level_Entity (Proc) then
18873 ("argument for pragma% must be library level entity", Arg1);
18876 -- The only processing required is to link this item on to the
18877 -- list of rep items for the given entity. This is accomplished
18878 -- by the call to Rep_Item_Too_Late (when no error is detected
18879 -- and False is returned).
18881 if Rep_Item_Too_Late (Proc, N) then
18884 Set_Has_Gigi_Rep_Item (Proc);
18886 end Linker_Constructor;
18888 --------------------
18889 -- Linker_Options --
18890 --------------------
18892 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18894 when Pragma_Linker_Options => Linker_Options : declare
18898 Check_Ada_83_Warning;
18899 Check_No_Identifiers;
18900 Check_Arg_Count (1);
18901 Check_Is_In_Decl_Part_Or_Package_Spec;
18902 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18903 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18906 while Present (Arg) loop
18907 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18908 Store_String_Char (ASCII.NUL);
18910 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18914 if Operating_Mode = Generate_Code
18915 and then In_Extended_Main_Source_Unit (N)
18917 Store_Linker_Option_String (End_String);
18919 end Linker_Options;
18921 --------------------
18922 -- Linker_Section --
18923 --------------------
18925 -- pragma Linker_Section (
18926 -- [Entity =>] LOCAL_NAME
18927 -- [Section =>] static_string_EXPRESSION);
18929 when Pragma_Linker_Section => Linker_Section : declare
18934 Ghost_Error_Posted : Boolean := False;
18935 -- Flag set when an error concerning the illegal mix of Ghost and
18936 -- non-Ghost subprograms is emitted.
18938 Ghost_Id : Entity_Id := Empty;
18939 -- The entity of the first Ghost subprogram encountered while
18940 -- processing the arguments of the pragma.
18944 Check_Arg_Order ((Name_Entity, Name_Section));
18945 Check_Arg_Count (2);
18946 Check_Optional_Identifier (Arg1, Name_Entity);
18947 Check_Optional_Identifier (Arg2, Name_Section);
18948 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18949 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18951 -- Check kind of entity
18953 Arg := Get_Pragma_Arg (Arg1);
18954 Ent := Entity (Arg);
18956 case Ekind (Ent) is
18958 -- Objects (constants and variables) and types. For these cases
18959 -- all we need to do is to set the Linker_Section_pragma field,
18960 -- checking that we do not have a duplicate.
18966 LPE := Linker_Section_Pragma (Ent);
18968 if Present (LPE) then
18969 Error_Msg_Sloc := Sloc (LPE);
18971 ("Linker_Section already specified for &#", Arg1, Ent);
18974 Set_Linker_Section_Pragma (Ent, N);
18976 -- A pragma that applies to a Ghost entity becomes Ghost for
18977 -- the purposes of legality checks and removal of ignored
18980 Mark_Ghost_Pragma (N, Ent);
18984 when Subprogram_Kind =>
18986 -- Aspect case, entity already set
18988 if From_Aspect_Specification (N) then
18989 Set_Linker_Section_Pragma
18990 (Entity (Corresponding_Aspect (N)), N);
18992 -- Propagate it to its ultimate aliased entity to
18993 -- facilitate the backend processing this attribute
18994 -- in instantiations of generic subprograms.
18996 if Present (Alias (Entity (Corresponding_Aspect (N))))
18998 Set_Linker_Section_Pragma
19000 (Entity (Corresponding_Aspect (N))), N);
19003 -- Pragma case, we must climb the homonym chain, but skip
19004 -- any for which the linker section is already set.
19008 if No (Linker_Section_Pragma (Ent)) then
19009 Set_Linker_Section_Pragma (Ent, N);
19011 -- Propagate it to its ultimate aliased entity to
19012 -- facilitate the backend processing this attribute
19013 -- in instantiations of generic subprograms.
19015 if Present (Alias (Ent)) then
19016 Set_Linker_Section_Pragma
19017 (Ultimate_Alias (Ent), N);
19020 -- A pragma that applies to a Ghost entity becomes
19021 -- Ghost for the purposes of legality checks and
19022 -- removal of ignored Ghost code.
19024 Mark_Ghost_Pragma (N, Ent);
19026 -- Capture the entity of the first Ghost subprogram
19027 -- being processed for error detection purposes.
19029 if Is_Ghost_Entity (Ent) then
19030 if No (Ghost_Id) then
19034 -- Otherwise the subprogram is non-Ghost. It is
19035 -- illegal to mix references to Ghost and non-Ghost
19036 -- entities (SPARK RM 6.9).
19038 elsif Present (Ghost_Id)
19039 and then not Ghost_Error_Posted
19041 Ghost_Error_Posted := True;
19043 Error_Msg_Name_1 := Pname;
19045 ("pragma % cannot mention ghost and "
19046 & "non-ghost subprograms", N);
19048 Error_Msg_Sloc := Sloc (Ghost_Id);
19050 ("\& # declared as ghost", N, Ghost_Id);
19052 Error_Msg_Sloc := Sloc (Ent);
19054 ("\& # declared as non-ghost", N, Ent);
19058 Ent := Homonym (Ent);
19060 or else Scope (Ent) /= Current_Scope;
19064 -- All other cases are illegal
19068 ("pragma% applies only to objects, subprograms, and types",
19071 end Linker_Section;
19077 -- pragma List (On | Off)
19079 -- There is nothing to do here, since we did all the processing for
19080 -- this pragma in Par.Prag (so that it works properly even in syntax
19083 when Pragma_List =>
19090 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19092 when Pragma_Lock_Free => Lock_Free : declare
19093 P : constant Node_Id := Parent (N);
19099 Check_No_Identifiers;
19100 Check_At_Most_N_Arguments (1);
19102 -- Protected definition case
19104 if Nkind (P) = N_Protected_Definition then
19105 Ent := Defining_Identifier (Parent (P));
19109 if Arg_Count = 1 then
19110 Arg := Get_Pragma_Arg (Arg1);
19111 Val := Is_True (Static_Boolean (Arg));
19113 -- No arguments (expression is considered to be True)
19119 -- Check duplicate pragma before we chain the pragma in the Rep
19120 -- Item chain of Ent.
19122 Check_Duplicate_Pragma (Ent);
19123 Record_Rep_Item (Ent, N);
19124 Set_Uses_Lock_Free (Ent, Val);
19126 -- Anything else is incorrect placement
19133 --------------------
19134 -- Locking_Policy --
19135 --------------------
19137 -- pragma Locking_Policy (policy_IDENTIFIER);
19139 when Pragma_Locking_Policy => declare
19140 subtype LP_Range is Name_Id
19141 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19146 Check_Ada_83_Warning;
19147 Check_Arg_Count (1);
19148 Check_No_Identifiers;
19149 Check_Arg_Is_Locking_Policy (Arg1);
19150 Check_Valid_Configuration_Pragma;
19151 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19154 when Name_Ceiling_Locking => LP := 'C';
19155 when Name_Concurrent_Readers_Locking => LP := 'R';
19156 when Name_Inheritance_Locking => LP := 'I';
19159 if Locking_Policy /= ' '
19160 and then Locking_Policy /= LP
19162 Error_Msg_Sloc := Locking_Policy_Sloc;
19163 Error_Pragma ("locking policy incompatible with policy#");
19165 -- Set new policy, but always preserve System_Location since we
19166 -- like the error message with the run time name.
19169 Locking_Policy := LP;
19171 if Locking_Policy_Sloc /= System_Location then
19172 Locking_Policy_Sloc := Loc;
19177 -------------------
19178 -- Loop_Optimize --
19179 -------------------
19181 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19183 -- OPTIMIZATION_HINT ::=
19184 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19186 when Pragma_Loop_Optimize => Loop_Optimize : declare
19191 Check_At_Least_N_Arguments (1);
19192 Check_No_Identifiers;
19194 Hint := First (Pragma_Argument_Associations (N));
19195 while Present (Hint) loop
19196 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19204 Check_Loop_Pragma_Placement;
19211 -- pragma Loop_Variant
19212 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19214 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19216 -- CHANGE_DIRECTION ::= Increases | Decreases
19218 when Pragma_Loop_Variant => Loop_Variant : declare
19223 Check_At_Least_N_Arguments (1);
19224 Check_Loop_Pragma_Placement;
19226 -- Process all increasing / decreasing expressions
19228 Variant := First (Pragma_Argument_Associations (N));
19229 while Present (Variant) loop
19230 if Chars (Variant) = No_Name then
19231 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19233 elsif Chars (Variant) not in Name_Decreases | Name_Increases
19236 Name : String := Get_Name_String (Chars (Variant));
19239 -- It is a common mistake to write "Increasing" for
19240 -- "Increases" or "Decreasing" for "Decreases". Recognize
19241 -- specially names starting with "incr" or "decr" to
19242 -- suggest the corresponding name.
19244 System.Case_Util.To_Lower (Name);
19246 if Name'Length >= 4
19247 and then Name (1 .. 4) = "incr"
19249 Error_Pragma_Arg_Ident
19250 ("expect name `Increases`", Variant);
19252 elsif Name'Length >= 4
19253 and then Name (1 .. 4) = "decr"
19255 Error_Pragma_Arg_Ident
19256 ("expect name `Decreases`", Variant);
19259 Error_Pragma_Arg_Ident
19260 ("expect name `Increases` or `Decreases`", Variant);
19265 Preanalyze_Assert_Expression
19266 (Expression (Variant), Any_Discrete);
19272 -----------------------
19273 -- Machine_Attribute --
19274 -----------------------
19276 -- pragma Machine_Attribute (
19277 -- [Entity =>] LOCAL_NAME,
19278 -- [Attribute_Name =>] static_string_EXPRESSION
19279 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19281 when Pragma_Machine_Attribute => Machine_Attribute : declare
19283 Def_Id : Entity_Id;
19287 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19289 if Arg_Count >= 3 then
19290 Check_Optional_Identifier (Arg3, Name_Info);
19292 while Present (Arg) loop
19293 Check_Arg_Is_OK_Static_Expression (Arg);
19297 Check_Arg_Count (2);
19300 Check_Optional_Identifier (Arg1, Name_Entity);
19301 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19302 Check_Arg_Is_Local_Name (Arg1);
19303 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19304 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19306 if Is_Access_Type (Def_Id) then
19307 Def_Id := Designated_Type (Def_Id);
19310 if Rep_Item_Too_Early (Def_Id, N) then
19314 Def_Id := Underlying_Type (Def_Id);
19316 -- The only processing required is to link this item on to the
19317 -- list of rep items for the given entity. This is accomplished
19318 -- by the call to Rep_Item_Too_Late (when no error is detected
19319 -- and False is returned).
19321 if Rep_Item_Too_Late (Def_Id, N) then
19324 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19326 end Machine_Attribute;
19333 -- (MAIN_OPTION [, MAIN_OPTION]);
19336 -- [STACK_SIZE =>] static_integer_EXPRESSION
19337 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19338 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19340 when Pragma_Main => Main : declare
19341 Args : Args_List (1 .. 3);
19342 Names : constant Name_List (1 .. 3) := (
19344 Name_Task_Stack_Size_Default,
19345 Name_Time_Slicing_Enabled);
19351 Gather_Associations (Names, Args);
19353 for J in 1 .. 2 loop
19354 if Present (Args (J)) then
19355 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19359 if Present (Args (3)) then
19360 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19364 while Present (Nod) loop
19365 if Nkind (Nod) = N_Pragma
19366 and then Pragma_Name (Nod) = Name_Main
19368 Error_Msg_Name_1 := Pname;
19369 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19380 -- pragma Main_Storage
19381 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19383 -- MAIN_STORAGE_OPTION ::=
19384 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19385 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19387 when Pragma_Main_Storage => Main_Storage : declare
19388 Args : Args_List (1 .. 2);
19389 Names : constant Name_List (1 .. 2) := (
19390 Name_Working_Storage,
19397 Gather_Associations (Names, Args);
19399 for J in 1 .. 2 loop
19400 if Present (Args (J)) then
19401 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19405 Check_In_Main_Program;
19408 while Present (Nod) loop
19409 if Nkind (Nod) = N_Pragma
19410 and then Pragma_Name (Nod) = Name_Main_Storage
19412 Error_Msg_Name_1 := Pname;
19413 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19420 ----------------------------
19421 -- Max_Entry_Queue_Length --
19422 ----------------------------
19424 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19426 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19427 -- Pragma_Max_Queue_Length.
19429 when Pragma_Max_Entry_Queue_Length
19430 | Pragma_Max_Entry_Queue_Depth
19431 | Pragma_Max_Queue_Length
19433 Max_Entry_Queue_Length : declare
19435 Entry_Decl : Node_Id;
19436 Entry_Id : Entity_Id;
19440 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19441 or else Prag_Id = Pragma_Max_Queue_Length
19446 Check_Arg_Count (1);
19449 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19451 -- Entry declaration
19453 if Nkind (Entry_Decl) = N_Entry_Declaration then
19455 -- Entry illegally within a task
19457 if Nkind (Parent (N)) = N_Task_Definition then
19458 Error_Pragma ("pragma % cannot apply to task entries");
19462 Entry_Id := Defining_Entity (Entry_Decl);
19464 -- Otherwise the pragma is associated with an illegal construct
19468 ("pragma % must apply to a protected entry declaration");
19472 -- Mark the pragma as Ghost if the related subprogram is also
19473 -- Ghost. This also ensures that any expansion performed further
19474 -- below will produce Ghost nodes.
19476 Mark_Ghost_Pragma (N, Entry_Id);
19478 -- Analyze the Integer expression
19480 Arg := Get_Pragma_Arg (Arg1);
19481 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19483 Val := Expr_Value (Arg);
19487 ("argument for pragma% cannot be less than -1", Arg1);
19489 elsif not UI_Is_In_Int_Range (Val) then
19491 ("argument for pragma% out of range of Integer", Arg1);
19495 Record_Rep_Item (Entry_Id, N);
19496 end Max_Entry_Queue_Length;
19502 -- pragma Memory_Size (NUMERIC_LITERAL)
19504 when Pragma_Memory_Size =>
19507 -- Memory size is simply ignored
19509 Check_No_Identifiers;
19510 Check_Arg_Count (1);
19511 Check_Arg_Is_Integer_Literal (Arg1);
19519 -- The only correct use of this pragma is on its own in a file, in
19520 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19521 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19522 -- check for a file containing nothing but a No_Body pragma). If we
19523 -- attempt to process it during normal semantics processing, it means
19524 -- it was misplaced.
19526 when Pragma_No_Body =>
19530 -----------------------------
19531 -- No_Elaboration_Code_All --
19532 -----------------------------
19534 -- pragma No_Elaboration_Code_All;
19536 when Pragma_No_Elaboration_Code_All =>
19538 Check_Valid_Library_Unit_Pragma;
19540 if Nkind (N) = N_Null_Statement then
19544 -- Must appear for a spec or generic spec
19546 if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
19547 N_Generic_Package_Declaration |
19548 N_Generic_Subprogram_Declaration |
19549 N_Package_Declaration |
19550 N_Subprogram_Declaration
19554 ("pragma% can only occur for package "
19555 & "or subprogram spec"));
19558 -- Set flag in unit table
19560 Set_No_Elab_Code_All (Current_Sem_Unit);
19562 -- Set restriction No_Elaboration_Code if this is the main unit
19564 if Current_Sem_Unit = Main_Unit then
19565 Set_Restriction (No_Elaboration_Code, N);
19568 -- If we are in the main unit or in an extended main source unit,
19569 -- then we also add it to the configuration restrictions so that
19570 -- it will apply to all units in the extended main source.
19572 if Current_Sem_Unit = Main_Unit
19573 or else In_Extended_Main_Source_Unit (N)
19575 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19578 -- If in main extended unit, activate transitive with test
19580 if In_Extended_Main_Source_Unit (N) then
19581 Opt.No_Elab_Code_All_Pragma := N;
19584 -----------------------------
19585 -- No_Component_Reordering --
19586 -----------------------------
19588 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19590 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19596 Check_At_Most_N_Arguments (1);
19598 if Arg_Count = 0 then
19599 Check_Valid_Configuration_Pragma;
19600 Opt.No_Component_Reordering := True;
19603 Check_Optional_Identifier (Arg2, Name_Entity);
19604 Check_Arg_Is_Local_Name (Arg1);
19605 E_Id := Get_Pragma_Arg (Arg1);
19607 if Etype (E_Id) = Any_Type then
19611 E := Entity (E_Id);
19613 if not Is_Record_Type (E) then
19614 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19617 Set_No_Reordering (Base_Type (E));
19619 end No_Comp_Reordering;
19621 --------------------------
19622 -- No_Heap_Finalization --
19623 --------------------------
19625 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19627 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19628 Context : constant Node_Id := Parent (N);
19629 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19635 Check_No_Identifiers;
19637 -- The pragma appears in a configuration file
19639 if No (Context) then
19640 Check_Arg_Count (0);
19641 Check_Valid_Configuration_Pragma;
19643 -- Detect a duplicate pragma
19645 if Present (No_Heap_Finalization_Pragma) then
19648 Prev => No_Heap_Finalization_Pragma);
19652 No_Heap_Finalization_Pragma := N;
19654 -- Otherwise the pragma should be associated with a library-level
19655 -- named access-to-object type.
19658 Check_Arg_Count (1);
19659 Check_Arg_Is_Local_Name (Arg1);
19661 Find_Type (Typ_Arg);
19662 Typ := Entity (Typ_Arg);
19664 -- The type being subjected to the pragma is erroneous
19666 if Typ = Any_Type then
19667 Error_Pragma ("cannot find type referenced by pragma %");
19669 -- The pragma is applied to an incomplete or generic formal
19670 -- type way too early.
19672 elsif Rep_Item_Too_Early (Typ, N) then
19676 Typ := Underlying_Type (Typ);
19679 -- The pragma must apply to an access-to-object type
19681 if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
19684 -- Give a detailed error message on all other access type kinds
19686 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19688 ("pragma % cannot apply to access protected subprogram "
19691 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19693 ("pragma % cannot apply to access subprogram type");
19695 elsif Is_Anonymous_Access_Type (Typ) then
19697 ("pragma % cannot apply to anonymous access type");
19699 -- Give a general error message in case the pragma applies to a
19700 -- non-access type.
19704 ("pragma % must apply to library level access type");
19707 -- At this point the argument denotes an access-to-object type.
19708 -- Ensure that the type is declared at the library level.
19710 if Is_Library_Level_Entity (Typ) then
19713 -- Quietly ignore an access-to-object type originally declared
19714 -- at the library level within a generic, but instantiated at
19715 -- a non-library level. As a result the access-to-object type
19716 -- "loses" its No_Heap_Finalization property.
19718 elsif In_Instance then
19723 ("pragma % must apply to library level access type");
19726 -- Detect a duplicate pragma
19728 if Present (No_Heap_Finalization_Pragma) then
19731 Prev => No_Heap_Finalization_Pragma);
19735 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19737 if Present (Prev) then
19745 Record_Rep_Item (Typ, N);
19747 end No_Heap_Finalization;
19753 -- pragma No_Inline ( NAME {, NAME} );
19755 when Pragma_No_Inline =>
19757 Process_Inline (Suppressed);
19763 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19765 when Pragma_No_Return => No_Return : declare
19771 Ghost_Error_Posted : Boolean := False;
19772 -- Flag set when an error concerning the illegal mix of Ghost and
19773 -- non-Ghost subprograms is emitted.
19775 Ghost_Id : Entity_Id := Empty;
19776 -- The entity of the first Ghost procedure encountered while
19777 -- processing the arguments of the pragma.
19781 Check_At_Least_N_Arguments (1);
19783 -- Loop through arguments of pragma
19786 while Present (Arg) loop
19787 Check_Arg_Is_Local_Name (Arg);
19788 Id := Get_Pragma_Arg (Arg);
19791 if not Is_Entity_Name (Id) then
19792 Error_Pragma_Arg ("entity name required", Arg);
19795 if Etype (Id) = Any_Type then
19799 -- Loop to find matching procedures or functions (Ada 2020)
19805 and then Scope (E) = Current_Scope
19807 -- Ada 2020 (AI12-0269): A function can be No_Return
19809 if Ekind (E) in E_Generic_Procedure | E_Procedure
19810 or else (Ada_Version >= Ada_2020
19812 Ekind (E) in E_Generic_Function | E_Function)
19814 -- Check that the pragma is not applied to a body.
19815 -- First check the specless body case, to give a
19816 -- different error message. These checks do not apply
19817 -- if Relaxed_RM_Semantics, to accommodate other Ada
19818 -- compilers. Disable these checks under -gnatd.J.
19820 if not Debug_Flag_Dot_JJ then
19821 if Nkind (Parent (Declaration_Node (E))) =
19823 and then not Relaxed_RM_Semantics
19826 ("pragma% requires separate spec and must come "
19830 -- Now the "specful" body case
19832 if Rep_Item_Too_Late (E, N) then
19839 -- A pragma that applies to a Ghost entity becomes Ghost
19840 -- for the purposes of legality checks and removal of
19841 -- ignored Ghost code.
19843 Mark_Ghost_Pragma (N, E);
19845 -- Capture the entity of the first Ghost procedure being
19846 -- processed for error detection purposes.
19848 if Is_Ghost_Entity (E) then
19849 if No (Ghost_Id) then
19853 -- Otherwise the subprogram is non-Ghost. It is illegal
19854 -- to mix references to Ghost and non-Ghost entities
19857 elsif Present (Ghost_Id)
19858 and then not Ghost_Error_Posted
19860 Ghost_Error_Posted := True;
19862 Error_Msg_Name_1 := Pname;
19864 ("pragma % cannot mention ghost and non-ghost "
19865 & "procedures", N);
19867 Error_Msg_Sloc := Sloc (Ghost_Id);
19868 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19870 Error_Msg_Sloc := Sloc (E);
19871 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19874 -- Set flag on any alias as well
19876 if Is_Overloadable (E) and then Present (Alias (E)) then
19877 Set_No_Return (Alias (E));
19883 exit when From_Aspect_Specification (N);
19887 -- If entity in not in current scope it may be the enclosing
19888 -- suprogram body to which the aspect applies.
19891 if Entity (Id) = Current_Scope
19892 and then From_Aspect_Specification (N)
19894 Set_No_Return (Entity (Id));
19896 elsif Ada_Version >= Ada_2020 then
19898 ("no subprogram& found for pragma%", Arg);
19901 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19913 -- pragma No_Run_Time;
19915 -- Note: this pragma is retained for backwards compatibility. See
19916 -- body of Rtsfind for full details on its handling.
19918 when Pragma_No_Run_Time =>
19920 Check_Valid_Configuration_Pragma;
19921 Check_Arg_Count (0);
19923 -- Remove backward compatibility if Build_Type is FSF or GPL and
19924 -- generate a warning.
19927 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19930 Error_Pragma ("pragma% is ignored, has no effect??");
19932 No_Run_Time_Mode := True;
19933 Configurable_Run_Time_Mode := True;
19935 -- Set Duration to 32 bits if word size is 32
19937 if Ttypes.System_Word_Size = 32 then
19938 Duration_32_Bits_On_Target := True;
19941 -- Set appropriate restrictions
19943 Set_Restriction (No_Finalization, N);
19944 Set_Restriction (No_Exception_Handlers, N);
19945 Set_Restriction (Max_Tasks, N, 0);
19946 Set_Restriction (No_Tasking, N);
19950 -----------------------
19951 -- No_Tagged_Streams --
19952 -----------------------
19954 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19956 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19962 Check_At_Most_N_Arguments (1);
19964 -- One argument case
19966 if Arg_Count = 1 then
19967 Check_Optional_Identifier (Arg1, Name_Entity);
19968 Check_Arg_Is_Local_Name (Arg1);
19969 E_Id := Get_Pragma_Arg (Arg1);
19971 if Etype (E_Id) = Any_Type then
19975 E := Entity (E_Id);
19977 Check_Duplicate_Pragma (E);
19979 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19981 ("argument for pragma% must be root tagged type", Arg1);
19984 if Rep_Item_Too_Early (E, N)
19986 Rep_Item_Too_Late (E, N)
19990 Set_No_Tagged_Streams_Pragma (E, N);
19993 -- Zero argument case
19996 Check_Is_In_Decl_Part_Or_Package_Spec;
19997 No_Tagged_Streams := N;
19999 end No_Tagged_Strms;
20001 ------------------------
20002 -- No_Strict_Aliasing --
20003 ------------------------
20005 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20007 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20013 Check_At_Most_N_Arguments (1);
20015 if Arg_Count = 0 then
20016 Check_Valid_Configuration_Pragma;
20017 Opt.No_Strict_Aliasing := True;
20020 Check_Optional_Identifier (Arg2, Name_Entity);
20021 Check_Arg_Is_Local_Name (Arg1);
20022 E_Id := Get_Pragma_Arg (Arg1);
20024 if Etype (E_Id) = Any_Type then
20028 E := Entity (E_Id);
20030 if not Is_Access_Type (E) then
20031 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20034 Set_No_Strict_Aliasing (Base_Type (E));
20036 end No_Strict_Aliasing;
20038 -----------------------
20039 -- Normalize_Scalars --
20040 -----------------------
20042 -- pragma Normalize_Scalars;
20044 when Pragma_Normalize_Scalars =>
20045 Check_Ada_83_Warning;
20046 Check_Arg_Count (0);
20047 Check_Valid_Configuration_Pragma;
20049 -- Normalize_Scalars creates false positives in CodePeer, and
20050 -- incorrect negative results in GNATprove mode, so ignore this
20051 -- pragma in these modes.
20053 if not (CodePeer_Mode or GNATprove_Mode) then
20054 Normalize_Scalars := True;
20055 Init_Or_Norm_Scalars := True;
20062 -- pragma Obsolescent;
20064 -- pragma Obsolescent (
20065 -- [Message =>] static_string_EXPRESSION
20066 -- [,[Version =>] Ada_05]]);
20068 -- pragma Obsolescent (
20069 -- [Entity =>] NAME
20070 -- [,[Message =>] static_string_EXPRESSION
20071 -- [,[Version =>] Ada_05]] );
20073 when Pragma_Obsolescent => Obsolescent : declare
20077 procedure Set_Obsolescent (E : Entity_Id);
20078 -- Given an entity Ent, mark it as obsolescent if appropriate
20080 ---------------------
20081 -- Set_Obsolescent --
20082 ---------------------
20084 procedure Set_Obsolescent (E : Entity_Id) is
20093 -- A pragma that applies to a Ghost entity becomes Ghost for
20094 -- the purposes of legality checks and removal of ignored Ghost
20097 Mark_Ghost_Pragma (N, E);
20099 -- Entity name was given
20101 if Present (Ename) then
20103 -- If entity name matches, we are fine.
20105 if Chars (Ename) = Chars (Ent) then
20106 Set_Entity (Ename, Ent);
20107 Generate_Reference (Ent, Ename);
20109 -- If entity name does not match, only possibility is an
20110 -- enumeration literal from an enumeration type declaration.
20112 elsif Ekind (Ent) /= E_Enumeration_Type then
20114 ("pragma % entity name does not match declaration");
20117 Ent := First_Literal (E);
20121 ("pragma % entity name does not match any "
20122 & "enumeration literal");
20124 elsif Chars (Ent) = Chars (Ename) then
20125 Set_Entity (Ename, Ent);
20126 Generate_Reference (Ent, Ename);
20130 Next_Literal (Ent);
20136 -- Ent points to entity to be marked
20138 if Arg_Count >= 1 then
20140 -- Deal with static string argument
20142 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20143 S := Strval (Get_Pragma_Arg (Arg1));
20145 for J in 1 .. String_Length (S) loop
20146 if not In_Character_Range (Get_String_Char (S, J)) then
20148 ("pragma% argument does not allow wide characters",
20153 Obsolescent_Warnings.Append
20154 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20156 -- Check for Ada_05 parameter
20158 if Arg_Count /= 1 then
20159 Check_Arg_Count (2);
20162 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20165 Check_Arg_Is_Identifier (Argx);
20167 if Chars (Argx) /= Name_Ada_05 then
20168 Error_Msg_Name_2 := Name_Ada_05;
20170 ("only allowed argument for pragma% is %", Argx);
20173 if Ada_Version_Explicit < Ada_2005
20174 or else not Warn_On_Ada_2005_Compatibility
20182 -- Set flag if pragma active
20185 Set_Is_Obsolescent (Ent);
20189 end Set_Obsolescent;
20191 -- Start of processing for pragma Obsolescent
20196 Check_At_Most_N_Arguments (3);
20198 -- See if first argument specifies an entity name
20202 (Chars (Arg1) = Name_Entity
20204 Nkind (Get_Pragma_Arg (Arg1)) in
20205 N_Character_Literal | N_Identifier | N_Operator_Symbol)
20207 Ename := Get_Pragma_Arg (Arg1);
20209 -- Eliminate first argument, so we can share processing
20213 Arg_Count := Arg_Count - 1;
20215 -- No Entity name argument given
20221 if Arg_Count >= 1 then
20222 Check_Optional_Identifier (Arg1, Name_Message);
20224 if Arg_Count = 2 then
20225 Check_Optional_Identifier (Arg2, Name_Version);
20229 -- Get immediately preceding declaration
20232 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20236 -- Cases where we do not follow anything other than another pragma
20240 -- First case: library level compilation unit declaration with
20241 -- the pragma immediately following the declaration.
20243 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20245 (Defining_Entity (Unit (Parent (Parent (N)))));
20248 -- Case 2: library unit placement for package
20252 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20254 if Is_Package_Or_Generic_Package (Ent) then
20255 Set_Obsolescent (Ent);
20261 -- Cases where we must follow a declaration, including an
20262 -- abstract subprogram declaration, which is not in the
20263 -- other node subtypes.
20266 if Nkind (Decl) not in N_Declaration
20267 and then Nkind (Decl) not in N_Later_Decl_Item
20268 and then Nkind (Decl) not in N_Generic_Declaration
20269 and then Nkind (Decl) not in N_Renaming_Declaration
20270 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20273 ("pragma% misplaced, "
20274 & "must immediately follow a declaration");
20277 Set_Obsolescent (Defining_Entity (Decl));
20287 -- pragma Optimize (Time | Space | Off);
20289 -- The actual check for optimize is done in Gigi. Note that this
20290 -- pragma does not actually change the optimization setting, it
20291 -- simply checks that it is consistent with the pragma.
20293 when Pragma_Optimize =>
20294 Check_No_Identifiers;
20295 Check_Arg_Count (1);
20296 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20298 ------------------------
20299 -- Optimize_Alignment --
20300 ------------------------
20302 -- pragma Optimize_Alignment (Time | Space | Off);
20304 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20306 Check_No_Identifiers;
20307 Check_Arg_Count (1);
20308 Check_Valid_Configuration_Pragma;
20311 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20314 when Name_Off => Opt.Optimize_Alignment := 'O';
20315 when Name_Space => Opt.Optimize_Alignment := 'S';
20316 when Name_Time => Opt.Optimize_Alignment := 'T';
20319 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20323 -- Set indication that mode is set locally. If we are in fact in a
20324 -- configuration pragma file, this setting is harmless since the
20325 -- switch will get reset anyway at the start of each unit.
20327 Optimize_Alignment_Local := True;
20328 end Optimize_Alignment;
20334 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20336 when Pragma_Ordered => Ordered : declare
20337 Assoc : constant Node_Id := Arg1;
20343 Check_No_Identifiers;
20344 Check_Arg_Count (1);
20345 Check_Arg_Is_Local_Name (Arg1);
20347 Type_Id := Get_Pragma_Arg (Assoc);
20348 Find_Type (Type_Id);
20349 Typ := Entity (Type_Id);
20351 if Typ = Any_Type then
20354 Typ := Underlying_Type (Typ);
20357 if not Is_Enumeration_Type (Typ) then
20358 Error_Pragma ("pragma% must specify enumeration type");
20361 Check_First_Subtype (Arg1);
20362 Set_Has_Pragma_Ordered (Base_Type (Typ));
20365 -------------------
20366 -- Overflow_Mode --
20367 -------------------
20369 -- pragma Overflow_Mode
20370 -- ([General => ] MODE [, [Assertions => ] MODE]);
20372 -- MODE := STRICT | MINIMIZED | ELIMINATED
20374 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20375 -- since System.Bignums makes this assumption. This is true of nearly
20376 -- all (all?) targets.
20378 when Pragma_Overflow_Mode => Overflow_Mode : declare
20379 function Get_Overflow_Mode
20381 Arg : Node_Id) return Overflow_Mode_Type;
20382 -- Function to process one pragma argument, Arg. If an identifier
20383 -- is present, it must be Name. Mode type is returned if a valid
20384 -- argument exists, otherwise an error is signalled.
20386 -----------------------
20387 -- Get_Overflow_Mode --
20388 -----------------------
20390 function Get_Overflow_Mode
20392 Arg : Node_Id) return Overflow_Mode_Type
20394 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20397 Check_Optional_Identifier (Arg, Name);
20398 Check_Arg_Is_Identifier (Argx);
20400 if Chars (Argx) = Name_Strict then
20403 elsif Chars (Argx) = Name_Minimized then
20406 elsif Chars (Argx) = Name_Eliminated then
20407 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20409 ("Eliminated not implemented on this target", Argx);
20415 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20417 end Get_Overflow_Mode;
20419 -- Start of processing for Overflow_Mode
20423 Check_At_Least_N_Arguments (1);
20424 Check_At_Most_N_Arguments (2);
20426 -- Process first argument
20428 Scope_Suppress.Overflow_Mode_General :=
20429 Get_Overflow_Mode (Name_General, Arg1);
20431 -- Case of only one argument
20433 if Arg_Count = 1 then
20434 Scope_Suppress.Overflow_Mode_Assertions :=
20435 Scope_Suppress.Overflow_Mode_General;
20437 -- Case of two arguments present
20440 Scope_Suppress.Overflow_Mode_Assertions :=
20441 Get_Overflow_Mode (Name_Assertions, Arg2);
20445 --------------------------
20446 -- Overriding Renamings --
20447 --------------------------
20449 -- pragma Overriding_Renamings;
20451 when Pragma_Overriding_Renamings =>
20453 Check_Arg_Count (0);
20454 Check_Valid_Configuration_Pragma;
20455 Overriding_Renamings := True;
20461 -- pragma Pack (first_subtype_LOCAL_NAME);
20463 when Pragma_Pack => Pack : declare
20464 Assoc : constant Node_Id := Arg1;
20466 Ignore : Boolean := False;
20471 Check_No_Identifiers;
20472 Check_Arg_Count (1);
20473 Check_Arg_Is_Local_Name (Arg1);
20474 Type_Id := Get_Pragma_Arg (Assoc);
20476 if not Is_Entity_Name (Type_Id)
20477 or else not Is_Type (Entity (Type_Id))
20480 ("argument for pragma% must be type or subtype", Arg1);
20483 Find_Type (Type_Id);
20484 Typ := Entity (Type_Id);
20487 or else Rep_Item_Too_Early (Typ, N)
20491 Typ := Underlying_Type (Typ);
20494 -- A pragma that applies to a Ghost entity becomes Ghost for the
20495 -- purposes of legality checks and removal of ignored Ghost code.
20497 Mark_Ghost_Pragma (N, Typ);
20499 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20500 Error_Pragma ("pragma% must specify array or record type");
20503 Check_First_Subtype (Arg1);
20504 Check_Duplicate_Pragma (Typ);
20508 if Is_Array_Type (Typ) then
20509 Ctyp := Component_Type (Typ);
20511 -- Ignore pack that does nothing
20513 if Known_Static_Esize (Ctyp)
20514 and then Known_Static_RM_Size (Ctyp)
20515 and then Esize (Ctyp) = RM_Size (Ctyp)
20516 and then Addressable (Esize (Ctyp))
20521 -- Process OK pragma Pack. Note that if there is a separate
20522 -- component clause present, the Pack will be cancelled. This
20523 -- processing is in Freeze.
20525 if not Rep_Item_Too_Late (Typ, N) then
20527 -- In CodePeer mode, we do not need complex front-end
20528 -- expansions related to pragma Pack, so disable handling
20531 if CodePeer_Mode then
20534 -- Normal case where we do the pack action
20538 Set_Is_Packed (Base_Type (Typ));
20539 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20542 Set_Has_Pragma_Pack (Base_Type (Typ));
20546 -- For record types, the pack is always effective
20548 else pragma Assert (Is_Record_Type (Typ));
20549 if not Rep_Item_Too_Late (Typ, N) then
20550 Set_Is_Packed (Base_Type (Typ));
20551 Set_Has_Pragma_Pack (Base_Type (Typ));
20552 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20563 -- There is nothing to do here, since we did all the processing for
20564 -- this pragma in Par.Prag (so that it works properly even in syntax
20567 when Pragma_Page =>
20574 -- pragma Part_Of (ABSTRACT_STATE);
20576 -- ABSTRACT_STATE ::= NAME
20578 when Pragma_Part_Of => Part_Of : declare
20579 procedure Propagate_Part_Of
20580 (Pack_Id : Entity_Id;
20581 State_Id : Entity_Id;
20582 Instance : Node_Id);
20583 -- Propagate the Part_Of indicator to all abstract states and
20584 -- objects declared in the visible state space of a package
20585 -- denoted by Pack_Id. State_Id is the encapsulating state.
20586 -- Instance is the package instantiation node.
20588 -----------------------
20589 -- Propagate_Part_Of --
20590 -----------------------
20592 procedure Propagate_Part_Of
20593 (Pack_Id : Entity_Id;
20594 State_Id : Entity_Id;
20595 Instance : Node_Id)
20597 Has_Item : Boolean := False;
20598 -- Flag set when the visible state space contains at least one
20599 -- abstract state or variable.
20601 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20602 -- Propagate the Part_Of indicator to all abstract states and
20603 -- objects declared in the visible state space of a package
20604 -- denoted by Pack_Id.
20606 -----------------------
20607 -- Propagate_Part_Of --
20608 -----------------------
20610 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20611 Constits : Elist_Id;
20612 Item_Id : Entity_Id;
20615 -- Traverse the entity chain of the package and set relevant
20616 -- attributes of abstract states and objects declared in the
20617 -- visible state space of the package.
20619 Item_Id := First_Entity (Pack_Id);
20620 while Present (Item_Id)
20621 and then not In_Private_Part (Item_Id)
20623 -- Do not consider internally generated items
20625 if not Comes_From_Source (Item_Id) then
20628 -- Do not consider generic formals or their corresponding
20629 -- actuals because they are not part of a visible state.
20630 -- Note that both entities are marked as hidden.
20632 elsif Is_Hidden (Item_Id) then
20635 -- The Part_Of indicator turns an abstract state or an
20636 -- object into a constituent of the encapsulating state.
20637 -- Note that constants are considered here even though
20638 -- they may not depend on variable input. This check is
20639 -- left to the SPARK prover.
20641 elsif Ekind (Item_Id) in
20642 E_Abstract_State | E_Constant | E_Variable
20645 Constits := Part_Of_Constituents (State_Id);
20647 if No (Constits) then
20648 Constits := New_Elmt_List;
20649 Set_Part_Of_Constituents (State_Id, Constits);
20652 Append_Elmt (Item_Id, Constits);
20653 Set_Encapsulating_State (Item_Id, State_Id);
20655 -- Recursively handle nested packages and instantiations
20657 elsif Ekind (Item_Id) = E_Package then
20658 Propagate_Part_Of (Item_Id);
20661 Next_Entity (Item_Id);
20663 end Propagate_Part_Of;
20665 -- Start of processing for Propagate_Part_Of
20668 Propagate_Part_Of (Pack_Id);
20670 -- Detect a package instantiation that is subject to a Part_Of
20671 -- indicator, but has no visible state.
20673 if not Has_Item then
20675 ("package instantiation & has Part_Of indicator but "
20676 & "lacks visible state", Instance, Pack_Id);
20678 end Propagate_Part_Of;
20682 Constits : Elist_Id;
20684 Encap_Id : Entity_Id;
20685 Item_Id : Entity_Id;
20689 -- Start of processing for Part_Of
20693 Check_No_Identifiers;
20694 Check_Arg_Count (1);
20696 Stmt := Find_Related_Context (N, Do_Checks => True);
20698 -- Object declaration
20700 if Nkind (Stmt) = N_Object_Declaration then
20703 -- Package instantiation
20705 elsif Nkind (Stmt) = N_Package_Instantiation then
20708 -- Single concurrent type declaration
20710 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20713 -- Otherwise the pragma is associated with an illegal construct
20720 -- Extract the entity of the related object declaration or package
20721 -- instantiation. In the case of the instantiation, use the entity
20722 -- of the instance spec.
20724 if Nkind (Stmt) = N_Package_Instantiation then
20725 Stmt := Instance_Spec (Stmt);
20728 Item_Id := Defining_Entity (Stmt);
20730 -- A pragma that applies to a Ghost entity becomes Ghost for the
20731 -- purposes of legality checks and removal of ignored Ghost code.
20733 Mark_Ghost_Pragma (N, Item_Id);
20735 -- Chain the pragma on the contract for further processing by
20736 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20738 Add_Contract_Item (N, Item_Id);
20740 -- A variable may act as constituent of a single concurrent type
20741 -- which in turn could be declared after the variable. Due to this
20742 -- discrepancy, the full analysis of indicator Part_Of is delayed
20743 -- until the end of the enclosing declarative region (see routine
20744 -- Analyze_Part_Of_In_Decl_Part).
20746 if Ekind (Item_Id) = E_Variable then
20749 -- Otherwise indicator Part_Of applies to a constant or a package
20753 Encap := Get_Pragma_Arg (Arg1);
20755 -- Detect any discrepancies between the placement of the
20756 -- constant or package instantiation with respect to state
20757 -- space and the encapsulating state.
20761 Item_Id => Item_Id,
20763 Encap_Id => Encap_Id,
20767 pragma Assert (Present (Encap_Id));
20769 if Ekind (Item_Id) = E_Constant then
20770 Constits := Part_Of_Constituents (Encap_Id);
20772 if No (Constits) then
20773 Constits := New_Elmt_List;
20774 Set_Part_Of_Constituents (Encap_Id, Constits);
20777 Append_Elmt (Item_Id, Constits);
20778 Set_Encapsulating_State (Item_Id, Encap_Id);
20780 -- Propagate the Part_Of indicator to the visible state
20781 -- space of the package instantiation.
20785 (Pack_Id => Item_Id,
20786 State_Id => Encap_Id,
20793 ----------------------------------
20794 -- Partition_Elaboration_Policy --
20795 ----------------------------------
20797 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20799 when Pragma_Partition_Elaboration_Policy => PEP : declare
20800 subtype PEP_Range is Name_Id
20801 range First_Partition_Elaboration_Policy_Name
20802 .. Last_Partition_Elaboration_Policy_Name;
20803 PEP_Val : PEP_Range;
20808 Check_Arg_Count (1);
20809 Check_No_Identifiers;
20810 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20811 Check_Valid_Configuration_Pragma;
20812 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20815 when Name_Concurrent => PEP := 'C';
20816 when Name_Sequential => PEP := 'S';
20819 if Partition_Elaboration_Policy /= ' '
20820 and then Partition_Elaboration_Policy /= PEP
20822 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20824 ("partition elaboration policy incompatible with policy#");
20826 -- Set new policy, but always preserve System_Location since we
20827 -- like the error message with the run time name.
20830 Partition_Elaboration_Policy := PEP;
20832 if Partition_Elaboration_Policy_Sloc /= System_Location then
20833 Partition_Elaboration_Policy_Sloc := Loc;
20842 -- pragma Passive [(PASSIVE_FORM)];
20844 -- PASSIVE_FORM ::= Semaphore | No
20846 when Pragma_Passive =>
20849 if Nkind (Parent (N)) /= N_Task_Definition then
20850 Error_Pragma ("pragma% must be within task definition");
20853 if Arg_Count /= 0 then
20854 Check_Arg_Count (1);
20855 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20858 ----------------------------------
20859 -- Preelaborable_Initialization --
20860 ----------------------------------
20862 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20864 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20869 Check_Arg_Count (1);
20870 Check_No_Identifiers;
20871 Check_Arg_Is_Identifier (Arg1);
20872 Check_Arg_Is_Local_Name (Arg1);
20873 Check_First_Subtype (Arg1);
20874 Ent := Entity (Get_Pragma_Arg (Arg1));
20876 -- A pragma that applies to a Ghost entity becomes Ghost for the
20877 -- purposes of legality checks and removal of ignored Ghost code.
20879 Mark_Ghost_Pragma (N, Ent);
20881 -- The pragma may come from an aspect on a private declaration,
20882 -- even if the freeze point at which this is analyzed in the
20883 -- private part after the full view.
20885 if Has_Private_Declaration (Ent)
20886 and then From_Aspect_Specification (N)
20890 -- Check appropriate type argument
20892 elsif Is_Private_Type (Ent)
20893 or else Is_Protected_Type (Ent)
20894 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20896 -- AI05-0028: The pragma applies to all composite types. Note
20897 -- that we apply this binding interpretation to earlier versions
20898 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20899 -- choice since there are other compilers that do the same.
20901 or else Is_Composite_Type (Ent)
20907 ("pragma % can only be applied to private, formal derived, "
20908 & "protected, or composite type", Arg1);
20911 -- Give an error if the pragma is applied to a protected type that
20912 -- does not qualify (due to having entries, or due to components
20913 -- that do not qualify).
20915 if Is_Protected_Type (Ent)
20916 and then not Has_Preelaborable_Initialization (Ent)
20919 ("protected type & does not have preelaborable "
20920 & "initialization", Ent);
20922 -- Otherwise mark the type as definitely having preelaborable
20926 Set_Known_To_Have_Preelab_Init (Ent);
20929 if Has_Pragma_Preelab_Init (Ent)
20930 and then Warn_On_Redundant_Constructs
20932 Error_Pragma ("?r?duplicate pragma%!");
20934 Set_Has_Pragma_Preelab_Init (Ent);
20938 --------------------
20939 -- Persistent_BSS --
20940 --------------------
20942 -- pragma Persistent_BSS [(object_NAME)];
20944 when Pragma_Persistent_BSS => Persistent_BSS : declare
20951 Check_At_Most_N_Arguments (1);
20953 -- Case of application to specific object (one argument)
20955 if Arg_Count = 1 then
20956 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20958 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20960 Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
20961 E_Variable | E_Constant
20963 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20966 Ent := Entity (Get_Pragma_Arg (Arg1));
20968 -- A pragma that applies to a Ghost entity becomes Ghost for
20969 -- the purposes of legality checks and removal of ignored Ghost
20972 Mark_Ghost_Pragma (N, Ent);
20974 -- Check for duplication before inserting in list of
20975 -- representation items.
20977 Check_Duplicate_Pragma (Ent);
20979 if Rep_Item_Too_Late (Ent, N) then
20983 Decl := Parent (Ent);
20985 if Present (Expression (Decl)) then
20986 -- Variables in Persistent_BSS cannot be initialized, so
20987 -- turn off any initialization that might be caused by
20988 -- pragmas Initialize_Scalars or Normalize_Scalars.
20990 if Kill_Range_Check (Expression (Decl)) then
20993 Name_Suppress_Initialization,
20994 Pragma_Argument_Associations => New_List (
20995 Make_Pragma_Argument_Association (Loc,
20996 Expression => New_Occurrence_Of (Ent, Loc))));
20997 Insert_Before (N, Prag);
21002 ("object for pragma% cannot have initialization", Arg1);
21006 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
21008 ("object type for pragma% is not potentially persistent",
21013 Make_Linker_Section_Pragma
21014 (Ent, Loc, ".persistent.bss");
21015 Insert_After (N, Prag);
21018 -- Case of use as configuration pragma with no arguments
21021 Check_Valid_Configuration_Pragma;
21022 Persistent_BSS_Mode := True;
21024 end Persistent_BSS;
21026 --------------------
21027 -- Rename_Pragma --
21028 --------------------
21030 -- pragma Rename_Pragma (
21031 -- [New_Name =>] IDENTIFIER,
21032 -- [Renamed =>] pragma_IDENTIFIER);
21034 when Pragma_Rename_Pragma => Rename_Pragma : declare
21035 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21036 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21040 Check_Valid_Configuration_Pragma;
21041 Check_Arg_Count (2);
21042 Check_Optional_Identifier (Arg1, Name_New_Name);
21043 Check_Optional_Identifier (Arg2, Name_Renamed);
21045 if Nkind (New_Name) /= N_Identifier then
21046 Error_Pragma_Arg ("identifier expected", Arg1);
21049 if Nkind (Old_Name) /= N_Identifier then
21050 Error_Pragma_Arg ("identifier expected", Arg2);
21053 -- The New_Name arg should not be an existing pragma (but we allow
21054 -- it; it's just a warning). The Old_Name arg must be an existing
21057 if Is_Pragma_Name (Chars (New_Name)) then
21058 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21061 if not Is_Pragma_Name (Chars (Old_Name)) then
21062 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21065 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21068 -----------------------------------
21069 -- Post/Post_Class/Postcondition --
21070 -----------------------------------
21072 -- pragma Post (Boolean_EXPRESSION);
21073 -- pragma Post_Class (Boolean_EXPRESSION);
21074 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21075 -- [,[Message =>] String_EXPRESSION]);
21077 -- Characteristics:
21079 -- * Analysis - The annotation undergoes initial checks to verify
21080 -- the legal placement and context. Secondary checks preanalyze the
21083 -- Analyze_Pre_Post_Condition_In_Decl_Part
21085 -- * Expansion - The annotation is expanded during the expansion of
21086 -- the related subprogram [body] contract as performed in:
21088 -- Expand_Subprogram_Contract
21090 -- * Template - The annotation utilizes the generic template of the
21091 -- related subprogram [body] when it is:
21093 -- aspect on subprogram declaration
21094 -- aspect on stand-alone subprogram body
21095 -- pragma on stand-alone subprogram body
21097 -- The annotation must prepare its own template when it is:
21099 -- pragma on subprogram declaration
21101 -- * Globals - Capture of global references must occur after full
21104 -- * Instance - The annotation is instantiated automatically when
21105 -- the related generic subprogram [body] is instantiated except for
21106 -- the "pragma on subprogram declaration" case. In that scenario
21107 -- the annotation must instantiate itself.
21110 | Pragma_Post_Class
21111 | Pragma_Postcondition
21113 Analyze_Pre_Post_Condition;
21115 --------------------------------
21116 -- Pre/Pre_Class/Precondition --
21117 --------------------------------
21119 -- pragma Pre (Boolean_EXPRESSION);
21120 -- pragma Pre_Class (Boolean_EXPRESSION);
21121 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21122 -- [,[Message =>] String_EXPRESSION]);
21124 -- Characteristics:
21126 -- * Analysis - The annotation undergoes initial checks to verify
21127 -- the legal placement and context. Secondary checks preanalyze the
21130 -- Analyze_Pre_Post_Condition_In_Decl_Part
21132 -- * Expansion - The annotation is expanded during the expansion of
21133 -- the related subprogram [body] contract as performed in:
21135 -- Expand_Subprogram_Contract
21137 -- * Template - The annotation utilizes the generic template of the
21138 -- related subprogram [body] when it is:
21140 -- aspect on subprogram declaration
21141 -- aspect on stand-alone subprogram body
21142 -- pragma on stand-alone subprogram body
21144 -- The annotation must prepare its own template when it is:
21146 -- pragma on subprogram declaration
21148 -- * Globals - Capture of global references must occur after full
21151 -- * Instance - The annotation is instantiated automatically when
21152 -- the related generic subprogram [body] is instantiated except for
21153 -- the "pragma on subprogram declaration" case. In that scenario
21154 -- the annotation must instantiate itself.
21158 | Pragma_Precondition
21160 Analyze_Pre_Post_Condition;
21166 -- pragma Predicate
21167 -- ([Entity =>] type_LOCAL_NAME,
21168 -- [Check =>] boolean_EXPRESSION);
21170 when Pragma_Predicate => Predicate : declare
21177 Check_Arg_Count (2);
21178 Check_Optional_Identifier (Arg1, Name_Entity);
21179 Check_Optional_Identifier (Arg2, Name_Check);
21181 Check_Arg_Is_Local_Name (Arg1);
21183 Type_Id := Get_Pragma_Arg (Arg1);
21184 Find_Type (Type_Id);
21185 Typ := Entity (Type_Id);
21187 if Typ = Any_Type then
21191 -- A pragma that applies to a Ghost entity becomes Ghost for the
21192 -- purposes of legality checks and removal of ignored Ghost code.
21194 Mark_Ghost_Pragma (N, Typ);
21196 -- The remaining processing is simply to link the pragma on to
21197 -- the rep item chain, for processing when the type is frozen.
21198 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21199 -- mark the type as having predicates.
21201 -- If the current policy for predicate checking is Ignore mark the
21202 -- subtype accordingly. In the case of predicates we consider them
21203 -- enabled unless Ignore is specified (either directly or with a
21204 -- general Assertion_Policy pragma) to preserve existing warnings.
21206 Set_Has_Predicates (Typ);
21208 -- Indicate that the pragma must be processed at the point the
21209 -- type is frozen, as is done for the corresponding aspect.
21211 Set_Has_Delayed_Aspects (Typ);
21212 Set_Has_Delayed_Freeze (Typ);
21214 Set_Predicates_Ignored (Typ,
21215 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21216 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21219 -----------------------
21220 -- Predicate_Failure --
21221 -----------------------
21223 -- pragma Predicate_Failure
21224 -- ([Entity =>] type_LOCAL_NAME,
21225 -- [Message =>] string_EXPRESSION);
21227 when Pragma_Predicate_Failure => Predicate_Failure : declare
21234 Check_Arg_Count (2);
21235 Check_Optional_Identifier (Arg1, Name_Entity);
21236 Check_Optional_Identifier (Arg2, Name_Message);
21238 Check_Arg_Is_Local_Name (Arg1);
21240 Type_Id := Get_Pragma_Arg (Arg1);
21241 Find_Type (Type_Id);
21242 Typ := Entity (Type_Id);
21244 if Typ = Any_Type then
21248 -- A pragma that applies to a Ghost entity becomes Ghost for the
21249 -- purposes of legality checks and removal of ignored Ghost code.
21251 Mark_Ghost_Pragma (N, Typ);
21253 -- The remaining processing is simply to link the pragma on to
21254 -- the rep item chain, for processing when the type is frozen.
21255 -- This is accomplished by a call to Rep_Item_Too_Late.
21257 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21258 end Predicate_Failure;
21264 -- pragma Preelaborate [(library_unit_NAME)];
21266 -- Set the flag Is_Preelaborated of program unit name entity
21268 when Pragma_Preelaborate => Preelaborate : declare
21269 Pa : constant Node_Id := Parent (N);
21270 Pk : constant Node_Kind := Nkind (Pa);
21274 Check_Ada_83_Warning;
21275 Check_Valid_Library_Unit_Pragma;
21277 if Nkind (N) = N_Null_Statement then
21281 Ent := Find_Lib_Unit_Name;
21283 -- A pragma that applies to a Ghost entity becomes Ghost for the
21284 -- purposes of legality checks and removal of ignored Ghost code.
21286 Mark_Ghost_Pragma (N, Ent);
21287 Check_Duplicate_Pragma (Ent);
21289 -- This filters out pragmas inside generic parents that show up
21290 -- inside instantiations. Pragmas that come from aspects in the
21291 -- unit are not ignored.
21293 if Present (Ent) then
21294 if Pk = N_Package_Specification
21295 and then Present (Generic_Parent (Pa))
21296 and then not From_Aspect_Specification (N)
21301 if not Debug_Flag_U then
21302 Set_Is_Preelaborated (Ent);
21304 if Legacy_Elaboration_Checks then
21305 Set_Suppress_Elaboration_Warnings (Ent);
21312 -------------------------------
21313 -- Prefix_Exception_Messages --
21314 -------------------------------
21316 -- pragma Prefix_Exception_Messages;
21318 when Pragma_Prefix_Exception_Messages =>
21320 Check_Valid_Configuration_Pragma;
21321 Check_Arg_Count (0);
21322 Prefix_Exception_Messages := True;
21328 -- pragma Priority (EXPRESSION);
21330 when Pragma_Priority => Priority : declare
21331 P : constant Node_Id := Parent (N);
21336 Check_No_Identifiers;
21337 Check_Arg_Count (1);
21341 if Nkind (P) = N_Subprogram_Body then
21342 Check_In_Main_Program;
21344 Ent := Defining_Unit_Name (Specification (P));
21346 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21347 Ent := Defining_Identifier (Ent);
21350 Arg := Get_Pragma_Arg (Arg1);
21351 Analyze_And_Resolve (Arg, Standard_Integer);
21355 if not Is_OK_Static_Expression (Arg) then
21356 Flag_Non_Static_Expr
21357 ("main subprogram priority is not static!", Arg);
21360 -- If constraint error, then we already signalled an error
21362 elsif Raises_Constraint_Error (Arg) then
21365 -- Otherwise check in range except if Relaxed_RM_Semantics
21366 -- where we ignore the value if out of range.
21369 if not Relaxed_RM_Semantics
21370 and then not Is_In_Range (Arg, RTE (RE_Priority))
21373 ("main subprogram priority is out of range", Arg1);
21376 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21380 -- Load an arbitrary entity from System.Tasking.Stages or
21381 -- System.Tasking.Restricted.Stages (depending on the
21382 -- supported profile) to make sure that one of these packages
21383 -- is implicitly with'ed, since we need to have the tasking
21384 -- run time active for the pragma Priority to have any effect.
21385 -- Previously we with'ed the package System.Tasking, but this
21386 -- package does not trigger the required initialization of the
21387 -- run-time library.
21390 Discard : Entity_Id;
21391 pragma Warnings (Off, Discard);
21393 if Restricted_Profile then
21394 Discard := RTE (RE_Activate_Restricted_Tasks);
21396 Discard := RTE (RE_Activate_Tasks);
21400 -- Task or Protected, must be of type Integer
21402 elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
21403 Arg := Get_Pragma_Arg (Arg1);
21404 Ent := Defining_Identifier (Parent (P));
21406 -- The expression must be analyzed in the special manner
21407 -- described in "Handling of Default and Per-Object
21408 -- Expressions" in sem.ads.
21410 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21412 if not Is_OK_Static_Expression (Arg) then
21413 Check_Restriction (Static_Priorities, Arg);
21416 -- Anything else is incorrect
21422 -- Check duplicate pragma before we chain the pragma in the Rep
21423 -- Item chain of Ent.
21425 Check_Duplicate_Pragma (Ent);
21426 Record_Rep_Item (Ent, N);
21429 -----------------------------------
21430 -- Priority_Specific_Dispatching --
21431 -----------------------------------
21433 -- pragma Priority_Specific_Dispatching (
21434 -- policy_IDENTIFIER,
21435 -- first_priority_EXPRESSION,
21436 -- last_priority_EXPRESSION);
21438 when Pragma_Priority_Specific_Dispatching =>
21439 Priority_Specific_Dispatching : declare
21440 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21441 -- This is the entity System.Any_Priority;
21444 Lower_Bound : Node_Id;
21445 Upper_Bound : Node_Id;
21451 Check_Arg_Count (3);
21452 Check_No_Identifiers;
21453 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21454 Check_Valid_Configuration_Pragma;
21455 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21456 DP := Fold_Upper (Name_Buffer (1));
21458 Lower_Bound := Get_Pragma_Arg (Arg2);
21459 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21460 Lower_Val := Expr_Value (Lower_Bound);
21462 Upper_Bound := Get_Pragma_Arg (Arg3);
21463 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21464 Upper_Val := Expr_Value (Upper_Bound);
21466 -- It is not allowed to use Task_Dispatching_Policy and
21467 -- Priority_Specific_Dispatching in the same partition.
21469 if Task_Dispatching_Policy /= ' ' then
21470 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21472 ("pragma% incompatible with Task_Dispatching_Policy#");
21474 -- Check lower bound in range
21476 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21478 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21481 ("first_priority is out of range", Arg2);
21483 -- Check upper bound in range
21485 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21487 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21490 ("last_priority is out of range", Arg3);
21492 -- Check that the priority range is valid
21494 elsif Lower_Val > Upper_Val then
21496 ("last_priority_expression must be greater than or equal to "
21497 & "first_priority_expression");
21499 -- Store the new policy, but always preserve System_Location since
21500 -- we like the error message with the run-time name.
21503 -- Check overlapping in the priority ranges specified in other
21504 -- Priority_Specific_Dispatching pragmas within the same
21505 -- partition. We can only check those we know about.
21508 Specific_Dispatching.First .. Specific_Dispatching.Last
21510 if Specific_Dispatching.Table (J).First_Priority in
21511 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21512 or else Specific_Dispatching.Table (J).Last_Priority in
21513 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21516 Specific_Dispatching.Table (J).Pragma_Loc;
21518 ("priority range overlaps with "
21519 & "Priority_Specific_Dispatching#");
21523 -- The use of Priority_Specific_Dispatching is incompatible
21524 -- with Task_Dispatching_Policy.
21526 if Task_Dispatching_Policy /= ' ' then
21527 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21529 ("Priority_Specific_Dispatching incompatible "
21530 & "with Task_Dispatching_Policy#");
21533 -- The use of Priority_Specific_Dispatching forces ceiling
21536 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21537 Error_Msg_Sloc := Locking_Policy_Sloc;
21539 ("Priority_Specific_Dispatching incompatible "
21540 & "with Locking_Policy#");
21542 -- Set the Ceiling_Locking policy, but preserve System_Location
21543 -- since we like the error message with the run time name.
21546 Locking_Policy := 'C';
21548 if Locking_Policy_Sloc /= System_Location then
21549 Locking_Policy_Sloc := Loc;
21553 -- Add entry in the table
21555 Specific_Dispatching.Append
21556 ((Dispatching_Policy => DP,
21557 First_Priority => UI_To_Int (Lower_Val),
21558 Last_Priority => UI_To_Int (Upper_Val),
21559 Pragma_Loc => Loc));
21561 end Priority_Specific_Dispatching;
21567 -- pragma Profile (profile_IDENTIFIER);
21569 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21571 when Pragma_Profile =>
21573 Check_Arg_Count (1);
21574 Check_Valid_Configuration_Pragma;
21575 Check_No_Identifiers;
21578 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21581 if Chars (Argx) = Name_Ravenscar then
21582 Set_Ravenscar_Profile (Ravenscar, N);
21584 elsif Chars (Argx) = Name_Jorvik then
21585 Set_Ravenscar_Profile (Jorvik, N);
21587 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21588 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21590 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21591 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21593 elsif Chars (Argx) = Name_Restricted then
21594 Set_Profile_Restrictions
21596 N, Warn => Treat_Restrictions_As_Warnings);
21598 elsif Chars (Argx) = Name_Rational then
21599 Set_Rational_Profile;
21601 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21602 Set_Profile_Restrictions
21603 (No_Implementation_Extensions,
21604 N, Warn => Treat_Restrictions_As_Warnings);
21607 Error_Pragma_Arg ("& is not a valid profile", Argx);
21611 ----------------------
21612 -- Profile_Warnings --
21613 ----------------------
21615 -- pragma Profile_Warnings (profile_IDENTIFIER);
21617 -- profile_IDENTIFIER => Restricted | Ravenscar
21619 when Pragma_Profile_Warnings =>
21621 Check_Arg_Count (1);
21622 Check_Valid_Configuration_Pragma;
21623 Check_No_Identifiers;
21626 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21629 if Chars (Argx) = Name_Ravenscar then
21630 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21632 elsif Chars (Argx) = Name_Restricted then
21633 Set_Profile_Restrictions (Restricted, N, Warn => True);
21635 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21636 Set_Profile_Restrictions
21637 (No_Implementation_Extensions, N, Warn => True);
21640 Error_Pragma_Arg ("& is not a valid profile", Argx);
21644 --------------------------
21645 -- Propagate_Exceptions --
21646 --------------------------
21648 -- pragma Propagate_Exceptions;
21650 -- Note: this pragma is obsolete and has no effect
21652 when Pragma_Propagate_Exceptions =>
21654 Check_Arg_Count (0);
21656 if Warn_On_Obsolescent_Feature then
21658 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21659 "and has no effect?j?", N);
21662 -----------------------------
21663 -- Provide_Shift_Operators --
21664 -----------------------------
21666 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21668 when Pragma_Provide_Shift_Operators =>
21669 Provide_Shift_Operators : declare
21672 procedure Declare_Shift_Operator (Nam : Name_Id);
21673 -- Insert declaration and pragma Instrinsic for named shift op
21675 ----------------------------
21676 -- Declare_Shift_Operator --
21677 ----------------------------
21679 procedure Declare_Shift_Operator (Nam : Name_Id) is
21685 Make_Subprogram_Declaration (Loc,
21686 Make_Function_Specification (Loc,
21687 Defining_Unit_Name =>
21688 Make_Defining_Identifier (Loc, Chars => Nam),
21690 Result_Definition =>
21691 Make_Identifier (Loc, Chars => Chars (Ent)),
21693 Parameter_Specifications => New_List (
21694 Make_Parameter_Specification (Loc,
21695 Defining_Identifier =>
21696 Make_Defining_Identifier (Loc, Name_Value),
21698 Make_Identifier (Loc, Chars => Chars (Ent))),
21700 Make_Parameter_Specification (Loc,
21701 Defining_Identifier =>
21702 Make_Defining_Identifier (Loc, Name_Amount),
21704 New_Occurrence_Of (Standard_Natural, Loc)))));
21708 Chars => Name_Import,
21709 Pragma_Argument_Associations => New_List (
21710 Make_Pragma_Argument_Association (Loc,
21711 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21712 Make_Pragma_Argument_Association (Loc,
21713 Expression => Make_Identifier (Loc, Nam))));
21715 Insert_After (N, Import);
21716 Insert_After (N, Func);
21717 end Declare_Shift_Operator;
21719 -- Start of processing for Provide_Shift_Operators
21723 Check_Arg_Count (1);
21724 Check_Arg_Is_Local_Name (Arg1);
21726 Arg1 := Get_Pragma_Arg (Arg1);
21728 -- We must have an entity name
21730 if not Is_Entity_Name (Arg1) then
21732 ("pragma % must apply to integer first subtype", Arg1);
21735 -- If no Entity, means there was a prior error so ignore
21737 if Present (Entity (Arg1)) then
21738 Ent := Entity (Arg1);
21740 -- Apply error checks
21742 if not Is_First_Subtype (Ent) then
21744 ("cannot apply pragma %",
21745 "\& is not a first subtype",
21748 elsif not Is_Integer_Type (Ent) then
21750 ("cannot apply pragma %",
21751 "\& is not an integer type",
21754 elsif Has_Shift_Operator (Ent) then
21756 ("cannot apply pragma %",
21757 "\& already has declared shift operators",
21760 elsif Is_Frozen (Ent) then
21762 ("pragma % appears too late",
21763 "\& is already frozen",
21767 -- Now declare the operators. We do this during analysis rather
21768 -- than expansion, since we want the operators available if we
21769 -- are operating in -gnatc mode.
21771 Declare_Shift_Operator (Name_Rotate_Left);
21772 Declare_Shift_Operator (Name_Rotate_Right);
21773 Declare_Shift_Operator (Name_Shift_Left);
21774 Declare_Shift_Operator (Name_Shift_Right);
21775 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21777 end Provide_Shift_Operators;
21783 -- pragma Psect_Object (
21784 -- [Internal =>] LOCAL_NAME,
21785 -- [, [External =>] EXTERNAL_SYMBOL]
21786 -- [, [Size =>] EXTERNAL_SYMBOL]);
21788 when Pragma_Common_Object
21789 | Pragma_Psect_Object
21791 Psect_Object : declare
21792 Args : Args_List (1 .. 3);
21793 Names : constant Name_List (1 .. 3) := (
21798 Internal : Node_Id renames Args (1);
21799 External : Node_Id renames Args (2);
21800 Size : Node_Id renames Args (3);
21802 Def_Id : Entity_Id;
21804 procedure Check_Arg (Arg : Node_Id);
21805 -- Checks that argument is either a string literal or an
21806 -- identifier, and posts error message if not.
21812 procedure Check_Arg (Arg : Node_Id) is
21814 if Nkind (Original_Node (Arg)) not in
21815 N_String_Literal | N_Identifier
21818 ("inappropriate argument for pragma %", Arg);
21822 -- Start of processing for Common_Object/Psect_Object
21826 Gather_Associations (Names, Args);
21827 Process_Extended_Import_Export_Internal_Arg (Internal);
21829 Def_Id := Entity (Internal);
21831 if Ekind (Def_Id) not in E_Constant | E_Variable then
21833 ("pragma% must designate an object", Internal);
21836 Check_Arg (Internal);
21838 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21840 ("cannot use pragma% for imported/exported object",
21844 if Is_Concurrent_Type (Etype (Internal)) then
21846 ("cannot specify pragma % for task/protected object",
21850 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21852 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21854 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21857 if Ekind (Def_Id) = E_Constant then
21859 ("cannot specify pragma % for a constant", Internal);
21862 if Is_Record_Type (Etype (Internal)) then
21868 Ent := First_Entity (Etype (Internal));
21869 while Present (Ent) loop
21870 Decl := Declaration_Node (Ent);
21872 if Ekind (Ent) = E_Component
21873 and then Nkind (Decl) = N_Component_Declaration
21874 and then Present (Expression (Decl))
21875 and then Warn_On_Export_Import
21878 ("?x?object for pragma % has defaults", Internal);
21888 if Present (Size) then
21892 if Present (External) then
21893 Check_Arg_Is_External_Name (External);
21896 -- If all error tests pass, link pragma on to the rep item chain
21898 Record_Rep_Item (Def_Id, N);
21905 -- pragma Pure [(library_unit_NAME)];
21907 when Pragma_Pure => Pure : declare
21911 Check_Ada_83_Warning;
21913 -- If the pragma comes from a subprogram instantiation, nothing to
21914 -- check, this can happen at any level of nesting.
21916 if Is_Wrapper_Package (Current_Scope) then
21919 Check_Valid_Library_Unit_Pragma;
21922 if Nkind (N) = N_Null_Statement then
21926 Ent := Find_Lib_Unit_Name;
21928 -- A pragma that applies to a Ghost entity becomes Ghost for the
21929 -- purposes of legality checks and removal of ignored Ghost code.
21931 Mark_Ghost_Pragma (N, Ent);
21933 if not Debug_Flag_U then
21935 Set_Has_Pragma_Pure (Ent);
21937 if Legacy_Elaboration_Checks then
21938 Set_Suppress_Elaboration_Warnings (Ent);
21943 -------------------
21944 -- Pure_Function --
21945 -------------------
21947 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21949 when Pragma_Pure_Function => Pure_Function : declare
21950 Def_Id : Entity_Id;
21953 Effective : Boolean := False;
21954 Orig_Def : Entity_Id;
21955 Same_Decl : Boolean := False;
21959 Check_Arg_Count (1);
21960 Check_Optional_Identifier (Arg1, Name_Entity);
21961 Check_Arg_Is_Local_Name (Arg1);
21962 E_Id := Get_Pragma_Arg (Arg1);
21964 if Etype (E_Id) = Any_Type then
21968 -- Loop through homonyms (overloadings) of referenced entity
21970 E := Entity (E_Id);
21972 -- A pragma that applies to a Ghost entity becomes Ghost for the
21973 -- purposes of legality checks and removal of ignored Ghost code.
21975 Mark_Ghost_Pragma (N, E);
21977 if Present (E) then
21979 Def_Id := Get_Base_Subprogram (E);
21981 if Ekind (Def_Id) not in
21982 E_Function | E_Generic_Function | E_Operator
21985 ("pragma% requires a function name", Arg1);
21988 -- When we have a generic function we must jump up a level
21989 -- to the declaration of the wrapper package itself.
21991 Orig_Def := Def_Id;
21993 if Is_Generic_Instance (Def_Id) then
21994 while Nkind (Orig_Def) /= N_Package_Declaration loop
21995 Orig_Def := Parent (Orig_Def);
21999 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
22001 Set_Is_Pure (Def_Id);
22003 if not Has_Pragma_Pure_Function (Def_Id) then
22004 Set_Has_Pragma_Pure_Function (Def_Id);
22009 exit when From_Aspect_Specification (N);
22011 exit when No (E) or else Scope (E) /= Current_Scope;
22015 and then Warn_On_Redundant_Constructs
22018 ("pragma Pure_Function on& is redundant?r?",
22021 elsif not Same_Decl then
22023 ("pragma% argument must be in same declarative part",
22029 --------------------
22030 -- Queuing_Policy --
22031 --------------------
22033 -- pragma Queuing_Policy (policy_IDENTIFIER);
22035 when Pragma_Queuing_Policy => declare
22039 Check_Ada_83_Warning;
22040 Check_Arg_Count (1);
22041 Check_No_Identifiers;
22042 Check_Arg_Is_Queuing_Policy (Arg1);
22043 Check_Valid_Configuration_Pragma;
22044 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22045 QP := Fold_Upper (Name_Buffer (1));
22047 if Queuing_Policy /= ' '
22048 and then Queuing_Policy /= QP
22050 Error_Msg_Sloc := Queuing_Policy_Sloc;
22051 Error_Pragma ("queuing policy incompatible with policy#");
22053 -- Set new policy, but always preserve System_Location since we
22054 -- like the error message with the run time name.
22057 Queuing_Policy := QP;
22059 if Queuing_Policy_Sloc /= System_Location then
22060 Queuing_Policy_Sloc := Loc;
22069 -- pragma Rational, for compatibility with foreign compiler
22071 when Pragma_Rational =>
22072 Set_Rational_Profile;
22074 ---------------------
22075 -- Refined_Depends --
22076 ---------------------
22078 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22080 -- DEPENDENCY_RELATION ::=
22082 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22084 -- DEPENDENCY_CLAUSE ::=
22085 -- OUTPUT_LIST =>[+] INPUT_LIST
22086 -- | NULL_DEPENDENCY_CLAUSE
22088 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22090 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22092 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22094 -- OUTPUT ::= NAME | FUNCTION_RESULT
22097 -- where FUNCTION_RESULT is a function Result attribute_reference
22099 -- Characteristics:
22101 -- * Analysis - The annotation undergoes initial checks to verify
22102 -- the legal placement and context. Secondary checks fully analyze
22103 -- the dependency clauses/global list in:
22105 -- Analyze_Refined_Depends_In_Decl_Part
22107 -- * Expansion - None.
22109 -- * Template - The annotation utilizes the generic template of the
22110 -- related subprogram body.
22112 -- * Globals - Capture of global references must occur after full
22115 -- * Instance - The annotation is instantiated automatically when
22116 -- the related generic subprogram body is instantiated.
22118 when Pragma_Refined_Depends => Refined_Depends : declare
22119 Body_Id : Entity_Id;
22121 Spec_Id : Entity_Id;
22124 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22128 -- Chain the pragma on the contract for further processing by
22129 -- Analyze_Refined_Depends_In_Decl_Part.
22131 Add_Contract_Item (N, Body_Id);
22133 -- The legality checks of pragmas Refined_Depends and
22134 -- Refined_Global are affected by the SPARK mode in effect and
22135 -- the volatility of the context. In addition these two pragmas
22136 -- are subject to an inherent order:
22138 -- 1) Refined_Global
22139 -- 2) Refined_Depends
22141 -- Analyze all these pragmas in the order outlined above
22143 Analyze_If_Present (Pragma_SPARK_Mode);
22144 Analyze_If_Present (Pragma_Volatile_Function);
22145 Analyze_If_Present (Pragma_Refined_Global);
22146 Analyze_Refined_Depends_In_Decl_Part (N);
22148 end Refined_Depends;
22150 --------------------
22151 -- Refined_Global --
22152 --------------------
22154 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22156 -- GLOBAL_SPECIFICATION ::=
22159 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22161 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22163 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22164 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22165 -- GLOBAL_ITEM ::= NAME
22167 -- Characteristics:
22169 -- * Analysis - The annotation undergoes initial checks to verify
22170 -- the legal placement and context. Secondary checks fully analyze
22171 -- the dependency clauses/global list in:
22173 -- Analyze_Refined_Global_In_Decl_Part
22175 -- * Expansion - None.
22177 -- * Template - The annotation utilizes the generic template of the
22178 -- related subprogram body.
22180 -- * Globals - Capture of global references must occur after full
22183 -- * Instance - The annotation is instantiated automatically when
22184 -- the related generic subprogram body is instantiated.
22186 when Pragma_Refined_Global => Refined_Global : declare
22187 Body_Id : Entity_Id;
22189 Spec_Id : Entity_Id;
22192 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22196 -- Chain the pragma on the contract for further processing by
22197 -- Analyze_Refined_Global_In_Decl_Part.
22199 Add_Contract_Item (N, Body_Id);
22201 -- The legality checks of pragmas Refined_Depends and
22202 -- Refined_Global are affected by the SPARK mode in effect and
22203 -- the volatility of the context. In addition these two pragmas
22204 -- are subject to an inherent order:
22206 -- 1) Refined_Global
22207 -- 2) Refined_Depends
22209 -- Analyze all these pragmas in the order outlined above
22211 Analyze_If_Present (Pragma_SPARK_Mode);
22212 Analyze_If_Present (Pragma_Volatile_Function);
22213 Analyze_Refined_Global_In_Decl_Part (N);
22214 Analyze_If_Present (Pragma_Refined_Depends);
22216 end Refined_Global;
22222 -- pragma Refined_Post (boolean_EXPRESSION);
22224 -- Characteristics:
22226 -- * Analysis - The annotation is fully analyzed immediately upon
22227 -- elaboration as it cannot forward reference entities.
22229 -- * Expansion - The annotation is expanded during the expansion of
22230 -- the related subprogram body contract as performed in:
22232 -- Expand_Subprogram_Contract
22234 -- * Template - The annotation utilizes the generic template of the
22235 -- related subprogram body.
22237 -- * Globals - Capture of global references must occur after full
22240 -- * Instance - The annotation is instantiated automatically when
22241 -- the related generic subprogram body is instantiated.
22243 when Pragma_Refined_Post => Refined_Post : declare
22244 Body_Id : Entity_Id;
22246 Spec_Id : Entity_Id;
22249 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22251 -- Fully analyze the pragma when it appears inside a subprogram
22252 -- body because it cannot benefit from forward references.
22256 -- Chain the pragma on the contract for completeness
22258 Add_Contract_Item (N, Body_Id);
22260 -- The legality checks of pragma Refined_Post are affected by
22261 -- the SPARK mode in effect and the volatility of the context.
22262 -- Analyze all pragmas in a specific order.
22264 Analyze_If_Present (Pragma_SPARK_Mode);
22265 Analyze_If_Present (Pragma_Volatile_Function);
22266 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22268 -- Currently it is not possible to inline pre/postconditions on
22269 -- a subprogram subject to pragma Inline_Always.
22271 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22275 -------------------
22276 -- Refined_State --
22277 -------------------
22279 -- pragma Refined_State (REFINEMENT_LIST);
22281 -- REFINEMENT_LIST ::=
22282 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22284 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22286 -- CONSTITUENT_LIST ::=
22289 -- | (CONSTITUENT {, CONSTITUENT})
22291 -- CONSTITUENT ::= object_NAME | state_NAME
22293 -- Characteristics:
22295 -- * Analysis - The annotation undergoes initial checks to verify
22296 -- the legal placement and context. Secondary checks preanalyze the
22297 -- refinement clauses in:
22299 -- Analyze_Refined_State_In_Decl_Part
22301 -- * Expansion - None.
22303 -- * Template - The annotation utilizes the template of the related
22306 -- * Globals - Capture of global references must occur after full
22309 -- * Instance - The annotation is instantiated automatically when
22310 -- the related generic package body is instantiated.
22312 when Pragma_Refined_State => Refined_State : declare
22313 Pack_Decl : Node_Id;
22314 Spec_Id : Entity_Id;
22318 Check_No_Identifiers;
22319 Check_Arg_Count (1);
22321 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22323 if Nkind (Pack_Decl) /= N_Package_Body then
22328 Spec_Id := Corresponding_Spec (Pack_Decl);
22330 -- A pragma that applies to a Ghost entity becomes Ghost for the
22331 -- purposes of legality checks and removal of ignored Ghost code.
22333 Mark_Ghost_Pragma (N, Spec_Id);
22335 -- Chain the pragma on the contract for further processing by
22336 -- Analyze_Refined_State_In_Decl_Part.
22338 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22340 -- The legality checks of pragma Refined_State are affected by the
22341 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22343 Analyze_If_Present (Pragma_SPARK_Mode);
22345 -- State refinement is allowed only when the corresponding package
22346 -- declaration has non-null pragma Abstract_State. Refinement not
22347 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22349 if SPARK_Mode /= Off
22351 (No (Abstract_States (Spec_Id))
22352 or else Has_Null_Abstract_State (Spec_Id))
22355 ("useless refinement, package & does not define abstract "
22356 & "states", N, Spec_Id);
22361 -----------------------
22362 -- Relative_Deadline --
22363 -----------------------
22365 -- pragma Relative_Deadline (time_span_EXPRESSION);
22367 when Pragma_Relative_Deadline => Relative_Deadline : declare
22368 P : constant Node_Id := Parent (N);
22373 Check_No_Identifiers;
22374 Check_Arg_Count (1);
22376 Arg := Get_Pragma_Arg (Arg1);
22378 -- The expression must be analyzed in the special manner described
22379 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22381 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22385 if Nkind (P) = N_Subprogram_Body then
22386 Check_In_Main_Program;
22388 -- Only Task and subprogram cases allowed
22390 elsif Nkind (P) /= N_Task_Definition then
22394 -- Check duplicate pragma before we set the corresponding flag
22396 if Has_Relative_Deadline_Pragma (P) then
22397 Error_Pragma ("duplicate pragma% not allowed");
22400 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22401 -- Relative_Deadline pragma node cannot be inserted in the Rep
22402 -- Item chain of Ent since it is rewritten by the expander as a
22403 -- procedure call statement that will break the chain.
22405 Set_Has_Relative_Deadline_Pragma (P);
22406 end Relative_Deadline;
22408 ------------------------
22409 -- Remote_Access_Type --
22410 ------------------------
22412 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22414 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22419 Check_Arg_Count (1);
22420 Check_Optional_Identifier (Arg1, Name_Entity);
22421 Check_Arg_Is_Local_Name (Arg1);
22423 E := Entity (Get_Pragma_Arg (Arg1));
22425 -- A pragma that applies to a Ghost entity becomes Ghost for the
22426 -- purposes of legality checks and removal of ignored Ghost code.
22428 Mark_Ghost_Pragma (N, E);
22430 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22431 and then Ekind (E) = E_General_Access_Type
22432 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22433 and then Scope (Root_Type (Directly_Designated_Type (E)))
22435 and then Is_Valid_Remote_Object_Type
22436 (Root_Type (Directly_Designated_Type (E)))
22438 Set_Is_Remote_Types (E);
22442 ("pragma% applies only to formal access-to-class-wide types",
22445 end Remote_Access_Type;
22447 ---------------------------
22448 -- Remote_Call_Interface --
22449 ---------------------------
22451 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22453 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22454 Cunit_Node : Node_Id;
22455 Cunit_Ent : Entity_Id;
22459 Check_Ada_83_Warning;
22460 Check_Valid_Library_Unit_Pragma;
22462 if Nkind (N) = N_Null_Statement then
22466 Cunit_Node := Cunit (Current_Sem_Unit);
22467 K := Nkind (Unit (Cunit_Node));
22468 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22470 -- A pragma that applies to a Ghost entity becomes Ghost for the
22471 -- purposes of legality checks and removal of ignored Ghost code.
22473 Mark_Ghost_Pragma (N, Cunit_Ent);
22475 if K = N_Package_Declaration
22476 or else K = N_Generic_Package_Declaration
22477 or else K = N_Subprogram_Declaration
22478 or else K = N_Generic_Subprogram_Declaration
22479 or else (K = N_Subprogram_Body
22480 and then Acts_As_Spec (Unit (Cunit_Node)))
22485 "pragma% must apply to package or subprogram declaration");
22488 Set_Is_Remote_Call_Interface (Cunit_Ent);
22489 end Remote_Call_Interface;
22495 -- pragma Remote_Types [(library_unit_NAME)];
22497 when Pragma_Remote_Types => Remote_Types : declare
22498 Cunit_Node : Node_Id;
22499 Cunit_Ent : Entity_Id;
22502 Check_Ada_83_Warning;
22503 Check_Valid_Library_Unit_Pragma;
22505 if Nkind (N) = N_Null_Statement then
22509 Cunit_Node := Cunit (Current_Sem_Unit);
22510 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22512 -- A pragma that applies to a Ghost entity becomes Ghost for the
22513 -- purposes of legality checks and removal of ignored Ghost code.
22515 Mark_Ghost_Pragma (N, Cunit_Ent);
22517 if Nkind (Unit (Cunit_Node)) not in
22518 N_Package_Declaration | N_Generic_Package_Declaration
22521 ("pragma% can only apply to a package declaration");
22524 Set_Is_Remote_Types (Cunit_Ent);
22531 -- pragma Ravenscar;
22533 when Pragma_Ravenscar =>
22535 Check_Arg_Count (0);
22536 Check_Valid_Configuration_Pragma;
22537 Set_Ravenscar_Profile (Ravenscar, N);
22539 if Warn_On_Obsolescent_Feature then
22541 ("pragma Ravenscar is an obsolescent feature?j?", N);
22543 ("|use pragma Profile (Ravenscar) instead?j?", N);
22546 -------------------------
22547 -- Restricted_Run_Time --
22548 -------------------------
22550 -- pragma Restricted_Run_Time;
22552 when Pragma_Restricted_Run_Time =>
22554 Check_Arg_Count (0);
22555 Check_Valid_Configuration_Pragma;
22556 Set_Profile_Restrictions
22557 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22559 if Warn_On_Obsolescent_Feature then
22561 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22564 ("|use pragma Profile (Restricted) instead?j?", N);
22571 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22574 -- restriction_IDENTIFIER
22575 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22577 when Pragma_Restrictions =>
22578 Process_Restrictions_Or_Restriction_Warnings
22579 (Warn => Treat_Restrictions_As_Warnings);
22581 --------------------------
22582 -- Restriction_Warnings --
22583 --------------------------
22585 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22588 -- restriction_IDENTIFIER
22589 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22591 when Pragma_Restriction_Warnings =>
22593 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22599 -- pragma Reviewable;
22601 when Pragma_Reviewable =>
22602 Check_Ada_83_Warning;
22603 Check_Arg_Count (0);
22605 -- Call dummy debugging function rv. This is done to assist front
22606 -- end debugging. By placing a Reviewable pragma in the source
22607 -- program, a breakpoint on rv catches this place in the source,
22608 -- allowing convenient stepping to the point of interest.
22612 --------------------------
22613 -- Secondary_Stack_Size --
22614 --------------------------
22616 -- pragma Secondary_Stack_Size (EXPRESSION);
22618 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22619 P : constant Node_Id := Parent (N);
22625 Check_No_Identifiers;
22626 Check_Arg_Count (1);
22628 if Nkind (P) = N_Task_Definition then
22629 Arg := Get_Pragma_Arg (Arg1);
22630 Ent := Defining_Identifier (Parent (P));
22632 -- The expression must be analyzed in the special manner
22633 -- described in "Handling of Default Expressions" in sem.ads.
22635 Preanalyze_Spec_Expression (Arg, Any_Integer);
22637 -- The pragma cannot appear if the No_Secondary_Stack
22638 -- restriction is in effect.
22640 Check_Restriction (No_Secondary_Stack, Arg);
22642 -- Anything else is incorrect
22648 -- Check duplicate pragma before we chain the pragma in the Rep
22649 -- Item chain of Ent.
22651 Check_Duplicate_Pragma (Ent);
22652 Record_Rep_Item (Ent, N);
22653 end Secondary_Stack_Size;
22655 --------------------------
22656 -- Short_Circuit_And_Or --
22657 --------------------------
22659 -- pragma Short_Circuit_And_Or;
22661 when Pragma_Short_Circuit_And_Or =>
22663 Check_Arg_Count (0);
22664 Check_Valid_Configuration_Pragma;
22665 Short_Circuit_And_Or := True;
22667 -------------------
22668 -- Share_Generic --
22669 -------------------
22671 -- pragma Share_Generic (GNAME {, GNAME});
22673 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22675 when Pragma_Share_Generic =>
22677 Process_Generic_List;
22683 -- pragma Shared (LOCAL_NAME);
22685 when Pragma_Shared =>
22687 Process_Atomic_Independent_Shared_Volatile;
22689 --------------------
22690 -- Shared_Passive --
22691 --------------------
22693 -- pragma Shared_Passive [(library_unit_NAME)];
22695 -- Set the flag Is_Shared_Passive of program unit name entity
22697 when Pragma_Shared_Passive => Shared_Passive : declare
22698 Cunit_Node : Node_Id;
22699 Cunit_Ent : Entity_Id;
22702 Check_Ada_83_Warning;
22703 Check_Valid_Library_Unit_Pragma;
22705 if Nkind (N) = N_Null_Statement then
22709 Cunit_Node := Cunit (Current_Sem_Unit);
22710 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22712 -- A pragma that applies to a Ghost entity becomes Ghost for the
22713 -- purposes of legality checks and removal of ignored Ghost code.
22715 Mark_Ghost_Pragma (N, Cunit_Ent);
22717 if Nkind (Unit (Cunit_Node)) not in
22718 N_Package_Declaration | N_Generic_Package_Declaration
22721 ("pragma% can only apply to a package declaration");
22724 Set_Is_Shared_Passive (Cunit_Ent);
22725 end Shared_Passive;
22727 -----------------------
22728 -- Short_Descriptors --
22729 -----------------------
22731 -- pragma Short_Descriptors;
22733 -- Recognize and validate, but otherwise ignore
22735 when Pragma_Short_Descriptors =>
22737 Check_Arg_Count (0);
22738 Check_Valid_Configuration_Pragma;
22740 ------------------------------
22741 -- Simple_Storage_Pool_Type --
22742 ------------------------------
22744 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22746 when Pragma_Simple_Storage_Pool_Type =>
22747 Simple_Storage_Pool_Type : declare
22753 Check_Arg_Count (1);
22754 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22756 Type_Id := Get_Pragma_Arg (Arg1);
22757 Find_Type (Type_Id);
22758 Typ := Entity (Type_Id);
22760 if Typ = Any_Type then
22764 -- A pragma that applies to a Ghost entity becomes Ghost for the
22765 -- purposes of legality checks and removal of ignored Ghost code.
22767 Mark_Ghost_Pragma (N, Typ);
22769 -- We require the pragma to apply to a type declared in a package
22770 -- declaration, but not (immediately) within a package body.
22772 if Ekind (Current_Scope) /= E_Package
22773 or else In_Package_Body (Current_Scope)
22776 ("pragma% can only apply to type declared immediately "
22777 & "within a package declaration");
22780 -- A simple storage pool type must be an immutably limited record
22781 -- or private type. If the pragma is given for a private type,
22782 -- the full type is similarly restricted (which is checked later
22783 -- in Freeze_Entity).
22785 if Is_Record_Type (Typ)
22786 and then not Is_Limited_View (Typ)
22789 ("pragma% can only apply to explicitly limited record type");
22791 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22793 ("pragma% can only apply to a private type that is limited");
22795 elsif not Is_Record_Type (Typ)
22796 and then not Is_Private_Type (Typ)
22799 ("pragma% can only apply to limited record or private type");
22802 Record_Rep_Item (Typ, N);
22803 end Simple_Storage_Pool_Type;
22805 ----------------------
22806 -- Source_File_Name --
22807 ----------------------
22809 -- There are five forms for this pragma:
22811 -- pragma Source_File_Name (
22812 -- [UNIT_NAME =>] unit_NAME,
22813 -- BODY_FILE_NAME => STRING_LITERAL
22814 -- [, [INDEX =>] INTEGER_LITERAL]);
22816 -- pragma Source_File_Name (
22817 -- [UNIT_NAME =>] unit_NAME,
22818 -- SPEC_FILE_NAME => STRING_LITERAL
22819 -- [, [INDEX =>] INTEGER_LITERAL]);
22821 -- pragma Source_File_Name (
22822 -- BODY_FILE_NAME => STRING_LITERAL
22823 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22824 -- [, CASING => CASING_SPEC]);
22826 -- pragma Source_File_Name (
22827 -- SPEC_FILE_NAME => STRING_LITERAL
22828 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22829 -- [, CASING => CASING_SPEC]);
22831 -- pragma Source_File_Name (
22832 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22833 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22834 -- [, CASING => CASING_SPEC]);
22836 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22838 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22839 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22840 -- only be used when no project file is used, while SFNP can only be
22841 -- used when a project file is used.
22843 -- No processing here. Processing was completed during parsing, since
22844 -- we need to have file names set as early as possible. Units are
22845 -- loaded well before semantic processing starts.
22847 -- The only processing we defer to this point is the check for
22848 -- correct placement.
22850 when Pragma_Source_File_Name =>
22852 Check_Valid_Configuration_Pragma;
22854 ------------------------------
22855 -- Source_File_Name_Project --
22856 ------------------------------
22858 -- See Source_File_Name for syntax
22860 -- No processing here. Processing was completed during parsing, since
22861 -- we need to have file names set as early as possible. Units are
22862 -- loaded well before semantic processing starts.
22864 -- The only processing we defer to this point is the check for
22865 -- correct placement.
22867 when Pragma_Source_File_Name_Project =>
22869 Check_Valid_Configuration_Pragma;
22871 -- Check that a pragma Source_File_Name_Project is used only in a
22872 -- configuration pragmas file.
22874 -- Pragmas Source_File_Name_Project should only be generated by
22875 -- the Project Manager in configuration pragmas files.
22877 -- This is really an ugly test. It seems to depend on some
22878 -- accidental and undocumented property. At the very least it
22879 -- needs to be documented, but it would be better to have a
22880 -- clean way of testing if we are in a configuration file???
22882 if Present (Parent (N)) then
22884 ("pragma% can only appear in a configuration pragmas file");
22887 ----------------------
22888 -- Source_Reference --
22889 ----------------------
22891 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22893 -- Nothing to do, all processing completed in Par.Prag, since we need
22894 -- the information for possible parser messages that are output.
22896 when Pragma_Source_Reference =>
22903 -- pragma SPARK_Mode [(On | Off)];
22905 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22906 Mode_Id : SPARK_Mode_Type;
22908 procedure Check_Pragma_Conformance
22909 (Context_Pragma : Node_Id;
22910 Entity : Entity_Id;
22911 Entity_Pragma : Node_Id);
22912 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22913 -- conformance of pragma N depending the following scenarios:
22915 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22916 -- compatible with the pragma Context_Pragma that was inherited
22917 -- from the context:
22918 -- * If the mode of Context_Pragma is ON, then the new mode can
22920 -- * If the mode of Context_Pragma is OFF, then the only allowed
22921 -- new mode is also OFF. Emit error if this is not the case.
22923 -- If Entity is not Empty, verify that pragma N is compatible with
22924 -- pragma Entity_Pragma that belongs to Entity.
22925 -- * If Entity_Pragma is Empty, always issue an error as this
22926 -- corresponds to the case where a previous section of Entity
22927 -- has no SPARK_Mode set.
22928 -- * If the mode of Entity_Pragma is ON, then the new mode can
22930 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22931 -- new mode is also OFF. Emit error if this is not the case.
22933 procedure Check_Library_Level_Entity (E : Entity_Id);
22934 -- Subsidiary to routines Process_xxx. Verify that the related
22935 -- entity E subject to pragma SPARK_Mode is library-level.
22937 procedure Process_Body (Decl : Node_Id);
22938 -- Verify the legality of pragma SPARK_Mode when it appears as the
22939 -- top of the body declarations of entry, package, protected unit,
22940 -- subprogram or task unit body denoted by Decl.
22942 procedure Process_Overloadable (Decl : Node_Id);
22943 -- Verify the legality of pragma SPARK_Mode when it applies to an
22944 -- entry or [generic] subprogram declaration denoted by Decl.
22946 procedure Process_Private_Part (Decl : Node_Id);
22947 -- Verify the legality of pragma SPARK_Mode when it appears at the
22948 -- top of the private declarations of a package spec, protected or
22949 -- task unit declaration denoted by Decl.
22951 procedure Process_Statement_Part (Decl : Node_Id);
22952 -- Verify the legality of pragma SPARK_Mode when it appears at the
22953 -- top of the statement sequence of a package body denoted by node
22956 procedure Process_Visible_Part (Decl : Node_Id);
22957 -- Verify the legality of pragma SPARK_Mode when it appears at the
22958 -- top of the visible declarations of a package spec, protected or
22959 -- task unit declaration denoted by Decl. The routine is also used
22960 -- on protected or task units declared without a definition.
22962 procedure Set_SPARK_Context;
22963 -- Subsidiary to routines Process_xxx. Set the global variables
22964 -- which represent the mode of the context from pragma N. Ensure
22965 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22967 ------------------------------
22968 -- Check_Pragma_Conformance --
22969 ------------------------------
22971 procedure Check_Pragma_Conformance
22972 (Context_Pragma : Node_Id;
22973 Entity : Entity_Id;
22974 Entity_Pragma : Node_Id)
22976 Err_Id : Entity_Id;
22980 -- The current pragma may appear without an argument. If this
22981 -- is the case, associate all error messages with the pragma
22984 if Present (Arg1) then
22990 -- The mode of the current pragma is compared against that of
22991 -- an enclosing context.
22993 if Present (Context_Pragma) then
22994 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22996 -- Issue an error if the new mode is less restrictive than
22997 -- that of the context.
22999 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
23000 and then Get_SPARK_Mode_From_Annotation (N) = On
23003 ("cannot change SPARK_Mode from Off to On", Err_N);
23004 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
23005 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
23010 -- The mode of the current pragma is compared against that of
23011 -- an initial package, protected type, subprogram or task type
23014 if Present (Entity) then
23016 -- A simple protected or task type is transformed into an
23017 -- anonymous type whose name cannot be used to issue error
23018 -- messages. Recover the original entity of the type.
23020 if Ekind (Entity) in E_Protected_Type | E_Task_Type then
23023 (Original_Node (Unit_Declaration_Node (Entity)));
23028 -- Both the initial declaration and the completion carry
23029 -- SPARK_Mode pragmas.
23031 if Present (Entity_Pragma) then
23032 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23034 -- Issue an error if the new mode is less restrictive
23035 -- than that of the initial declaration.
23037 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23038 and then Get_SPARK_Mode_From_Annotation (N) = On
23040 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23041 Error_Msg_Sloc := Sloc (Entity_Pragma);
23043 ("\value Off was set for SPARK_Mode on&#",
23048 -- Otherwise the initial declaration lacks a SPARK_Mode
23049 -- pragma in which case the current pragma is illegal as
23050 -- it cannot "complete".
23052 elsif Get_SPARK_Mode_From_Annotation (N) = Off
23053 and then (Is_Generic_Unit (Entity) or else In_Instance)
23058 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23059 Error_Msg_Sloc := Sloc (Err_Id);
23061 ("\no value was set for SPARK_Mode on&#",
23066 end Check_Pragma_Conformance;
23068 --------------------------------
23069 -- Check_Library_Level_Entity --
23070 --------------------------------
23072 procedure Check_Library_Level_Entity (E : Entity_Id) is
23073 procedure Add_Entity_To_Name_Buffer;
23074 -- Add the E_Kind of entity E to the name buffer
23076 -------------------------------
23077 -- Add_Entity_To_Name_Buffer --
23078 -------------------------------
23080 procedure Add_Entity_To_Name_Buffer is
23082 if Ekind (E) in E_Entry | E_Entry_Family then
23083 Add_Str_To_Name_Buffer ("entry");
23085 elsif Ekind (E) in E_Generic_Package
23089 Add_Str_To_Name_Buffer ("package");
23091 elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
23092 Add_Str_To_Name_Buffer ("protected type");
23094 elsif Ekind (E) in E_Function
23095 | E_Generic_Function
23096 | E_Generic_Procedure
23098 | E_Subprogram_Body
23100 Add_Str_To_Name_Buffer ("subprogram");
23103 pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
23104 Add_Str_To_Name_Buffer ("task type");
23106 end Add_Entity_To_Name_Buffer;
23110 Msg_1 : constant String := "incorrect placement of pragma%";
23113 -- Start of processing for Check_Library_Level_Entity
23116 -- A SPARK_Mode of On shall only apply to library-level
23117 -- entities, except for those in generic instances, which are
23118 -- ignored (even if the entity gets SPARK_Mode pragma attached
23119 -- in the AST, its effect is not taken into account unless the
23120 -- context already provides SPARK_Mode of On in GNATprove).
23122 if Get_SPARK_Mode_From_Annotation (N) = On
23123 and then not Is_Library_Level_Entity (E)
23124 and then Instantiation_Location (Sloc (N)) = No_Location
23126 Error_Msg_Name_1 := Pname;
23127 Error_Msg_N (Fix_Error (Msg_1), N);
23130 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23131 Add_Entity_To_Name_Buffer;
23133 Msg_2 := Name_Find;
23134 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23138 end Check_Library_Level_Entity;
23144 procedure Process_Body (Decl : Node_Id) is
23145 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23146 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23149 -- Ignore pragma when applied to the special body created for
23150 -- inlining, recognized by its internal name _Parent.
23152 if Chars (Body_Id) = Name_uParent then
23156 Check_Library_Level_Entity (Body_Id);
23158 -- For entry bodies, verify the legality against:
23159 -- * The mode of the context
23160 -- * The mode of the spec (if any)
23162 if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
23164 -- A stand-alone subprogram body
23166 if Body_Id = Spec_Id then
23167 Check_Pragma_Conformance
23168 (Context_Pragma => SPARK_Pragma (Body_Id),
23170 Entity_Pragma => Empty);
23172 -- An entry or subprogram body that completes a previous
23176 Check_Pragma_Conformance
23177 (Context_Pragma => SPARK_Pragma (Body_Id),
23179 Entity_Pragma => SPARK_Pragma (Spec_Id));
23183 Set_SPARK_Pragma (Body_Id, N);
23184 Set_SPARK_Pragma_Inherited (Body_Id, False);
23186 -- For package bodies, verify the legality against:
23187 -- * The mode of the context
23188 -- * The mode of the private part
23190 -- This case is separated from protected and task bodies
23191 -- because the statement part of the package body inherits
23192 -- the mode of the body declarations.
23194 elsif Nkind (Decl) = N_Package_Body then
23195 Check_Pragma_Conformance
23196 (Context_Pragma => SPARK_Pragma (Body_Id),
23198 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23201 Set_SPARK_Pragma (Body_Id, N);
23202 Set_SPARK_Pragma_Inherited (Body_Id, False);
23203 Set_SPARK_Aux_Pragma (Body_Id, N);
23204 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23206 -- For protected and task bodies, verify the legality against:
23207 -- * The mode of the context
23208 -- * The mode of the private part
23212 (Nkind (Decl) in N_Protected_Body | N_Task_Body);
23214 Check_Pragma_Conformance
23215 (Context_Pragma => SPARK_Pragma (Body_Id),
23217 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23220 Set_SPARK_Pragma (Body_Id, N);
23221 Set_SPARK_Pragma_Inherited (Body_Id, False);
23225 --------------------------
23226 -- Process_Overloadable --
23227 --------------------------
23229 procedure Process_Overloadable (Decl : Node_Id) is
23230 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23231 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23234 Check_Library_Level_Entity (Spec_Id);
23236 -- Verify the legality against:
23237 -- * The mode of the context
23239 Check_Pragma_Conformance
23240 (Context_Pragma => SPARK_Pragma (Spec_Id),
23242 Entity_Pragma => Empty);
23244 Set_SPARK_Pragma (Spec_Id, N);
23245 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23247 -- When the pragma applies to the anonymous object created for
23248 -- a single task type, decorate the type as well. This scenario
23249 -- arises when the single task type lacks a task definition,
23250 -- therefore there is no issue with respect to a potential
23251 -- pragma SPARK_Mode in the private part.
23253 -- task type Anon_Task_Typ;
23254 -- Obj : Anon_Task_Typ;
23255 -- pragma SPARK_Mode ...;
23257 if Is_Single_Task_Object (Spec_Id) then
23258 Set_SPARK_Pragma (Spec_Typ, N);
23259 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23260 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23261 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23263 end Process_Overloadable;
23265 --------------------------
23266 -- Process_Private_Part --
23267 --------------------------
23269 procedure Process_Private_Part (Decl : Node_Id) is
23270 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23273 Check_Library_Level_Entity (Spec_Id);
23275 -- Verify the legality against:
23276 -- * The mode of the visible declarations
23278 Check_Pragma_Conformance
23279 (Context_Pragma => Empty,
23281 Entity_Pragma => SPARK_Pragma (Spec_Id));
23284 Set_SPARK_Aux_Pragma (Spec_Id, N);
23285 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23286 end Process_Private_Part;
23288 ----------------------------
23289 -- Process_Statement_Part --
23290 ----------------------------
23292 procedure Process_Statement_Part (Decl : Node_Id) is
23293 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23296 Check_Library_Level_Entity (Body_Id);
23298 -- Verify the legality against:
23299 -- * The mode of the body declarations
23301 Check_Pragma_Conformance
23302 (Context_Pragma => Empty,
23304 Entity_Pragma => SPARK_Pragma (Body_Id));
23307 Set_SPARK_Aux_Pragma (Body_Id, N);
23308 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23309 end Process_Statement_Part;
23311 --------------------------
23312 -- Process_Visible_Part --
23313 --------------------------
23315 procedure Process_Visible_Part (Decl : Node_Id) is
23316 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23317 Obj_Id : Entity_Id;
23320 Check_Library_Level_Entity (Spec_Id);
23322 -- Verify the legality against:
23323 -- * The mode of the context
23325 Check_Pragma_Conformance
23326 (Context_Pragma => SPARK_Pragma (Spec_Id),
23328 Entity_Pragma => Empty);
23330 -- A task unit declared without a definition does not set the
23331 -- SPARK_Mode of the context because the task does not have any
23332 -- entries that could inherit the mode.
23334 if Nkind (Decl) not in
23335 N_Single_Task_Declaration | N_Task_Type_Declaration
23340 Set_SPARK_Pragma (Spec_Id, N);
23341 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23342 Set_SPARK_Aux_Pragma (Spec_Id, N);
23343 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23345 -- When the pragma applies to a single protected or task type,
23346 -- decorate the corresponding anonymous object as well.
23348 -- protected Anon_Prot_Typ is
23349 -- pragma SPARK_Mode ...;
23351 -- end Anon_Prot_Typ;
23353 -- Obj : Anon_Prot_Typ;
23355 if Is_Single_Concurrent_Type (Spec_Id) then
23356 Obj_Id := Anonymous_Object (Spec_Id);
23358 Set_SPARK_Pragma (Obj_Id, N);
23359 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23361 end Process_Visible_Part;
23363 -----------------------
23364 -- Set_SPARK_Context --
23365 -----------------------
23367 procedure Set_SPARK_Context is
23369 SPARK_Mode := Mode_Id;
23370 SPARK_Mode_Pragma := N;
23371 end Set_SPARK_Context;
23379 -- Start of processing for Do_SPARK_Mode
23383 Check_No_Identifiers;
23384 Check_At_Most_N_Arguments (1);
23386 -- Check the legality of the mode (no argument = ON)
23388 if Arg_Count = 1 then
23389 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23390 Mode := Chars (Get_Pragma_Arg (Arg1));
23395 Mode_Id := Get_SPARK_Mode_Type (Mode);
23396 Context := Parent (N);
23398 -- When a SPARK_Mode pragma appears inside an instantiation whose
23399 -- enclosing context has SPARK_Mode set to "off", the pragma has
23400 -- no semantic effect.
23402 if Ignore_SPARK_Mode_Pragmas_In_Instance
23403 and then Mode_Id /= Off
23405 Rewrite (N, Make_Null_Statement (Loc));
23410 -- The pragma appears in a configuration file
23412 if No (Context) then
23413 Check_Valid_Configuration_Pragma;
23415 if Present (SPARK_Mode_Pragma) then
23418 Prev => SPARK_Mode_Pragma);
23424 -- The pragma acts as a configuration pragma in a compilation unit
23426 -- pragma SPARK_Mode ...;
23427 -- package Pack is ...;
23429 elsif Nkind (Context) = N_Compilation_Unit
23430 and then List_Containing (N) = Context_Items (Context)
23432 Check_Valid_Configuration_Pragma;
23435 -- Otherwise the placement of the pragma within the tree dictates
23436 -- its associated construct. Inspect the declarative list where
23437 -- the pragma resides to find a potential construct.
23441 while Present (Stmt) loop
23443 -- Skip prior pragmas, but check for duplicates. Note that
23444 -- this also takes care of pragmas generated for aspects.
23446 if Nkind (Stmt) = N_Pragma then
23447 if Pragma_Name (Stmt) = Pname then
23454 -- The pragma applies to an expression function that has
23455 -- already been rewritten into a subprogram declaration.
23457 -- function Expr_Func return ... is (...);
23458 -- pragma SPARK_Mode ...;
23460 elsif Nkind (Stmt) = N_Subprogram_Declaration
23461 and then Nkind (Original_Node (Stmt)) =
23462 N_Expression_Function
23464 Process_Overloadable (Stmt);
23467 -- The pragma applies to the anonymous object created for a
23468 -- single concurrent type.
23470 -- protected type Anon_Prot_Typ ...;
23471 -- Obj : Anon_Prot_Typ;
23472 -- pragma SPARK_Mode ...;
23474 elsif Nkind (Stmt) = N_Object_Declaration
23475 and then Is_Single_Concurrent_Object
23476 (Defining_Entity (Stmt))
23478 Process_Overloadable (Stmt);
23481 -- Skip internally generated code
23483 elsif not Comes_From_Source (Stmt) then
23486 -- The pragma applies to an entry or [generic] subprogram
23490 -- pragma SPARK_Mode ...;
23493 -- procedure Proc ...;
23494 -- pragma SPARK_Mode ...;
23496 elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
23497 | N_Subprogram_Declaration
23498 or else (Nkind (Stmt) = N_Entry_Declaration
23499 and then Is_Protected_Type
23500 (Scope (Defining_Entity (Stmt))))
23502 Process_Overloadable (Stmt);
23505 -- Otherwise the pragma does not apply to a legal construct
23506 -- or it does not appear at the top of a declarative or a
23507 -- statement list. Issue an error and stop the analysis.
23517 -- The pragma applies to a package or a subprogram that acts as
23518 -- a compilation unit.
23520 -- procedure Proc ...;
23521 -- pragma SPARK_Mode ...;
23523 if Nkind (Context) = N_Compilation_Unit_Aux then
23524 Context := Unit (Parent (Context));
23527 -- The pragma appears at the top of entry, package, protected
23528 -- unit, subprogram or task unit body declarations.
23530 -- entry Ent when ... is
23531 -- pragma SPARK_Mode ...;
23533 -- package body Pack is
23534 -- pragma SPARK_Mode ...;
23536 -- procedure Proc ... is
23537 -- pragma SPARK_Mode;
23539 -- protected body Prot is
23540 -- pragma SPARK_Mode ...;
23542 if Nkind (Context) in N_Entry_Body
23545 | N_Subprogram_Body
23548 Process_Body (Context);
23550 -- The pragma appears at the top of the visible or private
23551 -- declaration of a package spec, protected or task unit.
23554 -- pragma SPARK_Mode ...;
23556 -- pragma SPARK_Mode ...;
23558 -- protected [type] Prot is
23559 -- pragma SPARK_Mode ...;
23561 -- pragma SPARK_Mode ...;
23563 elsif Nkind (Context) in N_Package_Specification
23564 | N_Protected_Definition
23565 | N_Task_Definition
23567 if List_Containing (N) = Visible_Declarations (Context) then
23568 Process_Visible_Part (Parent (Context));
23570 Process_Private_Part (Parent (Context));
23573 -- The pragma appears at the top of package body statements
23575 -- package body Pack is
23577 -- pragma SPARK_Mode;
23579 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23580 and then Nkind (Parent (Context)) = N_Package_Body
23582 Process_Statement_Part (Parent (Context));
23584 -- The pragma appeared as an aspect of a [generic] subprogram
23585 -- declaration that acts as a compilation unit.
23588 -- procedure Proc ...;
23589 -- pragma SPARK_Mode ...;
23591 elsif Nkind (Context) in N_Generic_Subprogram_Declaration
23592 | N_Subprogram_Declaration
23594 Process_Overloadable (Context);
23596 -- The pragma does not apply to a legal construct, issue error
23604 --------------------------------
23605 -- Static_Elaboration_Desired --
23606 --------------------------------
23608 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23610 when Pragma_Static_Elaboration_Desired =>
23612 Check_At_Most_N_Arguments (1);
23614 if Is_Compilation_Unit (Current_Scope)
23615 and then Ekind (Current_Scope) = E_Package
23617 Set_Static_Elaboration_Desired (Current_Scope, True);
23619 Error_Pragma ("pragma% must apply to a library-level package");
23626 -- pragma Storage_Size (EXPRESSION);
23628 when Pragma_Storage_Size => Storage_Size : declare
23629 P : constant Node_Id := Parent (N);
23633 Check_No_Identifiers;
23634 Check_Arg_Count (1);
23636 -- The expression must be analyzed in the special manner described
23637 -- in "Handling of Default Expressions" in sem.ads.
23639 Arg := Get_Pragma_Arg (Arg1);
23640 Preanalyze_Spec_Expression (Arg, Any_Integer);
23642 if not Is_OK_Static_Expression (Arg) then
23643 Check_Restriction (Static_Storage_Size, Arg);
23646 if Nkind (P) /= N_Task_Definition then
23651 if Has_Storage_Size_Pragma (P) then
23652 Error_Pragma ("duplicate pragma% not allowed");
23654 Set_Has_Storage_Size_Pragma (P, True);
23657 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23665 -- pragma Storage_Unit (NUMERIC_LITERAL);
23667 -- Only permitted argument is System'Storage_Unit value
23669 when Pragma_Storage_Unit =>
23670 Check_No_Identifiers;
23671 Check_Arg_Count (1);
23672 Check_Arg_Is_Integer_Literal (Arg1);
23674 if Intval (Get_Pragma_Arg (Arg1)) /=
23675 UI_From_Int (Ttypes.System_Storage_Unit)
23677 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23679 ("the only allowed argument for pragma% is ^", Arg1);
23682 --------------------
23683 -- Stream_Convert --
23684 --------------------
23686 -- pragma Stream_Convert (
23687 -- [Entity =>] type_LOCAL_NAME,
23688 -- [Read =>] function_NAME,
23689 -- [Write =>] function NAME);
23691 when Pragma_Stream_Convert => Stream_Convert : declare
23692 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23693 -- Check that the given argument is the name of a local function
23694 -- of one argument that is not overloaded earlier in the current
23695 -- local scope. A check is also made that the argument is a
23696 -- function with one parameter.
23698 --------------------------------------
23699 -- Check_OK_Stream_Convert_Function --
23700 --------------------------------------
23702 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23706 Check_Arg_Is_Local_Name (Arg);
23707 Ent := Entity (Get_Pragma_Arg (Arg));
23709 if Has_Homonym (Ent) then
23711 ("argument for pragma% may not be overloaded", Arg);
23714 if Ekind (Ent) /= E_Function
23715 or else No (First_Formal (Ent))
23716 or else Present (Next_Formal (First_Formal (Ent)))
23719 ("argument for pragma% must be function of one argument",
23721 elsif Is_Abstract_Subprogram (Ent) then
23723 ("argument for pragma% cannot be abstract", Arg);
23725 end Check_OK_Stream_Convert_Function;
23727 -- Start of processing for Stream_Convert
23731 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23732 Check_Arg_Count (3);
23733 Check_Optional_Identifier (Arg1, Name_Entity);
23734 Check_Optional_Identifier (Arg2, Name_Read);
23735 Check_Optional_Identifier (Arg3, Name_Write);
23736 Check_Arg_Is_Local_Name (Arg1);
23737 Check_OK_Stream_Convert_Function (Arg2);
23738 Check_OK_Stream_Convert_Function (Arg3);
23741 Typ : constant Entity_Id :=
23742 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23743 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23744 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23747 Check_First_Subtype (Arg1);
23749 -- Check for too early or too late. Note that we don't enforce
23750 -- the rule about primitive operations in this case, since, as
23751 -- is the case for explicit stream attributes themselves, these
23752 -- restrictions are not appropriate. Note that the chaining of
23753 -- the pragma by Rep_Item_Too_Late is actually the critical
23754 -- processing done for this pragma.
23756 if Rep_Item_Too_Early (Typ, N)
23758 Rep_Item_Too_Late (Typ, N, FOnly => True)
23763 -- Return if previous error
23765 if Etype (Typ) = Any_Type
23767 Etype (Read) = Any_Type
23769 Etype (Write) = Any_Type
23776 if Underlying_Type (Etype (Read)) /= Typ then
23778 ("incorrect return type for function&", Arg2);
23781 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23783 ("incorrect parameter type for function&", Arg3);
23786 if Underlying_Type (Etype (First_Formal (Read))) /=
23787 Underlying_Type (Etype (Write))
23790 ("result type of & does not match Read parameter type",
23794 end Stream_Convert;
23800 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23802 -- This is processed by the parser since some of the style checks
23803 -- take place during source scanning and parsing. This means that
23804 -- we don't need to issue error messages here.
23806 when Pragma_Style_Checks => Style_Checks : declare
23807 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23813 Check_No_Identifiers;
23815 -- Two argument form
23817 if Arg_Count = 2 then
23818 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23825 E_Id := Get_Pragma_Arg (Arg2);
23828 if not Is_Entity_Name (E_Id) then
23830 ("second argument of pragma% must be entity name",
23834 E := Entity (E_Id);
23836 if not Ignore_Style_Checks_Pragmas then
23841 Set_Suppress_Style_Checks
23842 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23843 exit when No (Homonym (E));
23850 -- One argument form
23853 Check_Arg_Count (1);
23855 if Nkind (A) = N_String_Literal then
23859 Slen : constant Natural := Natural (String_Length (S));
23860 Options : String (1 .. Slen);
23866 C := Get_String_Char (S, Pos (J));
23867 exit when not In_Character_Range (C);
23868 Options (J) := Get_Character (C);
23870 -- If at end of string, set options. As per discussion
23871 -- above, no need to check for errors, since we issued
23872 -- them in the parser.
23875 if not Ignore_Style_Checks_Pragmas then
23876 Set_Style_Check_Options (Options);
23886 elsif Nkind (A) = N_Identifier then
23887 if Chars (A) = Name_All_Checks then
23888 if not Ignore_Style_Checks_Pragmas then
23890 Set_GNAT_Style_Check_Options;
23892 Set_Default_Style_Check_Options;
23896 elsif Chars (A) = Name_On then
23897 if not Ignore_Style_Checks_Pragmas then
23898 Style_Check := True;
23901 elsif Chars (A) = Name_Off then
23902 if not Ignore_Style_Checks_Pragmas then
23903 Style_Check := False;
23910 ------------------------
23911 -- Subprogram_Variant --
23912 ------------------------
23914 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM
23915 -- {, SUBPROGRAM_VARIANT_ITEM } );
23917 -- SUBPROGRAM_VARIANT_ITEM ::=
23918 -- CHANGE_DIRECTION => discrete_EXPRESSION
23920 -- CHANGE_DIRECTION ::= Increases | Decreases
23922 -- Characteristics:
23924 -- * Analysis - The annotation undergoes initial checks to verify
23925 -- the legal placement and context. Secondary checks preanalyze the
23928 -- Analyze_Subprogram_Variant_In_Decl_Part
23930 -- * Expansion - The annotation is expanded during the expansion of
23931 -- the related subprogram [body] contract as performed in:
23933 -- Expand_Subprogram_Contract
23935 -- * Template - The annotation utilizes the generic template of the
23936 -- related subprogram [body] when it is:
23938 -- aspect on subprogram declaration
23939 -- aspect on stand-alone subprogram body
23940 -- pragma on stand-alone subprogram body
23942 -- The annotation must prepare its own template when it is:
23944 -- pragma on subprogram declaration
23946 -- * Globals - Capture of global references must occur after full
23949 -- * Instance - The annotation is instantiated automatically when
23950 -- the related generic subprogram [body] is instantiated except for
23951 -- the "pragma on subprogram declaration" case. In that scenario
23952 -- the annotation must instantiate itself.
23954 when Pragma_Subprogram_Variant => Subprogram_Variant : declare
23955 Spec_Id : Entity_Id;
23956 Subp_Decl : Node_Id;
23957 Subp_Spec : Node_Id;
23961 Check_No_Identifiers;
23962 Check_Arg_Count (1);
23964 -- Ensure the proper placement of the pragma. Subprogram_Variant
23965 -- must be associated with a subprogram declaration or a body that
23969 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23971 -- Generic subprogram
23973 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23976 -- Body acts as spec
23978 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23979 and then No (Corresponding_Spec (Subp_Decl))
23983 -- Body stub acts as spec
23985 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23986 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23992 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23993 Subp_Spec := Specification (Subp_Decl);
23995 -- Pragma Subprogram_Variant is forbidden on null procedures,
23996 -- as this may lead to potential ambiguities in behavior when
23997 -- interface null procedures are involved. Also, it just
23998 -- wouldn't make sense, because null procedure is not
24001 if Nkind (Subp_Spec) = N_Procedure_Specification
24002 and then Null_Present (Subp_Spec)
24004 Error_Msg_N (Fix_Error
24005 ("pragma % cannot apply to null procedure"), N);
24014 Spec_Id := Unique_Defining_Entity (Subp_Decl);
24016 -- A pragma that applies to a Ghost entity becomes Ghost for the
24017 -- purposes of legality checks and removal of ignored Ghost code.
24019 Mark_Ghost_Pragma (N, Spec_Id);
24020 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
24022 -- Chain the pragma on the contract for further processing by
24023 -- Analyze_Contract_Cases_In_Decl_Part.
24025 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
24027 -- Fully analyze the pragma when it appears inside a subprogram
24028 -- body because it cannot benefit from forward references.
24030 if Nkind (Subp_Decl) in N_Subprogram_Body
24031 | N_Subprogram_Body_Stub
24033 -- The legality checks of pragma Subprogram_Variant are
24034 -- affected by the SPARK mode in effect and the volatility
24035 -- of the context. Analyze all pragmas in a specific order.
24037 Analyze_If_Present (Pragma_SPARK_Mode);
24038 Analyze_If_Present (Pragma_Volatile_Function);
24039 Analyze_Subprogram_Variant_In_Decl_Part (N);
24041 end Subprogram_Variant;
24047 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24049 when Pragma_Subtitle =>
24051 Check_Arg_Count (1);
24052 Check_Optional_Identifier (Arg1, Name_Subtitle);
24053 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24060 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24062 when Pragma_Suppress =>
24063 Process_Suppress_Unsuppress (Suppress_Case => True);
24069 -- pragma Suppress_All;
24071 -- The only check made here is that the pragma has no arguments.
24072 -- There are no placement rules, and the processing required (setting
24073 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24074 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24075 -- then creates and inserts a pragma Suppress (All_Checks).
24077 when Pragma_Suppress_All =>
24079 Check_Arg_Count (0);
24081 -------------------------
24082 -- Suppress_Debug_Info --
24083 -------------------------
24085 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24087 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24088 Nam_Id : Entity_Id;
24092 Check_Arg_Count (1);
24093 Check_Optional_Identifier (Arg1, Name_Entity);
24094 Check_Arg_Is_Local_Name (Arg1);
24096 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24098 -- A pragma that applies to a Ghost entity becomes Ghost for the
24099 -- purposes of legality checks and removal of ignored Ghost code.
24101 Mark_Ghost_Pragma (N, Nam_Id);
24102 Set_Debug_Info_Off (Nam_Id);
24103 end Suppress_Debug_Info;
24105 ----------------------------------
24106 -- Suppress_Exception_Locations --
24107 ----------------------------------
24109 -- pragma Suppress_Exception_Locations;
24111 when Pragma_Suppress_Exception_Locations =>
24113 Check_Arg_Count (0);
24114 Check_Valid_Configuration_Pragma;
24115 Exception_Locations_Suppressed := True;
24117 -----------------------------
24118 -- Suppress_Initialization --
24119 -----------------------------
24121 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24123 when Pragma_Suppress_Initialization => Suppress_Init : declare
24129 Check_Arg_Count (1);
24130 Check_Optional_Identifier (Arg1, Name_Entity);
24131 Check_Arg_Is_Local_Name (Arg1);
24133 E_Id := Get_Pragma_Arg (Arg1);
24135 if Etype (E_Id) = Any_Type then
24139 E := Entity (E_Id);
24141 -- A pragma that applies to a Ghost entity becomes Ghost for the
24142 -- purposes of legality checks and removal of ignored Ghost code.
24144 Mark_Ghost_Pragma (N, E);
24146 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24148 ("pragma% requires variable, type or subtype", Arg1);
24151 if Rep_Item_Too_Early (E, N)
24153 Rep_Item_Too_Late (E, N, FOnly => True)
24158 -- For incomplete/private type, set flag on full view
24160 if Is_Incomplete_Or_Private_Type (E) then
24161 if No (Full_View (Base_Type (E))) then
24163 ("argument of pragma% cannot be an incomplete type", Arg1);
24165 Set_Suppress_Initialization (Full_View (E));
24168 -- For first subtype, set flag on base type
24170 elsif Is_First_Subtype (E) then
24171 Set_Suppress_Initialization (Base_Type (E));
24173 -- For other than first subtype, set flag on subtype or variable
24176 Set_Suppress_Initialization (E);
24184 -- pragma System_Name (DIRECT_NAME);
24186 -- Syntax check: one argument, which must be the identifier GNAT or
24187 -- the identifier GCC, no other identifiers are acceptable.
24189 when Pragma_System_Name =>
24191 Check_No_Identifiers;
24192 Check_Arg_Count (1);
24193 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24195 -----------------------------
24196 -- Task_Dispatching_Policy --
24197 -----------------------------
24199 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24201 when Pragma_Task_Dispatching_Policy => declare
24205 Check_Ada_83_Warning;
24206 Check_Arg_Count (1);
24207 Check_No_Identifiers;
24208 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24209 Check_Valid_Configuration_Pragma;
24210 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24211 DP := Fold_Upper (Name_Buffer (1));
24213 if Task_Dispatching_Policy /= ' '
24214 and then Task_Dispatching_Policy /= DP
24216 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24218 ("task dispatching policy incompatible with policy#");
24220 -- Set new policy, but always preserve System_Location since we
24221 -- like the error message with the run time name.
24224 Task_Dispatching_Policy := DP;
24226 if Task_Dispatching_Policy_Sloc /= System_Location then
24227 Task_Dispatching_Policy_Sloc := Loc;
24236 -- pragma Task_Info (EXPRESSION);
24238 when Pragma_Task_Info => Task_Info : declare
24239 P : constant Node_Id := Parent (N);
24245 if Warn_On_Obsolescent_Feature then
24247 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24248 & "instead?j?", N);
24251 if Nkind (P) /= N_Task_Definition then
24252 Error_Pragma ("pragma% must appear in task definition");
24255 Check_No_Identifiers;
24256 Check_Arg_Count (1);
24258 Analyze_And_Resolve
24259 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24261 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24265 Ent := Defining_Identifier (Parent (P));
24267 -- Check duplicate pragma before we chain the pragma in the Rep
24268 -- Item chain of Ent.
24271 (Ent, Name_Task_Info, Check_Parents => False)
24273 Error_Pragma ("duplicate pragma% not allowed");
24276 Record_Rep_Item (Ent, N);
24283 -- pragma Task_Name (string_EXPRESSION);
24285 when Pragma_Task_Name => Task_Name : declare
24286 P : constant Node_Id := Parent (N);
24291 Check_No_Identifiers;
24292 Check_Arg_Count (1);
24294 Arg := Get_Pragma_Arg (Arg1);
24296 -- The expression is used in the call to Create_Task, and must be
24297 -- expanded there, not in the context of the current spec. It must
24298 -- however be analyzed to capture global references, in case it
24299 -- appears in a generic context.
24301 Preanalyze_And_Resolve (Arg, Standard_String);
24303 if Nkind (P) /= N_Task_Definition then
24307 Ent := Defining_Identifier (Parent (P));
24309 -- Check duplicate pragma before we chain the pragma in the Rep
24310 -- Item chain of Ent.
24313 (Ent, Name_Task_Name, Check_Parents => False)
24315 Error_Pragma ("duplicate pragma% not allowed");
24318 Record_Rep_Item (Ent, N);
24325 -- pragma Task_Storage (
24326 -- [Task_Type =>] LOCAL_NAME,
24327 -- [Top_Guard =>] static_integer_EXPRESSION);
24329 when Pragma_Task_Storage => Task_Storage : declare
24330 Args : Args_List (1 .. 2);
24331 Names : constant Name_List (1 .. 2) := (
24335 Task_Type : Node_Id renames Args (1);
24336 Top_Guard : Node_Id renames Args (2);
24342 Gather_Associations (Names, Args);
24344 if No (Task_Type) then
24346 ("missing task_type argument for pragma%");
24349 Check_Arg_Is_Local_Name (Task_Type);
24351 Ent := Entity (Task_Type);
24353 if not Is_Task_Type (Ent) then
24355 ("argument for pragma% must be task type", Task_Type);
24358 if No (Top_Guard) then
24360 ("pragma% takes two arguments", Task_Type);
24362 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24365 Check_First_Subtype (Task_Type);
24367 if Rep_Item_Too_Late (Ent, N) then
24376 -- pragma Test_Case
24377 -- ([Name =>] Static_String_EXPRESSION
24378 -- ,[Mode =>] MODE_TYPE
24379 -- [, Requires => Boolean_EXPRESSION]
24380 -- [, Ensures => Boolean_EXPRESSION]);
24382 -- MODE_TYPE ::= Nominal | Robustness
24384 -- Characteristics:
24386 -- * Analysis - The annotation undergoes initial checks to verify
24387 -- the legal placement and context. Secondary checks preanalyze the
24390 -- Analyze_Test_Case_In_Decl_Part
24392 -- * Expansion - None.
24394 -- * Template - The annotation utilizes the generic template of the
24395 -- related subprogram when it is:
24397 -- aspect on subprogram declaration
24399 -- The annotation must prepare its own template when it is:
24401 -- pragma on subprogram declaration
24403 -- * Globals - Capture of global references must occur after full
24406 -- * Instance - The annotation is instantiated automatically when
24407 -- the related generic subprogram is instantiated except for the
24408 -- "pragma on subprogram declaration" case. In that scenario the
24409 -- annotation must instantiate itself.
24411 when Pragma_Test_Case => Test_Case : declare
24412 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24413 -- Ensure that the contract of subprogram Subp_Id does not contain
24414 -- another Test_Case pragma with the same Name as the current one.
24416 -------------------------
24417 -- Check_Distinct_Name --
24418 -------------------------
24420 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24421 Items : constant Node_Id := Contract (Subp_Id);
24422 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24426 -- Inspect all Test_Case pragma of the related subprogram
24427 -- looking for one with a duplicate "Name" argument.
24429 if Present (Items) then
24430 Prag := Contract_Test_Cases (Items);
24431 while Present (Prag) loop
24432 if Pragma_Name (Prag) = Name_Test_Case
24434 and then String_Equal
24435 (Name, Get_Name_From_CTC_Pragma (Prag))
24437 Error_Msg_Sloc := Sloc (Prag);
24438 Error_Pragma ("name for pragma % is already used #");
24441 Prag := Next_Pragma (Prag);
24444 end Check_Distinct_Name;
24448 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24451 Subp_Decl : Node_Id;
24452 Subp_Id : Entity_Id;
24454 -- Start of processing for Test_Case
24458 Check_At_Least_N_Arguments (2);
24459 Check_At_Most_N_Arguments (4);
24461 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24465 Check_Optional_Identifier (Arg1, Name_Name);
24466 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24470 Check_Optional_Identifier (Arg2, Name_Mode);
24471 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24473 -- Arguments "Requires" and "Ensures"
24475 if Present (Arg3) then
24476 if Present (Arg4) then
24477 Check_Identifier (Arg3, Name_Requires);
24478 Check_Identifier (Arg4, Name_Ensures);
24480 Check_Identifier_Is_One_Of
24481 (Arg3, Name_Requires, Name_Ensures);
24485 -- Pragma Test_Case must be associated with a subprogram declared
24486 -- in a library-level package. First determine whether the current
24487 -- compilation unit is a legal context.
24489 if Nkind (Pack_Decl) in N_Package_Declaration
24490 | N_Generic_Package_Declaration
24494 -- Otherwise the placement is illegal
24498 ("pragma % must be specified within a package declaration");
24502 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24504 -- Find the enclosing context
24506 Context := Parent (Subp_Decl);
24508 if Present (Context) then
24509 Context := Parent (Context);
24512 -- Verify the placement of the pragma
24514 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24516 ("pragma % cannot be applied to abstract subprogram");
24519 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24520 Error_Pragma ("pragma % cannot be applied to entry");
24523 -- The context is a [generic] subprogram declared at the top level
24524 -- of the [generic] package unit.
24526 elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
24527 | N_Subprogram_Declaration
24528 and then Present (Context)
24529 and then Nkind (Context) in N_Generic_Package_Declaration
24530 | N_Package_Declaration
24534 -- Otherwise the placement is illegal
24538 ("pragma % must be applied to a library-level subprogram "
24543 Subp_Id := Defining_Entity (Subp_Decl);
24545 -- A pragma that applies to a Ghost entity becomes Ghost for the
24546 -- purposes of legality checks and removal of ignored Ghost code.
24548 Mark_Ghost_Pragma (N, Subp_Id);
24550 -- Chain the pragma on the contract for further processing by
24551 -- Analyze_Test_Case_In_Decl_Part.
24553 Add_Contract_Item (N, Subp_Id);
24555 -- Preanalyze the original aspect argument "Name" for a generic
24556 -- subprogram to properly capture global references.
24558 if Is_Generic_Subprogram (Subp_Id) then
24559 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24561 if Present (Asp_Arg) then
24563 -- The argument appears with an identifier in association
24566 if Nkind (Asp_Arg) = N_Component_Association then
24567 Asp_Arg := Expression (Asp_Arg);
24570 Check_Expr_Is_OK_Static_Expression
24571 (Asp_Arg, Standard_String);
24575 -- Ensure that the all Test_Case pragmas of the related subprogram
24576 -- have distinct names.
24578 Check_Distinct_Name (Subp_Id);
24580 -- Fully analyze the pragma when it appears inside an entry
24581 -- or subprogram body because it cannot benefit from forward
24584 if Nkind (Subp_Decl) in N_Entry_Body
24585 | N_Subprogram_Body
24586 | N_Subprogram_Body_Stub
24588 -- The legality checks of pragma Test_Case are affected by the
24589 -- SPARK mode in effect and the volatility of the context.
24590 -- Analyze all pragmas in a specific order.
24592 Analyze_If_Present (Pragma_SPARK_Mode);
24593 Analyze_If_Present (Pragma_Volatile_Function);
24594 Analyze_Test_Case_In_Decl_Part (N);
24598 --------------------------
24599 -- Thread_Local_Storage --
24600 --------------------------
24602 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24604 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24610 Check_Arg_Count (1);
24611 Check_Optional_Identifier (Arg1, Name_Entity);
24612 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24614 Id := Get_Pragma_Arg (Arg1);
24617 if not Is_Entity_Name (Id)
24618 or else Ekind (Entity (Id)) /= E_Variable
24620 Error_Pragma_Arg ("local variable name required", Arg1);
24625 -- A pragma that applies to a Ghost entity becomes Ghost for the
24626 -- purposes of legality checks and removal of ignored Ghost code.
24628 Mark_Ghost_Pragma (N, E);
24630 if Rep_Item_Too_Early (E, N)
24632 Rep_Item_Too_Late (E, N)
24637 Set_Has_Pragma_Thread_Local_Storage (E);
24638 Set_Has_Gigi_Rep_Item (E);
24639 end Thread_Local_Storage;
24645 -- pragma Time_Slice (static_duration_EXPRESSION);
24647 when Pragma_Time_Slice => Time_Slice : declare
24653 Check_Arg_Count (1);
24654 Check_No_Identifiers;
24655 Check_In_Main_Program;
24656 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24658 if not Error_Posted (Arg1) then
24660 while Present (Nod) loop
24661 if Nkind (Nod) = N_Pragma
24662 and then Pragma_Name (Nod) = Name_Time_Slice
24664 Error_Msg_Name_1 := Pname;
24665 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24672 -- Process only if in main unit
24674 if Get_Source_Unit (Loc) = Main_Unit then
24675 Opt.Time_Slice_Set := True;
24676 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24678 if Val <= Ureal_0 then
24679 Opt.Time_Slice_Value := 0;
24681 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24682 Opt.Time_Slice_Value := 1_000_000_000;
24685 Opt.Time_Slice_Value :=
24686 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24695 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24697 -- TITLING_OPTION ::=
24698 -- [Title =>] STRING_LITERAL
24699 -- | [Subtitle =>] STRING_LITERAL
24701 when Pragma_Title => Title : declare
24702 Args : Args_List (1 .. 2);
24703 Names : constant Name_List (1 .. 2) := (
24709 Gather_Associations (Names, Args);
24712 for J in 1 .. 2 loop
24713 if Present (Args (J)) then
24714 Check_Arg_Is_OK_Static_Expression
24715 (Args (J), Standard_String);
24720 ----------------------------
24721 -- Type_Invariant[_Class] --
24722 ----------------------------
24724 -- pragma Type_Invariant[_Class]
24725 -- ([Entity =>] type_LOCAL_NAME,
24726 -- [Check =>] EXPRESSION);
24728 when Pragma_Type_Invariant
24729 | Pragma_Type_Invariant_Class
24731 Type_Invariant : declare
24732 I_Pragma : Node_Id;
24735 Check_Arg_Count (2);
24737 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24738 -- setting Class_Present for the Type_Invariant_Class case.
24740 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24741 I_Pragma := New_Copy (N);
24742 Set_Pragma_Identifier
24743 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24744 Rewrite (N, I_Pragma);
24745 Set_Analyzed (N, False);
24747 end Type_Invariant;
24749 ---------------------
24750 -- Unchecked_Union --
24751 ---------------------
24753 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24755 when Pragma_Unchecked_Union => Unchecked_Union : declare
24756 Assoc : constant Node_Id := Arg1;
24757 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24767 Check_No_Identifiers;
24768 Check_Arg_Count (1);
24769 Check_Arg_Is_Local_Name (Arg1);
24771 Find_Type (Type_Id);
24773 Typ := Entity (Type_Id);
24775 -- A pragma that applies to a Ghost entity becomes Ghost for the
24776 -- purposes of legality checks and removal of ignored Ghost code.
24778 Mark_Ghost_Pragma (N, Typ);
24781 or else Rep_Item_Too_Early (Typ, N)
24785 Typ := Underlying_Type (Typ);
24788 if Rep_Item_Too_Late (Typ, N) then
24792 Check_First_Subtype (Arg1);
24794 -- Note remaining cases are references to a type in the current
24795 -- declarative part. If we find an error, we post the error on
24796 -- the relevant type declaration at an appropriate point.
24798 if not Is_Record_Type (Typ) then
24799 Error_Msg_N ("unchecked union must be record type", Typ);
24802 elsif Is_Tagged_Type (Typ) then
24803 Error_Msg_N ("unchecked union must not be tagged", Typ);
24806 elsif not Has_Discriminants (Typ) then
24808 ("unchecked union must have one discriminant", Typ);
24811 -- Note: in previous versions of GNAT we used to check for limited
24812 -- types and give an error, but in fact the standard does allow
24813 -- Unchecked_Union on limited types, so this check was removed.
24815 -- Similarly, GNAT used to require that all discriminants have
24816 -- default values, but this is not mandated by the RM.
24818 -- Proceed with basic error checks completed
24821 Tdef := Type_Definition (Declaration_Node (Typ));
24822 Clist := Component_List (Tdef);
24824 -- Check presence of component list and variant part
24826 if No (Clist) or else No (Variant_Part (Clist)) then
24828 ("unchecked union must have variant part", Tdef);
24832 -- Check components
24834 Comp := First_Non_Pragma (Component_Items (Clist));
24835 while Present (Comp) loop
24836 Check_Component (Comp, Typ);
24837 Next_Non_Pragma (Comp);
24840 -- Check variant part
24842 Vpart := Variant_Part (Clist);
24844 Variant := First_Non_Pragma (Variants (Vpart));
24845 while Present (Variant) loop
24846 Check_Variant (Variant, Typ);
24847 Next_Non_Pragma (Variant);
24851 Set_Is_Unchecked_Union (Typ);
24852 Set_Convention (Typ, Convention_C);
24853 Set_Has_Unchecked_Union (Base_Type (Typ));
24854 Set_Is_Unchecked_Union (Base_Type (Typ));
24855 end Unchecked_Union;
24857 ----------------------------
24858 -- Unevaluated_Use_Of_Old --
24859 ----------------------------
24861 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24863 when Pragma_Unevaluated_Use_Of_Old =>
24865 Check_Arg_Count (1);
24866 Check_No_Identifiers;
24867 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24869 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24870 -- a declarative part or a package spec.
24872 if not Is_Configuration_Pragma then
24873 Check_Is_In_Decl_Part_Or_Package_Spec;
24876 -- Store proper setting of Uneval_Old
24878 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24879 Uneval_Old := Fold_Upper (Name_Buffer (1));
24881 ------------------------
24882 -- Unimplemented_Unit --
24883 ------------------------
24885 -- pragma Unimplemented_Unit;
24887 -- Note: this only gives an error if we are generating code, or if
24888 -- we are in a generic library unit (where the pragma appears in the
24889 -- body, not in the spec).
24891 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24892 Cunitent : constant Entity_Id :=
24893 Cunit_Entity (Get_Source_Unit (Loc));
24894 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24898 Check_Arg_Count (0);
24900 if Operating_Mode = Generate_Code
24901 or else Ent_Kind = E_Generic_Function
24902 or else Ent_Kind = E_Generic_Procedure
24903 or else Ent_Kind = E_Generic_Package
24905 Get_Name_String (Chars (Cunitent));
24906 Set_Casing (Mixed_Case);
24907 Write_Str (Name_Buffer (1 .. Name_Len));
24908 Write_Str (" is not supported in this configuration");
24910 raise Unrecoverable_Error;
24912 end Unimplemented_Unit;
24914 ------------------------
24915 -- Universal_Aliasing --
24916 ------------------------
24918 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24920 when Pragma_Universal_Aliasing => Universal_Alias : declare
24926 Check_Arg_Count (1);
24927 Check_Optional_Identifier (Arg2, Name_Entity);
24928 Check_Arg_Is_Local_Name (Arg1);
24929 E_Id := Get_Pragma_Arg (Arg1);
24931 if Etype (E_Id) = Any_Type then
24935 E := Entity (E_Id);
24937 if not Is_Type (E) then
24938 Error_Pragma_Arg ("pragma% requires type", Arg1);
24941 -- A pragma that applies to a Ghost entity becomes Ghost for the
24942 -- purposes of legality checks and removal of ignored Ghost code.
24944 Mark_Ghost_Pragma (N, E);
24945 Set_Universal_Aliasing (Base_Type (E));
24946 Record_Rep_Item (E, N);
24947 end Universal_Alias;
24949 --------------------
24950 -- Universal_Data --
24951 --------------------
24953 -- pragma Universal_Data [(library_unit_NAME)];
24955 when Pragma_Universal_Data =>
24957 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24963 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24965 when Pragma_Unmodified =>
24966 Analyze_Unmodified_Or_Unused;
24972 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24974 -- or when used in a context clause:
24976 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24978 when Pragma_Unreferenced =>
24979 Analyze_Unreferenced_Or_Unused;
24981 --------------------------
24982 -- Unreferenced_Objects --
24983 --------------------------
24985 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24987 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24989 Arg_Expr : Node_Id;
24990 Arg_Id : Entity_Id;
24992 Ghost_Error_Posted : Boolean := False;
24993 -- Flag set when an error concerning the illegal mix of Ghost and
24994 -- non-Ghost types is emitted.
24996 Ghost_Id : Entity_Id := Empty;
24997 -- The entity of the first Ghost type encountered while processing
24998 -- the arguments of the pragma.
25002 Check_At_Least_N_Arguments (1);
25005 while Present (Arg) loop
25006 Check_No_Identifier (Arg);
25007 Check_Arg_Is_Local_Name (Arg);
25008 Arg_Expr := Get_Pragma_Arg (Arg);
25010 if Is_Entity_Name (Arg_Expr) then
25011 Arg_Id := Entity (Arg_Expr);
25013 if Is_Type (Arg_Id) then
25014 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
25016 -- A pragma that applies to a Ghost entity becomes Ghost
25017 -- for the purposes of legality checks and removal of
25018 -- ignored Ghost code.
25020 Mark_Ghost_Pragma (N, Arg_Id);
25022 -- Capture the entity of the first Ghost type being
25023 -- processed for error detection purposes.
25025 if Is_Ghost_Entity (Arg_Id) then
25026 if No (Ghost_Id) then
25027 Ghost_Id := Arg_Id;
25030 -- Otherwise the type is non-Ghost. It is illegal to mix
25031 -- references to Ghost and non-Ghost entities
25034 elsif Present (Ghost_Id)
25035 and then not Ghost_Error_Posted
25037 Ghost_Error_Posted := True;
25039 Error_Msg_Name_1 := Pname;
25041 ("pragma % cannot mention ghost and non-ghost types",
25044 Error_Msg_Sloc := Sloc (Ghost_Id);
25045 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25047 Error_Msg_Sloc := Sloc (Arg_Id);
25048 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25052 ("argument for pragma% must be type or subtype", Arg);
25056 ("argument for pragma% must be type or subtype", Arg);
25061 end Unreferenced_Objects;
25063 ------------------------------
25064 -- Unreserve_All_Interrupts --
25065 ------------------------------
25067 -- pragma Unreserve_All_Interrupts;
25069 when Pragma_Unreserve_All_Interrupts =>
25071 Check_Arg_Count (0);
25073 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25074 Unreserve_All_Interrupts := True;
25081 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25083 when Pragma_Unsuppress =>
25085 Process_Suppress_Unsuppress (Suppress_Case => False);
25091 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25093 when Pragma_Unused =>
25094 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25095 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25097 -------------------
25098 -- Use_VADS_Size --
25099 -------------------
25101 -- pragma Use_VADS_Size;
25103 when Pragma_Use_VADS_Size =>
25105 Check_Arg_Count (0);
25106 Check_Valid_Configuration_Pragma;
25107 Use_VADS_Size := True;
25109 ---------------------
25110 -- Validity_Checks --
25111 ---------------------
25113 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25115 when Pragma_Validity_Checks => Validity_Checks : declare
25116 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25122 Check_Arg_Count (1);
25123 Check_No_Identifiers;
25125 -- Pragma always active unless in CodePeer or GNATprove modes,
25126 -- which use a fixed configuration of validity checks.
25128 if not (CodePeer_Mode or GNATprove_Mode) then
25129 if Nkind (A) = N_String_Literal then
25133 Slen : constant Natural := Natural (String_Length (S));
25134 Options : String (1 .. Slen);
25138 -- Couldn't we use a for loop here over Options'Range???
25142 C := Get_String_Char (S, Pos (J));
25144 -- This is a weird test, it skips setting validity
25145 -- checks entirely if any element of S is out of
25146 -- range of Character, what is that about ???
25148 exit when not In_Character_Range (C);
25149 Options (J) := Get_Character (C);
25152 Set_Validity_Check_Options (Options);
25160 elsif Nkind (A) = N_Identifier then
25161 if Chars (A) = Name_All_Checks then
25162 Set_Validity_Check_Options ("a");
25163 elsif Chars (A) = Name_On then
25164 Validity_Checks_On := True;
25165 elsif Chars (A) = Name_Off then
25166 Validity_Checks_On := False;
25170 end Validity_Checks;
25176 -- pragma Volatile (LOCAL_NAME);
25178 when Pragma_Volatile =>
25179 Process_Atomic_Independent_Shared_Volatile;
25181 -------------------------
25182 -- Volatile_Components --
25183 -------------------------
25185 -- pragma Volatile_Components (array_LOCAL_NAME);
25187 -- Volatile is handled by the same circuit as Atomic_Components
25189 --------------------------
25190 -- Volatile_Full_Access --
25191 --------------------------
25193 -- pragma Volatile_Full_Access (LOCAL_NAME);
25195 when Pragma_Volatile_Full_Access =>
25197 Process_Atomic_Independent_Shared_Volatile;
25199 -----------------------
25200 -- Volatile_Function --
25201 -----------------------
25203 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25205 when Pragma_Volatile_Function => Volatile_Function : declare
25206 Over_Id : Entity_Id;
25207 Spec_Id : Entity_Id;
25208 Subp_Decl : Node_Id;
25212 Check_No_Identifiers;
25213 Check_At_Most_N_Arguments (1);
25216 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25218 -- Generic subprogram
25220 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25223 -- Body acts as spec
25225 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25226 and then No (Corresponding_Spec (Subp_Decl))
25230 -- Body stub acts as spec
25232 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25233 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25239 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25247 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25249 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
25254 -- A pragma that applies to a Ghost entity becomes Ghost for the
25255 -- purposes of legality checks and removal of ignored Ghost code.
25257 Mark_Ghost_Pragma (N, Spec_Id);
25259 -- Chain the pragma on the contract for completeness
25261 Add_Contract_Item (N, Spec_Id);
25263 -- The legality checks of pragma Volatile_Function are affected by
25264 -- the SPARK mode in effect. Analyze all pragmas in a specific
25267 Analyze_If_Present (Pragma_SPARK_Mode);
25269 -- A volatile function cannot override a non-volatile function
25270 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25271 -- in New_Overloaded_Entity, however at that point the pragma has
25272 -- not been processed yet.
25274 Over_Id := Overridden_Operation (Spec_Id);
25276 if Present (Over_Id)
25277 and then not Is_Volatile_Function (Over_Id)
25280 ("incompatible volatile function values in effect", Spec_Id);
25282 Error_Msg_Sloc := Sloc (Over_Id);
25284 ("\& declared # with Volatile_Function value False",
25287 Error_Msg_Sloc := Sloc (Spec_Id);
25289 ("\overridden # with Volatile_Function value True",
25293 -- Analyze the Boolean expression (if any)
25295 if Present (Arg1) then
25296 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25298 end Volatile_Function;
25300 ----------------------
25301 -- Warning_As_Error --
25302 ----------------------
25304 -- pragma Warning_As_Error (static_string_EXPRESSION);
25306 when Pragma_Warning_As_Error =>
25308 Check_Arg_Count (1);
25309 Check_No_Identifiers;
25310 Check_Valid_Configuration_Pragma;
25312 if not Is_Static_String_Expression (Arg1) then
25314 ("argument of pragma% must be static string expression",
25317 -- OK static string expression
25320 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25321 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25322 new String'(Acquire_Warning_Match_String
25323 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25330 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25332 -- DETAILS ::= On | Off
25333 -- DETAILS ::= On | Off, local_NAME
25334 -- DETAILS ::= static_string_EXPRESSION
25335 -- DETAILS ::= On | Off, static_string_EXPRESSION
25337 -- TOOL_NAME ::= GNAT | GNATprove
25339 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25341 -- Note: If the first argument matches an allowed tool name, it is
25342 -- always considered to be a tool name, even if there is a string
25343 -- variable of that name.
25345 -- Note if the second argument of DETAILS is a local_NAME then the
25346 -- second form is always understood. If the intention is to use
25347 -- the fourth form, then you can write NAME & "" to force the
25348 -- intepretation as a static_string_EXPRESSION.
25350 when Pragma_Warnings => Warnings : declare
25351 Reason : String_Id;
25355 Check_At_Least_N_Arguments (1);
25357 -- See if last argument is labeled Reason. If so, make sure we
25358 -- have a string literal or a concatenation of string literals,
25359 -- and acquire the REASON string. Then remove the REASON argument
25360 -- by decreasing Num_Args by one; Remaining processing looks only
25361 -- at first Num_Args arguments).
25364 Last_Arg : constant Node_Id :=
25365 Last (Pragma_Argument_Associations (N));
25368 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25369 and then Chars (Last_Arg) = Name_Reason
25372 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25373 Reason := End_String;
25374 Arg_Count := Arg_Count - 1;
25376 -- Not allowed in compiler units (bootstrap issues)
25378 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25380 -- No REASON string, set null string as reason
25383 Reason := Null_String_Id;
25387 -- Now proceed with REASON taken care of and eliminated
25389 Check_No_Identifiers;
25391 -- If debug flag -gnatd.i is set, pragma is ignored
25393 if Debug_Flag_Dot_I then
25397 -- Process various forms of the pragma
25400 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25401 Shifted_Args : List_Id;
25404 -- See if first argument is a tool name, currently either
25405 -- GNAT or GNATprove. If so, either ignore the pragma if the
25406 -- tool used does not match, or continue as if no tool name
25407 -- was given otherwise, by shifting the arguments.
25409 if Nkind (Argx) = N_Identifier
25410 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25412 if Chars (Argx) = Name_Gnat then
25413 if CodePeer_Mode or GNATprove_Mode then
25414 Rewrite (N, Make_Null_Statement (Loc));
25419 elsif Chars (Argx) = Name_Gnatprove then
25420 if not GNATprove_Mode then
25421 Rewrite (N, Make_Null_Statement (Loc));
25427 raise Program_Error;
25430 -- At this point, the pragma Warnings applies to the tool,
25431 -- so continue with shifted arguments.
25433 Arg_Count := Arg_Count - 1;
25435 if Arg_Count = 1 then
25436 Shifted_Args := New_List (New_Copy (Arg2));
25437 elsif Arg_Count = 2 then
25438 Shifted_Args := New_List (New_Copy (Arg2),
25440 elsif Arg_Count = 3 then
25441 Shifted_Args := New_List (New_Copy (Arg2),
25445 raise Program_Error;
25450 Chars => Name_Warnings,
25451 Pragma_Argument_Associations => Shifted_Args));
25456 -- One argument case
25458 if Arg_Count = 1 then
25460 -- On/Off one argument case was processed by parser
25462 if Nkind (Argx) = N_Identifier
25463 and then Chars (Argx) in Name_On | Name_Off
25467 -- One argument case must be ON/OFF or static string expr
25469 elsif not Is_Static_String_Expression (Arg1) then
25471 ("argument of pragma% must be On/Off or static string "
25472 & "expression", Arg1);
25474 -- One argument string expression case
25478 Lit : constant Node_Id := Expr_Value_S (Argx);
25479 Str : constant String_Id := Strval (Lit);
25480 Len : constant Nat := String_Length (Str);
25488 while J <= Len loop
25489 C := Get_String_Char (Str, J);
25490 OK := In_Character_Range (C);
25493 Chr := Get_Character (C);
25495 -- Dash case: only -Wxxx is accepted
25502 C := Get_String_Char (Str, J);
25503 Chr := Get_Character (C);
25504 exit when Chr = 'W';
25509 elsif J < Len and then Chr = '.' then
25511 C := Get_String_Char (Str, J);
25512 Chr := Get_Character (C);
25514 if not Set_Dot_Warning_Switch (Chr) then
25516 ("invalid warning switch character "
25517 & '.' & Chr, Arg1);
25523 OK := Set_Warning_Switch (Chr);
25528 ("invalid warning switch character " & Chr,
25534 ("invalid wide character in warning switch ",
25543 -- Two or more arguments (must be two)
25546 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25547 Check_Arg_Count (2);
25555 E_Id := Get_Pragma_Arg (Arg2);
25558 -- In the expansion of an inlined body, a reference to
25559 -- the formal may be wrapped in a conversion if the
25560 -- actual is a conversion. Retrieve the real entity name.
25562 if (In_Instance_Body or In_Inlined_Body)
25563 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25565 E_Id := Expression (E_Id);
25568 -- Entity name case
25570 if Is_Entity_Name (E_Id) then
25571 E := Entity (E_Id);
25578 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25581 -- Suppress elaboration warnings if the entity
25582 -- denotes an elaboration target.
25584 if Is_Elaboration_Target (E) then
25585 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25588 -- For OFF case, make entry in warnings off
25589 -- pragma table for later processing. But we do
25590 -- not do that within an instance, since these
25591 -- warnings are about what is needed in the
25592 -- template, not an instance of it.
25594 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25595 and then Warn_On_Warnings_Off
25596 and then not In_Instance
25598 Warnings_Off_Pragmas.Append ((N, E, Reason));
25601 if Is_Enumeration_Type (E) then
25605 Lit := First_Literal (E);
25606 while Present (Lit) loop
25607 Set_Warnings_Off (Lit);
25608 Next_Literal (Lit);
25613 exit when No (Homonym (E));
25618 -- Error if not entity or static string expression case
25620 elsif not Is_Static_String_Expression (Arg2) then
25622 ("second argument of pragma% must be entity name "
25623 & "or static string expression", Arg2);
25625 -- Static string expression case
25628 -- Note on configuration pragma case: If this is a
25629 -- configuration pragma, then for an OFF pragma, we
25630 -- just set Config True in the call, which is all
25631 -- that needs to be done. For the case of ON, this
25632 -- is normally an error, unless it is canceling the
25633 -- effect of a previous OFF pragma in the same file.
25634 -- In any other case, an error will be signalled (ON
25635 -- with no matching OFF).
25637 -- Note: We set Used if we are inside a generic to
25638 -- disable the test that the non-config case actually
25639 -- cancels a warning. That's because we can't be sure
25640 -- there isn't an instantiation in some other unit
25641 -- where a warning is suppressed.
25643 -- We could do a little better here by checking if the
25644 -- generic unit we are inside is public, but for now
25645 -- we don't bother with that refinement.
25648 Message : constant String :=
25649 Acquire_Warning_Match_String
25650 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25652 if Chars (Argx) = Name_Off then
25653 Set_Specific_Warning_Off
25654 (Loc, Message, Reason,
25655 Config => Is_Configuration_Pragma,
25656 Used => Inside_A_Generic or else In_Instance);
25658 elsif Chars (Argx) = Name_On then
25659 Set_Specific_Warning_On (Loc, Message, Err);
25663 ("??pragma Warnings On with no matching "
25664 & "Warnings Off", Loc);
25674 -------------------
25675 -- Weak_External --
25676 -------------------
25678 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25680 when Pragma_Weak_External => Weak_External : declare
25685 Check_Arg_Count (1);
25686 Check_Optional_Identifier (Arg1, Name_Entity);
25687 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25688 Ent := Entity (Get_Pragma_Arg (Arg1));
25690 if Rep_Item_Too_Early (Ent, N) then
25693 Ent := Underlying_Type (Ent);
25696 -- The pragma applies to entities with addresses
25698 if Is_Type (Ent) then
25699 Error_Pragma ("pragma applies to objects and subprograms");
25702 -- The only processing required is to link this item on to the
25703 -- list of rep items for the given entity. This is accomplished
25704 -- by the call to Rep_Item_Too_Late (when no error is detected
25705 -- and False is returned).
25707 if Rep_Item_Too_Late (Ent, N) then
25710 Set_Has_Gigi_Rep_Item (Ent);
25714 -----------------------------
25715 -- Wide_Character_Encoding --
25716 -----------------------------
25718 -- pragma Wide_Character_Encoding (IDENTIFIER);
25720 when Pragma_Wide_Character_Encoding =>
25723 -- Nothing to do, handled in parser. Note that we do not enforce
25724 -- configuration pragma placement, this pragma can appear at any
25725 -- place in the source, allowing mixed encodings within a single
25730 --------------------
25731 -- Unknown_Pragma --
25732 --------------------
25734 -- Should be impossible, since the case of an unknown pragma is
25735 -- separately processed before the case statement is entered.
25737 when Unknown_Pragma =>
25738 raise Program_Error;
25741 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25742 -- until AI is formally approved.
25744 -- Check_Order_Dependence;
25747 when Pragma_Exit => null;
25748 end Analyze_Pragma;
25750 ---------------------------------------------
25751 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25752 ---------------------------------------------
25754 -- WARNING: This routine manages Ghost regions. Return statements must be
25755 -- replaced by gotos which jump to the end of the routine and restore the
25758 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25760 Freeze_Id : Entity_Id := Empty)
25762 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25763 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25765 Disp_Typ : Entity_Id;
25766 -- The dispatching type of the subprogram subject to the pre- or
25769 function Check_References (Nod : Node_Id) return Traverse_Result;
25770 -- Check that expression Nod does not mention non-primitives of the
25771 -- type, global objects of the type, or other illegalities described
25772 -- and implied by AI12-0113.
25774 ----------------------
25775 -- Check_References --
25776 ----------------------
25778 function Check_References (Nod : Node_Id) return Traverse_Result is
25780 if Nkind (Nod) = N_Function_Call
25781 and then Is_Entity_Name (Name (Nod))
25784 Func : constant Entity_Id := Entity (Name (Nod));
25788 -- An operation of the type must be a primitive
25790 if No (Find_Dispatching_Type (Func)) then
25791 Form := First_Formal (Func);
25792 while Present (Form) loop
25793 if Etype (Form) = Disp_Typ then
25795 ("operation in class-wide condition must be "
25796 & "primitive of &", Nod, Disp_Typ);
25799 Next_Formal (Form);
25802 -- A return object of the type is illegal as well
25804 if Etype (Func) = Disp_Typ
25805 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25808 ("operation in class-wide condition must be primitive "
25809 & "of &", Nod, Disp_Typ);
25812 -- Otherwise we have a call to an overridden primitive, and we
25813 -- will create a common class-wide clone for the body of
25814 -- original operation and its eventual inherited versions. If
25815 -- the original operation dispatches on result it is never
25816 -- inherited and there is no need for a clone. There is not
25817 -- need for a clone either in GNATprove mode, as cases that
25818 -- would require it are rejected (when an inherited primitive
25819 -- calls an overridden operation in a class-wide contract), and
25820 -- the clone would make proof impossible in some cases.
25822 elsif not Is_Abstract_Subprogram (Spec_Id)
25823 and then No (Class_Wide_Clone (Spec_Id))
25824 and then not Has_Controlling_Result (Spec_Id)
25825 and then not GNATprove_Mode
25827 Build_Class_Wide_Clone_Decl (Spec_Id);
25831 elsif Is_Entity_Name (Nod)
25833 (Etype (Nod) = Disp_Typ
25834 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25835 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
25838 ("object in class-wide condition must be formal of type &",
25841 elsif Nkind (Nod) = N_Explicit_Dereference
25842 and then (Etype (Nod) = Disp_Typ
25843 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25844 and then (not Is_Entity_Name (Prefix (Nod))
25845 or else not Is_Formal (Entity (Prefix (Nod))))
25848 ("operation in class-wide condition must be primitive of &",
25853 end Check_References;
25855 procedure Check_Class_Wide_Condition is
25856 new Traverse_Proc (Check_References);
25860 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25862 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25863 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25864 -- Save the Ghost-related attributes to restore on exit
25867 Restore_Scope : Boolean := False;
25869 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25872 -- Do not analyze the pragma multiple times
25874 if Is_Analyzed_Pragma (N) then
25878 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25879 -- analysis of the pragma, the Ghost mode at point of declaration and
25880 -- point of analysis may not necessarily be the same. Use the mode in
25881 -- effect at the point of declaration.
25883 Set_Ghost_Mode (N);
25885 -- Ensure that the subprogram and its formals are visible when analyzing
25886 -- the expression of the pragma.
25888 if not In_Open_Scopes (Spec_Id) then
25889 Restore_Scope := True;
25890 Push_Scope (Spec_Id);
25892 if Is_Generic_Subprogram (Spec_Id) then
25893 Install_Generic_Formals (Spec_Id);
25895 Install_Formals (Spec_Id);
25899 Errors := Serious_Errors_Detected;
25900 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25902 -- Emit a clarification message when the expression contains at least
25903 -- one undefined reference, possibly due to contract freezing.
25905 if Errors /= Serious_Errors_Detected
25906 and then Present (Freeze_Id)
25907 and then Has_Undefined_Reference (Expr)
25909 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25912 if Class_Present (N) then
25914 -- Verify that a class-wide condition is legal, i.e. the operation is
25915 -- a primitive of a tagged type. Note that a generic subprogram is
25916 -- not a primitive operation.
25918 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25920 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25921 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25923 if From_Aspect_Specification (N) then
25925 ("aspect % can only be specified for a primitive operation "
25926 & "of a tagged type", Corresponding_Aspect (N));
25928 -- The pragma is a source construct
25932 ("pragma % can only be specified for a primitive operation "
25933 & "of a tagged type", N);
25936 -- Remaining semantic checks require a full tree traversal
25939 Check_Class_Wide_Condition (Expr);
25944 if Restore_Scope then
25948 -- If analysis of the condition indicates that a class-wide clone
25949 -- has been created, build and analyze its declaration.
25951 if Is_Subprogram (Spec_Id)
25952 and then Present (Class_Wide_Clone (Spec_Id))
25954 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25957 -- Currently it is not possible to inline pre/postconditions on a
25958 -- subprogram subject to pragma Inline_Always.
25960 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25961 Set_Is_Analyzed_Pragma (N);
25963 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25964 end Analyze_Pre_Post_Condition_In_Decl_Part;
25966 ------------------------------------------
25967 -- Analyze_Refined_Depends_In_Decl_Part --
25968 ------------------------------------------
25970 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25971 procedure Check_Dependency_Clause
25972 (Spec_Id : Entity_Id;
25973 Dep_Clause : Node_Id;
25974 Dep_States : Elist_Id;
25975 Refinements : List_Id;
25976 Matched_Items : in out Elist_Id);
25977 -- Try to match a single dependency clause Dep_Clause against one or
25978 -- more refinement clauses found in list Refinements. Each successful
25979 -- match eliminates at least one refinement clause from Refinements.
25980 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25981 -- denotes the entities of all abstract states which appear in pragma
25982 -- Depends. Matched_Items contains the entities of all successfully
25983 -- matched items found in pragma Depends.
25985 procedure Check_Output_States
25986 (Spec_Inputs : Elist_Id;
25987 Spec_Outputs : Elist_Id;
25988 Body_Inputs : Elist_Id;
25989 Body_Outputs : Elist_Id);
25990 -- Determine whether pragma Depends contains an output state with a
25991 -- visible refinement and if so, ensure that pragma Refined_Depends
25992 -- mentions all its constituents as outputs. Spec_Inputs and
25993 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25994 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25995 -- the inputs and outputs of the subprogram body synthesized from pragma
25996 -- Refined_Depends.
25998 function Collect_States (Clauses : List_Id) return Elist_Id;
25999 -- Given a normalized list of dependencies obtained from calling
26000 -- Normalize_Clauses, return a list containing the entities of all
26001 -- states appearing in dependencies. It helps in checking refinements
26002 -- involving a state and a corresponding constituent which is not a
26003 -- direct constituent of the state.
26005 procedure Normalize_Clauses (Clauses : List_Id);
26006 -- Given a list of dependence or refinement clauses Clauses, normalize
26007 -- each clause by creating multiple dependencies with exactly one input
26010 procedure Remove_Extra_Clauses
26011 (Clauses : List_Id;
26012 Matched_Items : Elist_Id);
26013 -- Given a list of refinement clauses Clauses, remove all clauses whose
26014 -- inputs and/or outputs have been previously matched. See the body for
26015 -- all special cases. Matched_Items contains the entities of all matched
26016 -- items found in pragma Depends.
26018 procedure Report_Extra_Clauses (Clauses : List_Id);
26019 -- Emit an error for each extra clause found in list Clauses
26021 -----------------------------
26022 -- Check_Dependency_Clause --
26023 -----------------------------
26025 procedure Check_Dependency_Clause
26026 (Spec_Id : Entity_Id;
26027 Dep_Clause : Node_Id;
26028 Dep_States : Elist_Id;
26029 Refinements : List_Id;
26030 Matched_Items : in out Elist_Id)
26032 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26033 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26035 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26036 -- Determine whether dependency item Dep_Item has been matched in a
26037 -- previous clause.
26039 function Is_In_Out_State_Clause return Boolean;
26040 -- Determine whether dependence clause Dep_Clause denotes an abstract
26041 -- state that depends on itself (State => State).
26043 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26044 -- Determine whether item Item denotes an abstract state with visible
26045 -- null refinement.
26047 procedure Match_Items
26048 (Dep_Item : Node_Id;
26049 Ref_Item : Node_Id;
26050 Matched : out Boolean);
26051 -- Try to match dependence item Dep_Item against refinement item
26052 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26053 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26054 -- the following conformance scenarios is in effect:
26055 -- 1) Both items denote null
26056 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26057 -- 3) Both items denote attribute 'Result
26058 -- 4) Both items denote the same object
26059 -- 5) Both items denote the same formal parameter
26060 -- 6) Both items denote the same current instance of a type
26061 -- 7) Both items denote the same discriminant
26062 -- 8) Dep_Item is an abstract state with visible null refinement
26063 -- and Ref_Item denotes null.
26064 -- 9) Dep_Item is an abstract state with visible null refinement
26065 -- and Ref_Item is Empty (special case).
26066 -- 10) Dep_Item is an abstract state with full or partial visible
26067 -- non-null refinement and Ref_Item denotes one of its
26069 -- 11) Dep_Item is an abstract state without a full visible
26070 -- refinement and Ref_Item denotes the same state.
26071 -- When scenario 10 is in effect, the entity of the abstract state
26072 -- denoted by Dep_Item is added to list Refined_States.
26074 procedure Record_Item (Item_Id : Entity_Id);
26075 -- Store the entity of an item denoted by Item_Id in Matched_Items
26077 ------------------------
26078 -- Is_Already_Matched --
26079 ------------------------
26081 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26082 Item_Id : Entity_Id := Empty;
26085 -- When the dependency item denotes attribute 'Result, check for
26086 -- the entity of the related subprogram.
26088 if Is_Attribute_Result (Dep_Item) then
26089 Item_Id := Spec_Id;
26091 elsif Is_Entity_Name (Dep_Item) then
26092 Item_Id := Available_View (Entity_Of (Dep_Item));
26096 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26097 end Is_Already_Matched;
26099 ----------------------------
26100 -- Is_In_Out_State_Clause --
26101 ----------------------------
26103 function Is_In_Out_State_Clause return Boolean is
26104 Dep_Input_Id : Entity_Id;
26105 Dep_Output_Id : Entity_Id;
26108 -- Detect the following clause:
26111 if Is_Entity_Name (Dep_Input)
26112 and then Is_Entity_Name (Dep_Output)
26114 -- Handle abstract views generated for limited with clauses
26116 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26117 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26120 Ekind (Dep_Input_Id) = E_Abstract_State
26121 and then Dep_Input_Id = Dep_Output_Id;
26125 end Is_In_Out_State_Clause;
26127 ---------------------------
26128 -- Is_Null_Refined_State --
26129 ---------------------------
26131 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26132 Item_Id : Entity_Id;
26135 if Is_Entity_Name (Item) then
26137 -- Handle abstract views generated for limited with clauses
26139 Item_Id := Available_View (Entity_Of (Item));
26142 Ekind (Item_Id) = E_Abstract_State
26143 and then Has_Null_Visible_Refinement (Item_Id);
26147 end Is_Null_Refined_State;
26153 procedure Match_Items
26154 (Dep_Item : Node_Id;
26155 Ref_Item : Node_Id;
26156 Matched : out Boolean)
26158 Dep_Item_Id : Entity_Id;
26159 Ref_Item_Id : Entity_Id;
26162 -- Assume that the two items do not match
26166 -- A null matches null or Empty (special case)
26168 if Nkind (Dep_Item) = N_Null
26169 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26173 -- Attribute 'Result matches attribute 'Result
26175 elsif Is_Attribute_Result (Dep_Item)
26176 and then Is_Attribute_Result (Ref_Item)
26178 -- Put the entity of the related function on the list of
26179 -- matched items because attribute 'Result does not carry
26180 -- an entity similar to states and constituents.
26182 Record_Item (Spec_Id);
26185 -- Abstract states, current instances of concurrent types,
26186 -- discriminants, formal parameters and objects.
26188 elsif Is_Entity_Name (Dep_Item) then
26190 -- Handle abstract views generated for limited with clauses
26192 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26194 if Ekind (Dep_Item_Id) = E_Abstract_State then
26196 -- An abstract state with visible null refinement matches
26197 -- null or Empty (special case).
26199 if Has_Null_Visible_Refinement (Dep_Item_Id)
26200 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26202 Record_Item (Dep_Item_Id);
26205 -- An abstract state with visible non-null refinement
26206 -- matches one of its constituents, or itself for an
26207 -- abstract state with partial visible refinement.
26209 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26210 if Is_Entity_Name (Ref_Item) then
26211 Ref_Item_Id := Entity_Of (Ref_Item);
26213 if Ekind (Ref_Item_Id) in
26214 E_Abstract_State | E_Constant | E_Variable
26215 and then Present (Encapsulating_State (Ref_Item_Id))
26216 and then Find_Encapsulating_State
26217 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26219 Record_Item (Dep_Item_Id);
26222 elsif not Has_Visible_Refinement (Dep_Item_Id)
26223 and then Ref_Item_Id = Dep_Item_Id
26225 Record_Item (Dep_Item_Id);
26230 -- An abstract state without a visible refinement matches
26233 elsif Is_Entity_Name (Ref_Item)
26234 and then Entity_Of (Ref_Item) = Dep_Item_Id
26236 Record_Item (Dep_Item_Id);
26240 -- A current instance of a concurrent type, discriminant,
26241 -- formal parameter or an object matches itself.
26243 elsif Is_Entity_Name (Ref_Item)
26244 and then Entity_Of (Ref_Item) = Dep_Item_Id
26246 Record_Item (Dep_Item_Id);
26256 procedure Record_Item (Item_Id : Entity_Id) is
26258 if No (Matched_Items) then
26259 Matched_Items := New_Elmt_List;
26262 Append_Unique_Elmt (Item_Id, Matched_Items);
26267 Clause_Matched : Boolean := False;
26268 Dummy : Boolean := False;
26269 Inputs_Match : Boolean;
26270 Next_Ref_Clause : Node_Id;
26271 Outputs_Match : Boolean;
26272 Ref_Clause : Node_Id;
26273 Ref_Input : Node_Id;
26274 Ref_Output : Node_Id;
26276 -- Start of processing for Check_Dependency_Clause
26279 -- Do not perform this check in an instance because it was already
26280 -- performed successfully in the generic template.
26282 if In_Instance then
26286 -- Examine all refinement clauses and compare them against the
26287 -- dependence clause.
26289 Ref_Clause := First (Refinements);
26290 while Present (Ref_Clause) loop
26291 Next_Ref_Clause := Next (Ref_Clause);
26293 -- Obtain the attributes of the current refinement clause
26295 Ref_Input := Expression (Ref_Clause);
26296 Ref_Output := First (Choices (Ref_Clause));
26298 -- The current refinement clause matches the dependence clause
26299 -- when both outputs match and both inputs match. See routine
26300 -- Match_Items for all possible conformance scenarios.
26302 -- Depends Dep_Output => Dep_Input
26306 -- Refined_Depends Ref_Output => Ref_Input
26309 (Dep_Item => Dep_Input,
26310 Ref_Item => Ref_Input,
26311 Matched => Inputs_Match);
26314 (Dep_Item => Dep_Output,
26315 Ref_Item => Ref_Output,
26316 Matched => Outputs_Match);
26318 -- An In_Out state clause may be matched against a refinement with
26319 -- a null input or null output as long as the non-null side of the
26320 -- relation contains a valid constituent of the In_Out_State.
26322 if Is_In_Out_State_Clause then
26324 -- Depends => (State => State)
26325 -- Refined_Depends => (null => Constit) -- OK
26328 and then not Outputs_Match
26329 and then Nkind (Ref_Output) = N_Null
26331 Outputs_Match := True;
26334 -- Depends => (State => State)
26335 -- Refined_Depends => (Constit => null) -- OK
26337 if not Inputs_Match
26338 and then Outputs_Match
26339 and then Nkind (Ref_Input) = N_Null
26341 Inputs_Match := True;
26345 -- The current refinement clause is legally constructed following
26346 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26347 -- the pool of candidates. The seach continues because a single
26348 -- dependence clause may have multiple matching refinements.
26350 if Inputs_Match and Outputs_Match then
26351 Clause_Matched := True;
26352 Remove (Ref_Clause);
26355 Ref_Clause := Next_Ref_Clause;
26358 -- Depending on the order or composition of refinement clauses, an
26359 -- In_Out state clause may not be directly refinable.
26361 -- Refined_State => (State => (Constit_1, Constit_2))
26362 -- Depends => ((Output, State) => (Input, State))
26363 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26365 -- Matching normalized clause (State => State) fails because there is
26366 -- no direct refinement capable of satisfying this relation. Another
26367 -- similar case arises when clauses (Constit_1 => Input) and (Output
26368 -- => Constit_2) are matched first, leaving no candidates for clause
26369 -- (State => State). Both scenarios are legal as long as one of the
26370 -- previous clauses mentioned a valid constituent of State.
26372 if not Clause_Matched
26373 and then Is_In_Out_State_Clause
26374 and then Is_Already_Matched (Dep_Input)
26376 Clause_Matched := True;
26379 -- A clause where the input is an abstract state with visible null
26380 -- refinement or a 'Result attribute is implicitly matched when the
26381 -- output has already been matched in a previous clause.
26383 -- Refined_State => (State => null)
26384 -- Depends => (Output => State) -- implicitly OK
26385 -- Refined_Depends => (Output => ...)
26386 -- Depends => (...'Result => State) -- implicitly OK
26387 -- Refined_Depends => (...'Result => ...)
26389 if not Clause_Matched
26390 and then Is_Null_Refined_State (Dep_Input)
26391 and then Is_Already_Matched (Dep_Output)
26393 Clause_Matched := True;
26396 -- A clause where the output is an abstract state with visible null
26397 -- refinement is implicitly matched when the input has already been
26398 -- matched in a previous clause.
26400 -- Refined_State => (State => null)
26401 -- Depends => (State => Input) -- implicitly OK
26402 -- Refined_Depends => (... => Input)
26404 if not Clause_Matched
26405 and then Is_Null_Refined_State (Dep_Output)
26406 and then Is_Already_Matched (Dep_Input)
26408 Clause_Matched := True;
26411 -- At this point either all refinement clauses have been examined or
26412 -- pragma Refined_Depends contains a solitary null. Only an abstract
26413 -- state with null refinement can possibly match these cases.
26415 -- Refined_State => (State => null)
26416 -- Depends => (State => null)
26417 -- Refined_Depends => null -- OK
26419 if not Clause_Matched then
26421 (Dep_Item => Dep_Input,
26423 Matched => Inputs_Match);
26426 (Dep_Item => Dep_Output,
26428 Matched => Outputs_Match);
26430 Clause_Matched := Inputs_Match and Outputs_Match;
26433 -- If the contents of Refined_Depends are legal, then the current
26434 -- dependence clause should be satisfied either by an explicit match
26435 -- or by one of the special cases.
26437 if not Clause_Matched then
26439 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26440 & "matching refinement in body"), Dep_Clause, Spec_Id);
26442 end Check_Dependency_Clause;
26444 -------------------------
26445 -- Check_Output_States --
26446 -------------------------
26448 procedure Check_Output_States
26449 (Spec_Inputs : Elist_Id;
26450 Spec_Outputs : Elist_Id;
26451 Body_Inputs : Elist_Id;
26452 Body_Outputs : Elist_Id)
26454 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26455 -- Determine whether all constituents of state State_Id with full
26456 -- visible refinement are used as outputs in pragma Refined_Depends.
26457 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26459 -----------------------------
26460 -- Check_Constituent_Usage --
26461 -----------------------------
26463 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26464 Constits : constant Elist_Id :=
26465 Partial_Refinement_Constituents (State_Id);
26466 Constit_Elmt : Elmt_Id;
26467 Constit_Id : Entity_Id;
26468 Only_Partial : constant Boolean :=
26469 not Has_Visible_Refinement (State_Id);
26470 Posted : Boolean := False;
26473 if Present (Constits) then
26474 Constit_Elmt := First_Elmt (Constits);
26475 while Present (Constit_Elmt) loop
26476 Constit_Id := Node (Constit_Elmt);
26478 -- Issue an error when a constituent of State_Id is used,
26479 -- and State_Id has only partial visible refinement
26480 -- (SPARK RM 7.2.4(3d)).
26482 if Only_Partial then
26483 if (Present (Body_Inputs)
26484 and then Appears_In (Body_Inputs, Constit_Id))
26486 (Present (Body_Outputs)
26487 and then Appears_In (Body_Outputs, Constit_Id))
26489 Error_Msg_Name_1 := Chars (State_Id);
26491 ("constituent & of state % cannot be used in "
26492 & "dependence refinement", N, Constit_Id);
26493 Error_Msg_Name_1 := Chars (State_Id);
26494 SPARK_Msg_N ("\use state % instead", N);
26497 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26499 elsif Present (Body_Inputs)
26500 and then Appears_In (Body_Inputs, Constit_Id)
26502 Error_Msg_Name_1 := Chars (State_Id);
26504 ("constituent & of state % must act as output in "
26505 & "dependence refinement", N, Constit_Id);
26507 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26509 elsif No (Body_Outputs)
26510 or else not Appears_In (Body_Outputs, Constit_Id)
26515 ("output state & must be replaced by all its "
26516 & "constituents in dependence refinement",
26521 ("\constituent & is missing in output list",
26525 Next_Elmt (Constit_Elmt);
26528 end Check_Constituent_Usage;
26533 Item_Elmt : Elmt_Id;
26534 Item_Id : Entity_Id;
26536 -- Start of processing for Check_Output_States
26539 -- Do not perform this check in an instance because it was already
26540 -- performed successfully in the generic template.
26542 if In_Instance then
26545 -- Inspect the outputs of pragma Depends looking for a state with a
26546 -- visible refinement.
26548 elsif Present (Spec_Outputs) then
26549 Item_Elmt := First_Elmt (Spec_Outputs);
26550 while Present (Item_Elmt) loop
26551 Item := Node (Item_Elmt);
26553 -- Deal with the mixed nature of the input and output lists
26555 if Nkind (Item) = N_Defining_Identifier then
26558 Item_Id := Available_View (Entity_Of (Item));
26561 if Ekind (Item_Id) = E_Abstract_State then
26563 -- The state acts as an input-output, skip it
26565 if Present (Spec_Inputs)
26566 and then Appears_In (Spec_Inputs, Item_Id)
26570 -- Ensure that all of the constituents are utilized as
26571 -- outputs in pragma Refined_Depends.
26573 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26574 Check_Constituent_Usage (Item_Id);
26578 Next_Elmt (Item_Elmt);
26581 end Check_Output_States;
26583 --------------------
26584 -- Collect_States --
26585 --------------------
26587 function Collect_States (Clauses : List_Id) return Elist_Id is
26588 procedure Collect_State
26590 States : in out Elist_Id);
26591 -- Add the entity of Item to list States when it denotes to a state
26593 -------------------
26594 -- Collect_State --
26595 -------------------
26597 procedure Collect_State
26599 States : in out Elist_Id)
26604 if Is_Entity_Name (Item) then
26605 Id := Entity_Of (Item);
26607 if Ekind (Id) = E_Abstract_State then
26608 if No (States) then
26609 States := New_Elmt_List;
26612 Append_Unique_Elmt (Id, States);
26622 States : Elist_Id := No_Elist;
26624 -- Start of processing for Collect_States
26627 Clause := First (Clauses);
26628 while Present (Clause) loop
26629 Input := Expression (Clause);
26630 Output := First (Choices (Clause));
26632 Collect_State (Input, States);
26633 Collect_State (Output, States);
26639 end Collect_States;
26641 -----------------------
26642 -- Normalize_Clauses --
26643 -----------------------
26645 procedure Normalize_Clauses (Clauses : List_Id) is
26646 procedure Normalize_Inputs (Clause : Node_Id);
26647 -- Normalize clause Clause by creating multiple clauses for each
26648 -- input item of Clause. It is assumed that Clause has exactly one
26649 -- output. The transformation is as follows:
26651 -- Output => (Input_1, Input_2) -- original
26653 -- Output => Input_1 -- normalizations
26654 -- Output => Input_2
26656 procedure Normalize_Outputs (Clause : Node_Id);
26657 -- Normalize clause Clause by creating multiple clause for each
26658 -- output item of Clause. The transformation is as follows:
26660 -- (Output_1, Output_2) => Input -- original
26662 -- Output_1 => Input -- normalization
26663 -- Output_2 => Input
26665 ----------------------
26666 -- Normalize_Inputs --
26667 ----------------------
26669 procedure Normalize_Inputs (Clause : Node_Id) is
26670 Inputs : constant Node_Id := Expression (Clause);
26671 Loc : constant Source_Ptr := Sloc (Clause);
26672 Output : constant List_Id := Choices (Clause);
26673 Last_Input : Node_Id;
26675 New_Clause : Node_Id;
26676 Next_Input : Node_Id;
26679 -- Normalization is performed only when the original clause has
26680 -- more than one input. Multiple inputs appear as an aggregate.
26682 if Nkind (Inputs) = N_Aggregate then
26683 Last_Input := Last (Expressions (Inputs));
26685 -- Create a new clause for each input
26687 Input := First (Expressions (Inputs));
26688 while Present (Input) loop
26689 Next_Input := Next (Input);
26691 -- Unhook the current input from the original input list
26692 -- because it will be relocated to a new clause.
26696 -- Special processing for the last input. At this point the
26697 -- original aggregate has been stripped down to one element.
26698 -- Replace the aggregate by the element itself.
26700 if Input = Last_Input then
26701 Rewrite (Inputs, Input);
26703 -- Generate a clause of the form:
26708 Make_Component_Association (Loc,
26709 Choices => New_Copy_List_Tree (Output),
26710 Expression => Input);
26712 -- The new clause contains replicated content that has
26713 -- already been analyzed, mark the clause as analyzed.
26715 Set_Analyzed (New_Clause);
26716 Insert_After (Clause, New_Clause);
26719 Input := Next_Input;
26722 end Normalize_Inputs;
26724 -----------------------
26725 -- Normalize_Outputs --
26726 -----------------------
26728 procedure Normalize_Outputs (Clause : Node_Id) is
26729 Inputs : constant Node_Id := Expression (Clause);
26730 Loc : constant Source_Ptr := Sloc (Clause);
26731 Outputs : constant Node_Id := First (Choices (Clause));
26732 Last_Output : Node_Id;
26733 New_Clause : Node_Id;
26734 Next_Output : Node_Id;
26738 -- Multiple outputs appear as an aggregate. Nothing to do when
26739 -- the clause has exactly one output.
26741 if Nkind (Outputs) = N_Aggregate then
26742 Last_Output := Last (Expressions (Outputs));
26744 -- Create a clause for each output. Note that each time a new
26745 -- clause is created, the original output list slowly shrinks
26746 -- until there is one item left.
26748 Output := First (Expressions (Outputs));
26749 while Present (Output) loop
26750 Next_Output := Next (Output);
26752 -- Unhook the output from the original output list as it
26753 -- will be relocated to a new clause.
26757 -- Special processing for the last output. At this point
26758 -- the original aggregate has been stripped down to one
26759 -- element. Replace the aggregate by the element itself.
26761 if Output = Last_Output then
26762 Rewrite (Outputs, Output);
26765 -- Generate a clause of the form:
26766 -- (Output => Inputs)
26769 Make_Component_Association (Loc,
26770 Choices => New_List (Output),
26771 Expression => New_Copy_Tree (Inputs));
26773 -- The new clause contains replicated content that has
26774 -- already been analyzed. There is not need to reanalyze
26777 Set_Analyzed (New_Clause);
26778 Insert_After (Clause, New_Clause);
26781 Output := Next_Output;
26784 end Normalize_Outputs;
26790 -- Start of processing for Normalize_Clauses
26793 Clause := First (Clauses);
26794 while Present (Clause) loop
26795 Normalize_Outputs (Clause);
26799 Clause := First (Clauses);
26800 while Present (Clause) loop
26801 Normalize_Inputs (Clause);
26804 end Normalize_Clauses;
26806 --------------------------
26807 -- Remove_Extra_Clauses --
26808 --------------------------
26810 procedure Remove_Extra_Clauses
26811 (Clauses : List_Id;
26812 Matched_Items : Elist_Id)
26816 Input_Id : Entity_Id;
26817 Next_Clause : Node_Id;
26819 State_Id : Entity_Id;
26822 Clause := First (Clauses);
26823 while Present (Clause) loop
26824 Next_Clause := Next (Clause);
26826 Input := Expression (Clause);
26827 Output := First (Choices (Clause));
26829 -- Recognize a clause of the form
26833 -- where Input is a constituent of a state which was already
26834 -- successfully matched. This clause must be removed because it
26835 -- simply indicates that some of the constituents of the state
26838 -- Refined_State => (State => (Constit_1, Constit_2))
26839 -- Depends => (Output => State)
26840 -- Refined_Depends => ((Output => Constit_1), -- State matched
26841 -- (null => Constit_2)) -- OK
26843 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26845 -- Handle abstract views generated for limited with clauses
26847 Input_Id := Available_View (Entity_Of (Input));
26849 -- The input must be a constituent of a state
26851 if Ekind (Input_Id) in
26852 E_Abstract_State | E_Constant | E_Variable
26853 and then Present (Encapsulating_State (Input_Id))
26855 State_Id := Encapsulating_State (Input_Id);
26857 -- The state must have a non-null visible refinement and be
26858 -- matched in a previous clause.
26860 if Has_Non_Null_Visible_Refinement (State_Id)
26861 and then Contains (Matched_Items, State_Id)
26867 -- Recognize a clause of the form
26871 -- where Output is an arbitrary item. This clause must be removed
26872 -- because a null input legitimately matches anything.
26874 elsif Nkind (Input) = N_Null then
26878 Clause := Next_Clause;
26880 end Remove_Extra_Clauses;
26882 --------------------------
26883 -- Report_Extra_Clauses --
26884 --------------------------
26886 procedure Report_Extra_Clauses (Clauses : List_Id) is
26890 -- Do not perform this check in an instance because it was already
26891 -- performed successfully in the generic template.
26893 if In_Instance then
26896 elsif Present (Clauses) then
26897 Clause := First (Clauses);
26898 while Present (Clause) loop
26900 ("unmatched or extra clause in dependence refinement",
26906 end Report_Extra_Clauses;
26910 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26911 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26912 Errors : constant Nat := Serious_Errors_Detected;
26919 Body_Inputs : Elist_Id := No_Elist;
26920 Body_Outputs : Elist_Id := No_Elist;
26921 -- The inputs and outputs of the subprogram body synthesized from pragma
26922 -- Refined_Depends.
26924 Dependencies : List_Id := No_List;
26926 -- The corresponding Depends pragma along with its clauses
26928 Matched_Items : Elist_Id := No_Elist;
26929 -- A list containing the entities of all successfully matched items
26930 -- found in pragma Depends.
26932 Refinements : List_Id := No_List;
26933 -- The clauses of pragma Refined_Depends
26935 Spec_Id : Entity_Id;
26936 -- The entity of the subprogram subject to pragma Refined_Depends
26938 Spec_Inputs : Elist_Id := No_Elist;
26939 Spec_Outputs : Elist_Id := No_Elist;
26940 -- The inputs and outputs of the subprogram spec synthesized from pragma
26943 States : Elist_Id := No_Elist;
26944 -- A list containing the entities of all states whose constituents
26945 -- appear in pragma Depends.
26947 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26950 -- Do not analyze the pragma multiple times
26952 if Is_Analyzed_Pragma (N) then
26956 Spec_Id := Unique_Defining_Entity (Body_Decl);
26958 -- Use the anonymous object as the proper spec when Refined_Depends
26959 -- applies to the body of a single task type. The object carries the
26960 -- proper Chars as well as all non-refined versions of pragmas.
26962 if Is_Single_Concurrent_Type (Spec_Id) then
26963 Spec_Id := Anonymous_Object (Spec_Id);
26966 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26968 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26969 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26971 if No (Depends) then
26973 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26974 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26978 Deps := Expression (Get_Argument (Depends, Spec_Id));
26980 -- A null dependency relation renders the refinement useless because it
26981 -- cannot possibly mention abstract states with visible refinement. Note
26982 -- that the inverse is not true as states may be refined to null
26983 -- (SPARK RM 7.2.5(2)).
26985 if Nkind (Deps) = N_Null then
26987 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26988 & "depend on abstract state with visible refinement"), N, Spec_Id);
26992 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26993 -- This ensures that the categorization of all refined dependency items
26994 -- is consistent with their role.
26996 Analyze_Depends_In_Decl_Part (N);
26998 -- Do not match dependencies against refinements if Refined_Depends is
26999 -- illegal to avoid emitting misleading error.
27001 if Serious_Errors_Detected = Errors then
27003 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
27004 -- the inputs and outputs of the subprogram spec and body to verify
27005 -- the use of states with visible refinement and their constituents.
27007 if No (Get_Pragma (Spec_Id, Pragma_Global))
27008 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
27010 Collect_Subprogram_Inputs_Outputs
27011 (Subp_Id => Spec_Id,
27012 Synthesize => True,
27013 Subp_Inputs => Spec_Inputs,
27014 Subp_Outputs => Spec_Outputs,
27015 Global_Seen => Dummy);
27017 Collect_Subprogram_Inputs_Outputs
27018 (Subp_Id => Body_Id,
27019 Synthesize => True,
27020 Subp_Inputs => Body_Inputs,
27021 Subp_Outputs => Body_Outputs,
27022 Global_Seen => Dummy);
27024 -- For an output state with a visible refinement, ensure that all
27025 -- constituents appear as outputs in the dependency refinement.
27027 Check_Output_States
27028 (Spec_Inputs => Spec_Inputs,
27029 Spec_Outputs => Spec_Outputs,
27030 Body_Inputs => Body_Inputs,
27031 Body_Outputs => Body_Outputs);
27034 -- Multiple dependency clauses appear as component associations of an
27035 -- aggregate. Note that the clauses are copied because the algorithm
27036 -- modifies them and this should not be visible in Depends.
27038 pragma Assert (Nkind (Deps) = N_Aggregate);
27039 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
27040 Normalize_Clauses (Dependencies);
27042 -- Gather all states which appear in Depends
27044 States := Collect_States (Dependencies);
27046 Refs := Expression (Get_Argument (N, Spec_Id));
27048 if Nkind (Refs) = N_Null then
27049 Refinements := No_List;
27051 -- Multiple dependency clauses appear as component associations of an
27052 -- aggregate. Note that the clauses are copied because the algorithm
27053 -- modifies them and this should not be visible in Refined_Depends.
27055 else pragma Assert (Nkind (Refs) = N_Aggregate);
27056 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27057 Normalize_Clauses (Refinements);
27060 -- At this point the clauses of pragmas Depends and Refined_Depends
27061 -- have been normalized into simple dependencies between one output
27062 -- and one input. Examine all clauses of pragma Depends looking for
27063 -- matching clauses in pragma Refined_Depends.
27065 Clause := First (Dependencies);
27066 while Present (Clause) loop
27067 Check_Dependency_Clause
27068 (Spec_Id => Spec_Id,
27069 Dep_Clause => Clause,
27070 Dep_States => States,
27071 Refinements => Refinements,
27072 Matched_Items => Matched_Items);
27077 -- Pragma Refined_Depends may contain multiple clarification clauses
27078 -- which indicate that certain constituents do not influence the data
27079 -- flow in any way. Such clauses must be removed as long as the state
27080 -- has been matched, otherwise they will be incorrectly flagged as
27083 -- Refined_State => (State => (Constit_1, Constit_2))
27084 -- Depends => (Output => State)
27085 -- Refined_Depends => ((Output => Constit_1), -- State matched
27086 -- (null => Constit_2)) -- must be removed
27088 Remove_Extra_Clauses (Refinements, Matched_Items);
27090 if Serious_Errors_Detected = Errors then
27091 Report_Extra_Clauses (Refinements);
27096 Set_Is_Analyzed_Pragma (N);
27097 end Analyze_Refined_Depends_In_Decl_Part;
27099 -----------------------------------------
27100 -- Analyze_Refined_Global_In_Decl_Part --
27101 -----------------------------------------
27103 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27105 -- The corresponding Global pragma
27107 Has_In_State : Boolean := False;
27108 Has_In_Out_State : Boolean := False;
27109 Has_Out_State : Boolean := False;
27110 Has_Proof_In_State : Boolean := False;
27111 -- These flags are set when the corresponding Global pragma has a state
27112 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27115 Has_Null_State : Boolean := False;
27116 -- This flag is set when the corresponding Global pragma has at least
27117 -- one state with a null refinement.
27119 In_Constits : Elist_Id := No_Elist;
27120 In_Out_Constits : Elist_Id := No_Elist;
27121 Out_Constits : Elist_Id := No_Elist;
27122 Proof_In_Constits : Elist_Id := No_Elist;
27123 -- These lists contain the entities of all Input, In_Out, Output and
27124 -- Proof_In constituents that appear in Refined_Global and participate
27125 -- in state refinement.
27127 In_Items : Elist_Id := No_Elist;
27128 In_Out_Items : Elist_Id := No_Elist;
27129 Out_Items : Elist_Id := No_Elist;
27130 Proof_In_Items : Elist_Id := No_Elist;
27131 -- These lists contain the entities of all Input, In_Out, Output and
27132 -- Proof_In items defined in the corresponding Global pragma.
27134 Repeat_Items : Elist_Id := No_Elist;
27135 -- A list of all global items without full visible refinement found
27136 -- in pragma Global. These states should be repeated in the global
27137 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27138 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27140 Spec_Id : Entity_Id;
27141 -- The entity of the subprogram subject to pragma Refined_Global
27143 States : Elist_Id := No_Elist;
27144 -- A list of all states with full or partial visible refinement found in
27147 procedure Check_In_Out_States;
27148 -- Determine whether the corresponding Global pragma mentions In_Out
27149 -- states with visible refinement and if so, ensure that one of the
27150 -- following completions apply to the constituents of the state:
27151 -- 1) there is at least one constituent of mode In_Out
27152 -- 2) there is at least one Input and one Output constituent
27153 -- 3) not all constituents are present and one of them is of mode
27155 -- This routine may remove elements from In_Constits, In_Out_Constits,
27156 -- Out_Constits and Proof_In_Constits.
27158 procedure Check_Input_States;
27159 -- Determine whether the corresponding Global pragma mentions Input
27160 -- states with visible refinement and if so, ensure that at least one of
27161 -- its constituents appears as an Input item in Refined_Global.
27162 -- This routine may remove elements from In_Constits, In_Out_Constits,
27163 -- Out_Constits and Proof_In_Constits.
27165 procedure Check_Output_States;
27166 -- Determine whether the corresponding Global pragma mentions Output
27167 -- states with visible refinement and if so, ensure that all of its
27168 -- constituents appear as Output items in Refined_Global.
27169 -- This routine may remove elements from In_Constits, In_Out_Constits,
27170 -- Out_Constits and Proof_In_Constits.
27172 procedure Check_Proof_In_States;
27173 -- Determine whether the corresponding Global pragma mentions Proof_In
27174 -- states with visible refinement and if so, ensure that at least one of
27175 -- its constituents appears as a Proof_In item in Refined_Global.
27176 -- This routine may remove elements from In_Constits, In_Out_Constits,
27177 -- Out_Constits and Proof_In_Constits.
27179 procedure Check_Refined_Global_List
27181 Global_Mode : Name_Id := Name_Input);
27182 -- Verify the legality of a single global list declaration. Global_Mode
27183 -- denotes the current mode in effect.
27185 procedure Collect_Global_Items
27187 Mode : Name_Id := Name_Input);
27188 -- Gather all Input, In_Out, Output and Proof_In items from node List
27189 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27190 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27191 -- and Has_Proof_In_State are set when there is at least one abstract
27192 -- state with full or partial visible refinement available in the
27193 -- corresponding mode. Flag Has_Null_State is set when at least state
27194 -- has a null refinement. Mode denotes the current global mode in
27197 function Present_Then_Remove
27199 Item : Entity_Id) return Boolean;
27200 -- Search List for a particular entity Item. If Item has been found,
27201 -- remove it from List. This routine is used to strip lists In_Constits,
27202 -- In_Out_Constits and Out_Constits of valid constituents.
27204 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27205 -- Same as function Present_Then_Remove, but do not report the presence
27206 -- of Item in List.
27208 procedure Report_Extra_Constituents;
27209 -- Emit an error for each constituent found in lists In_Constits,
27210 -- In_Out_Constits and Out_Constits.
27212 procedure Report_Missing_Items;
27213 -- Emit an error for each global item not repeated found in list
27216 -------------------------
27217 -- Check_In_Out_States --
27218 -------------------------
27220 procedure Check_In_Out_States is
27221 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27222 -- Determine whether one of the following coverage scenarios is in
27224 -- 1) there is at least one constituent of mode In_Out or Output
27225 -- 2) there is at least one pair of constituents with modes Input
27226 -- and Output, or Proof_In and Output.
27227 -- 3) there is at least one constituent of mode Output and not all
27228 -- constituents are present.
27229 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27231 -----------------------------
27232 -- Check_Constituent_Usage --
27233 -----------------------------
27235 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27236 Constits : constant Elist_Id :=
27237 Partial_Refinement_Constituents (State_Id);
27238 Constit_Elmt : Elmt_Id;
27239 Constit_Id : Entity_Id;
27240 Has_Missing : Boolean := False;
27241 In_Out_Seen : Boolean := False;
27242 Input_Seen : Boolean := False;
27243 Output_Seen : Boolean := False;
27244 Proof_In_Seen : Boolean := False;
27247 -- Process all the constituents of the state and note their modes
27248 -- within the global refinement.
27250 if Present (Constits) then
27251 Constit_Elmt := First_Elmt (Constits);
27252 while Present (Constit_Elmt) loop
27253 Constit_Id := Node (Constit_Elmt);
27255 if Present_Then_Remove (In_Constits, Constit_Id) then
27256 Input_Seen := True;
27258 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27259 In_Out_Seen := True;
27261 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27262 Output_Seen := True;
27264 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27266 Proof_In_Seen := True;
27269 Has_Missing := True;
27272 Next_Elmt (Constit_Elmt);
27276 -- An In_Out constituent is a valid completion
27278 if In_Out_Seen then
27281 -- A pair of one Input/Proof_In and one Output constituent is a
27282 -- valid completion.
27284 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27287 elsif Output_Seen then
27289 -- A single Output constituent is a valid completion only when
27290 -- some of the other constituents are missing.
27292 if Has_Missing then
27295 -- Otherwise all constituents are of mode Output
27299 ("global refinement of state & must include at least one "
27300 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27304 -- The state lacks a completion. When full refinement is visible,
27305 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27306 -- refinement is visible, emit an error if the abstract state
27307 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27308 -- both are utilized, Check_State_And_Constituent_Use. will issue
27311 elsif not Input_Seen
27312 and then not In_Out_Seen
27313 and then not Output_Seen
27314 and then not Proof_In_Seen
27316 if Has_Visible_Refinement (State_Id)
27317 or else Contains (Repeat_Items, State_Id)
27320 ("missing global refinement of state &", N, State_Id);
27323 -- Otherwise the state has a malformed completion where at least
27324 -- one of the constituents has a different mode.
27328 ("global refinement of state & redefines the mode of its "
27329 & "constituents", N, State_Id);
27331 end Check_Constituent_Usage;
27335 Item_Elmt : Elmt_Id;
27336 Item_Id : Entity_Id;
27338 -- Start of processing for Check_In_Out_States
27341 -- Do not perform this check in an instance because it was already
27342 -- performed successfully in the generic template.
27344 if In_Instance then
27347 -- Inspect the In_Out items of the corresponding Global pragma
27348 -- looking for a state with a visible refinement.
27350 elsif Has_In_Out_State and then Present (In_Out_Items) then
27351 Item_Elmt := First_Elmt (In_Out_Items);
27352 while Present (Item_Elmt) loop
27353 Item_Id := Node (Item_Elmt);
27355 -- Ensure that one of the three coverage variants is satisfied
27357 if Ekind (Item_Id) = E_Abstract_State
27358 and then Has_Non_Null_Visible_Refinement (Item_Id)
27360 Check_Constituent_Usage (Item_Id);
27363 Next_Elmt (Item_Elmt);
27366 end Check_In_Out_States;
27368 ------------------------
27369 -- Check_Input_States --
27370 ------------------------
27372 procedure Check_Input_States is
27373 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27374 -- Determine whether at least one constituent of state State_Id with
27375 -- full or partial visible refinement is used and has mode Input.
27376 -- Ensure that the remaining constituents do not have In_Out or
27377 -- Output modes. Emit an error if this is not the case
27378 -- (SPARK RM 7.2.4(5)).
27380 -----------------------------
27381 -- Check_Constituent_Usage --
27382 -----------------------------
27384 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27385 Constits : constant Elist_Id :=
27386 Partial_Refinement_Constituents (State_Id);
27387 Constit_Elmt : Elmt_Id;
27388 Constit_Id : Entity_Id;
27389 In_Seen : Boolean := False;
27392 if Present (Constits) then
27393 Constit_Elmt := First_Elmt (Constits);
27394 while Present (Constit_Elmt) loop
27395 Constit_Id := Node (Constit_Elmt);
27397 -- At least one of the constituents appears as an Input
27399 if Present_Then_Remove (In_Constits, Constit_Id) then
27402 -- A Proof_In constituent can refine an Input state as long
27403 -- as there is at least one Input constituent present.
27405 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27409 -- The constituent appears in the global refinement, but has
27410 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27412 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27413 or else Present_Then_Remove (Out_Constits, Constit_Id)
27415 Error_Msg_Name_1 := Chars (State_Id);
27417 ("constituent & of state % must have mode `Input` in "
27418 & "global refinement", N, Constit_Id);
27421 Next_Elmt (Constit_Elmt);
27425 -- Not one of the constituents appeared as Input. Always emit an
27426 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27427 -- When only partial refinement is visible, emit an error if the
27428 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27429 -- the case where both are utilized, an error will be issued in
27430 -- Check_State_And_Constituent_Use.
27433 and then (Has_Visible_Refinement (State_Id)
27434 or else Contains (Repeat_Items, State_Id))
27437 ("global refinement of state & must include at least one "
27438 & "constituent of mode `Input`", N, State_Id);
27440 end Check_Constituent_Usage;
27444 Item_Elmt : Elmt_Id;
27445 Item_Id : Entity_Id;
27447 -- Start of processing for Check_Input_States
27450 -- Do not perform this check in an instance because it was already
27451 -- performed successfully in the generic template.
27453 if In_Instance then
27456 -- Inspect the Input items of the corresponding Global pragma looking
27457 -- for a state with a visible refinement.
27459 elsif Has_In_State and then Present (In_Items) then
27460 Item_Elmt := First_Elmt (In_Items);
27461 while Present (Item_Elmt) loop
27462 Item_Id := Node (Item_Elmt);
27464 -- When full refinement is visible, ensure that at least one of
27465 -- the constituents is utilized and is of mode Input. When only
27466 -- partial refinement is visible, ensure that either one of
27467 -- the constituents is utilized and is of mode Input, or the
27468 -- abstract state is repeated and no constituent is utilized.
27470 if Ekind (Item_Id) = E_Abstract_State
27471 and then Has_Non_Null_Visible_Refinement (Item_Id)
27473 Check_Constituent_Usage (Item_Id);
27476 Next_Elmt (Item_Elmt);
27479 end Check_Input_States;
27481 -------------------------
27482 -- Check_Output_States --
27483 -------------------------
27485 procedure Check_Output_States is
27486 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27487 -- Determine whether all constituents of state State_Id with full
27488 -- visible refinement are used and have mode Output. Emit an error
27489 -- if this is not the case (SPARK RM 7.2.4(5)).
27491 -----------------------------
27492 -- Check_Constituent_Usage --
27493 -----------------------------
27495 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27496 Constits : constant Elist_Id :=
27497 Partial_Refinement_Constituents (State_Id);
27498 Only_Partial : constant Boolean :=
27499 not Has_Visible_Refinement (State_Id);
27500 Constit_Elmt : Elmt_Id;
27501 Constit_Id : Entity_Id;
27502 Posted : Boolean := False;
27505 if Present (Constits) then
27506 Constit_Elmt := First_Elmt (Constits);
27507 while Present (Constit_Elmt) loop
27508 Constit_Id := Node (Constit_Elmt);
27510 -- Issue an error when a constituent of State_Id is utilized
27511 -- and State_Id has only partial visible refinement
27512 -- (SPARK RM 7.2.4(3d)).
27514 if Only_Partial then
27515 if Present_Then_Remove (Out_Constits, Constit_Id)
27516 or else Present_Then_Remove (In_Constits, Constit_Id)
27518 Present_Then_Remove (In_Out_Constits, Constit_Id)
27520 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27522 Error_Msg_Name_1 := Chars (State_Id);
27524 ("constituent & of state % cannot be used in global "
27525 & "refinement", N, Constit_Id);
27526 Error_Msg_Name_1 := Chars (State_Id);
27527 SPARK_Msg_N ("\use state % instead", N);
27530 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27533 -- The constituent appears in the global refinement, but has
27534 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27536 elsif Present_Then_Remove (In_Constits, Constit_Id)
27537 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27538 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27540 Error_Msg_Name_1 := Chars (State_Id);
27542 ("constituent & of state % must have mode `Output` in "
27543 & "global refinement", N, Constit_Id);
27545 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27551 ("`Output` state & must be replaced by all its "
27552 & "constituents in global refinement", N, State_Id);
27556 ("\constituent & is missing in output list",
27560 Next_Elmt (Constit_Elmt);
27563 end Check_Constituent_Usage;
27567 Item_Elmt : Elmt_Id;
27568 Item_Id : Entity_Id;
27570 -- Start of processing for Check_Output_States
27573 -- Do not perform this check in an instance because it was already
27574 -- performed successfully in the generic template.
27576 if In_Instance then
27579 -- Inspect the Output items of the corresponding Global pragma
27580 -- looking for a state with a visible refinement.
27582 elsif Has_Out_State and then Present (Out_Items) then
27583 Item_Elmt := First_Elmt (Out_Items);
27584 while Present (Item_Elmt) loop
27585 Item_Id := Node (Item_Elmt);
27587 -- When full refinement is visible, ensure that all of the
27588 -- constituents are utilized and they have mode Output. When
27589 -- only partial refinement is visible, ensure that no
27590 -- constituent is utilized.
27592 if Ekind (Item_Id) = E_Abstract_State
27593 and then Has_Non_Null_Visible_Refinement (Item_Id)
27595 Check_Constituent_Usage (Item_Id);
27598 Next_Elmt (Item_Elmt);
27601 end Check_Output_States;
27603 ---------------------------
27604 -- Check_Proof_In_States --
27605 ---------------------------
27607 procedure Check_Proof_In_States is
27608 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27609 -- Determine whether at least one constituent of state State_Id with
27610 -- full or partial visible refinement is used and has mode Proof_In.
27611 -- Ensure that the remaining constituents do not have Input, In_Out,
27612 -- or Output modes. Emit an error if this is not the case
27613 -- (SPARK RM 7.2.4(5)).
27615 -----------------------------
27616 -- Check_Constituent_Usage --
27617 -----------------------------
27619 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27620 Constits : constant Elist_Id :=
27621 Partial_Refinement_Constituents (State_Id);
27622 Constit_Elmt : Elmt_Id;
27623 Constit_Id : Entity_Id;
27624 Proof_In_Seen : Boolean := False;
27627 if Present (Constits) then
27628 Constit_Elmt := First_Elmt (Constits);
27629 while Present (Constit_Elmt) loop
27630 Constit_Id := Node (Constit_Elmt);
27632 -- At least one of the constituents appears as Proof_In
27634 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27635 Proof_In_Seen := True;
27637 -- The constituent appears in the global refinement, but has
27638 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27640 elsif Present_Then_Remove (In_Constits, Constit_Id)
27641 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27642 or else Present_Then_Remove (Out_Constits, Constit_Id)
27644 Error_Msg_Name_1 := Chars (State_Id);
27646 ("constituent & of state % must have mode `Proof_In` "
27647 & "in global refinement", N, Constit_Id);
27650 Next_Elmt (Constit_Elmt);
27654 -- Not one of the constituents appeared as Proof_In. Always emit
27655 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27656 -- When only partial refinement is visible, emit an error if the
27657 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27658 -- the case where both are utilized, an error will be issued by
27659 -- Check_State_And_Constituent_Use.
27661 if not Proof_In_Seen
27662 and then (Has_Visible_Refinement (State_Id)
27663 or else Contains (Repeat_Items, State_Id))
27666 ("global refinement of state & must include at least one "
27667 & "constituent of mode `Proof_In`", N, State_Id);
27669 end Check_Constituent_Usage;
27673 Item_Elmt : Elmt_Id;
27674 Item_Id : Entity_Id;
27676 -- Start of processing for Check_Proof_In_States
27679 -- Do not perform this check in an instance because it was already
27680 -- performed successfully in the generic template.
27682 if In_Instance then
27685 -- Inspect the Proof_In items of the corresponding Global pragma
27686 -- looking for a state with a visible refinement.
27688 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27689 Item_Elmt := First_Elmt (Proof_In_Items);
27690 while Present (Item_Elmt) loop
27691 Item_Id := Node (Item_Elmt);
27693 -- Ensure that at least one of the constituents is utilized
27694 -- and is of mode Proof_In. When only partial refinement is
27695 -- visible, ensure that either one of the constituents is
27696 -- utilized and is of mode Proof_In, or the abstract state
27697 -- is repeated and no constituent is utilized.
27699 if Ekind (Item_Id) = E_Abstract_State
27700 and then Has_Non_Null_Visible_Refinement (Item_Id)
27702 Check_Constituent_Usage (Item_Id);
27705 Next_Elmt (Item_Elmt);
27708 end Check_Proof_In_States;
27710 -------------------------------
27711 -- Check_Refined_Global_List --
27712 -------------------------------
27714 procedure Check_Refined_Global_List
27716 Global_Mode : Name_Id := Name_Input)
27718 procedure Check_Refined_Global_Item
27720 Global_Mode : Name_Id);
27721 -- Verify the legality of a single global item declaration. Parameter
27722 -- Global_Mode denotes the current mode in effect.
27724 -------------------------------
27725 -- Check_Refined_Global_Item --
27726 -------------------------------
27728 procedure Check_Refined_Global_Item
27730 Global_Mode : Name_Id)
27732 Item_Id : constant Entity_Id := Entity_Of (Item);
27734 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27735 -- Issue a common error message for all mode mismatches. Expect
27736 -- denotes the expected mode.
27738 -----------------------------
27739 -- Inconsistent_Mode_Error --
27740 -----------------------------
27742 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27745 ("global item & has inconsistent modes", Item, Item_Id);
27747 Error_Msg_Name_1 := Global_Mode;
27748 Error_Msg_Name_2 := Expect;
27749 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27750 end Inconsistent_Mode_Error;
27754 Enc_State : Entity_Id := Empty;
27755 -- Encapsulating state for constituent, Empty otherwise
27757 -- Start of processing for Check_Refined_Global_Item
27760 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
27762 Enc_State := Find_Encapsulating_State (States, Item_Id);
27765 -- When the state or object acts as a constituent of another
27766 -- state with a visible refinement, collect it for the state
27767 -- completeness checks performed later on. Note that the item
27768 -- acts as a constituent only when the encapsulating state is
27769 -- present in pragma Global.
27771 if Present (Enc_State)
27772 and then (Has_Visible_Refinement (Enc_State)
27773 or else Has_Partial_Visible_Refinement (Enc_State))
27774 and then Contains (States, Enc_State)
27776 -- If the state has only partial visible refinement, remove it
27777 -- from the list of items that should be repeated from pragma
27780 if not Has_Visible_Refinement (Enc_State) then
27781 Present_Then_Remove (Repeat_Items, Enc_State);
27784 if Global_Mode = Name_Input then
27785 Append_New_Elmt (Item_Id, In_Constits);
27787 elsif Global_Mode = Name_In_Out then
27788 Append_New_Elmt (Item_Id, In_Out_Constits);
27790 elsif Global_Mode = Name_Output then
27791 Append_New_Elmt (Item_Id, Out_Constits);
27793 elsif Global_Mode = Name_Proof_In then
27794 Append_New_Elmt (Item_Id, Proof_In_Constits);
27797 -- When not a constituent, ensure that both occurrences of the
27798 -- item in pragmas Global and Refined_Global match. Also remove
27799 -- it when present from the list of items that should be repeated
27800 -- from pragma Global.
27803 Present_Then_Remove (Repeat_Items, Item_Id);
27805 if Contains (In_Items, Item_Id) then
27806 if Global_Mode /= Name_Input then
27807 Inconsistent_Mode_Error (Name_Input);
27810 elsif Contains (In_Out_Items, Item_Id) then
27811 if Global_Mode /= Name_In_Out then
27812 Inconsistent_Mode_Error (Name_In_Out);
27815 elsif Contains (Out_Items, Item_Id) then
27816 if Global_Mode /= Name_Output then
27817 Inconsistent_Mode_Error (Name_Output);
27820 elsif Contains (Proof_In_Items, Item_Id) then
27823 -- The item does not appear in the corresponding Global pragma,
27824 -- it must be an extra (SPARK RM 7.2.4(3)).
27827 pragma Assert (Present (Global));
27828 Error_Msg_Sloc := Sloc (Global);
27830 ("extra global item & does not refine or repeat any "
27831 & "global item #", Item, Item_Id);
27834 end Check_Refined_Global_Item;
27840 -- Start of processing for Check_Refined_Global_List
27843 -- Do not perform this check in an instance because it was already
27844 -- performed successfully in the generic template.
27846 if In_Instance then
27849 elsif Nkind (List) = N_Null then
27852 -- Single global item declaration
27854 elsif Nkind (List) in N_Expanded_Name
27856 | N_Selected_Component
27858 Check_Refined_Global_Item (List, Global_Mode);
27860 -- Simple global list or moded global list declaration
27862 elsif Nkind (List) = N_Aggregate then
27864 -- The declaration of a simple global list appear as a collection
27867 if Present (Expressions (List)) then
27868 Item := First (Expressions (List));
27869 while Present (Item) loop
27870 Check_Refined_Global_Item (Item, Global_Mode);
27874 -- The declaration of a moded global list appears as a collection
27875 -- of component associations where individual choices denote
27878 elsif Present (Component_Associations (List)) then
27879 Item := First (Component_Associations (List));
27880 while Present (Item) loop
27881 Check_Refined_Global_List
27882 (List => Expression (Item),
27883 Global_Mode => Chars (First (Choices (Item))));
27891 raise Program_Error;
27897 raise Program_Error;
27899 end Check_Refined_Global_List;
27901 --------------------------
27902 -- Collect_Global_Items --
27903 --------------------------
27905 procedure Collect_Global_Items
27907 Mode : Name_Id := Name_Input)
27909 procedure Collect_Global_Item
27911 Item_Mode : Name_Id);
27912 -- Add a single item to the appropriate list. Item_Mode denotes the
27913 -- current mode in effect.
27915 -------------------------
27916 -- Collect_Global_Item --
27917 -------------------------
27919 procedure Collect_Global_Item
27921 Item_Mode : Name_Id)
27923 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27924 -- The above handles abstract views of variables and states built
27925 -- for limited with clauses.
27928 -- Signal that the global list contains at least one abstract
27929 -- state with a visible refinement. Note that the refinement may
27930 -- be null in which case there are no constituents.
27932 if Ekind (Item_Id) = E_Abstract_State then
27933 if Has_Null_Visible_Refinement (Item_Id) then
27934 Has_Null_State := True;
27936 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27937 Append_New_Elmt (Item_Id, States);
27939 if Item_Mode = Name_Input then
27940 Has_In_State := True;
27941 elsif Item_Mode = Name_In_Out then
27942 Has_In_Out_State := True;
27943 elsif Item_Mode = Name_Output then
27944 Has_Out_State := True;
27945 elsif Item_Mode = Name_Proof_In then
27946 Has_Proof_In_State := True;
27951 -- Record global items without full visible refinement found in
27952 -- pragma Global which should be repeated in the global refinement
27953 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27955 if Ekind (Item_Id) /= E_Abstract_State
27956 or else not Has_Visible_Refinement (Item_Id)
27958 Append_New_Elmt (Item_Id, Repeat_Items);
27961 -- Add the item to the proper list
27963 if Item_Mode = Name_Input then
27964 Append_New_Elmt (Item_Id, In_Items);
27965 elsif Item_Mode = Name_In_Out then
27966 Append_New_Elmt (Item_Id, In_Out_Items);
27967 elsif Item_Mode = Name_Output then
27968 Append_New_Elmt (Item_Id, Out_Items);
27969 elsif Item_Mode = Name_Proof_In then
27970 Append_New_Elmt (Item_Id, Proof_In_Items);
27972 end Collect_Global_Item;
27978 -- Start of processing for Collect_Global_Items
27981 if Nkind (List) = N_Null then
27984 -- Single global item declaration
27986 elsif Nkind (List) in N_Expanded_Name
27988 | N_Selected_Component
27990 Collect_Global_Item (List, Mode);
27992 -- Single global list or moded global list declaration
27994 elsif Nkind (List) = N_Aggregate then
27996 -- The declaration of a simple global list appear as a collection
27999 if Present (Expressions (List)) then
28000 Item := First (Expressions (List));
28001 while Present (Item) loop
28002 Collect_Global_Item (Item, Mode);
28006 -- The declaration of a moded global list appears as a collection
28007 -- of component associations where individual choices denote mode.
28009 elsif Present (Component_Associations (List)) then
28010 Item := First (Component_Associations (List));
28011 while Present (Item) loop
28012 Collect_Global_Items
28013 (List => Expression (Item),
28014 Mode => Chars (First (Choices (Item))));
28022 raise Program_Error;
28025 -- To accommodate partial decoration of disabled SPARK features, this
28026 -- routine may be called with illegal input. If this is the case, do
28027 -- not raise Program_Error.
28032 end Collect_Global_Items;
28034 -------------------------
28035 -- Present_Then_Remove --
28036 -------------------------
28038 function Present_Then_Remove
28040 Item : Entity_Id) return Boolean
28045 if Present (List) then
28046 Elmt := First_Elmt (List);
28047 while Present (Elmt) loop
28048 if Node (Elmt) = Item then
28049 Remove_Elmt (List, Elmt);
28058 end Present_Then_Remove;
28060 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28063 Ignore := Present_Then_Remove (List, Item);
28064 end Present_Then_Remove;
28066 -------------------------------
28067 -- Report_Extra_Constituents --
28068 -------------------------------
28070 procedure Report_Extra_Constituents is
28071 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28072 -- Emit an error for every element of List
28074 ---------------------------------------
28075 -- Report_Extra_Constituents_In_List --
28076 ---------------------------------------
28078 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28079 Constit_Elmt : Elmt_Id;
28082 if Present (List) then
28083 Constit_Elmt := First_Elmt (List);
28084 while Present (Constit_Elmt) loop
28085 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28086 Next_Elmt (Constit_Elmt);
28089 end Report_Extra_Constituents_In_List;
28091 -- Start of processing for Report_Extra_Constituents
28094 -- Do not perform this check in an instance because it was already
28095 -- performed successfully in the generic template.
28097 if In_Instance then
28101 Report_Extra_Constituents_In_List (In_Constits);
28102 Report_Extra_Constituents_In_List (In_Out_Constits);
28103 Report_Extra_Constituents_In_List (Out_Constits);
28104 Report_Extra_Constituents_In_List (Proof_In_Constits);
28106 end Report_Extra_Constituents;
28108 --------------------------
28109 -- Report_Missing_Items --
28110 --------------------------
28112 procedure Report_Missing_Items is
28113 Item_Elmt : Elmt_Id;
28114 Item_Id : Entity_Id;
28117 -- Do not perform this check in an instance because it was already
28118 -- performed successfully in the generic template.
28120 if In_Instance then
28124 if Present (Repeat_Items) then
28125 Item_Elmt := First_Elmt (Repeat_Items);
28126 while Present (Item_Elmt) loop
28127 Item_Id := Node (Item_Elmt);
28128 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28129 Next_Elmt (Item_Elmt);
28133 end Report_Missing_Items;
28137 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28138 Errors : constant Nat := Serious_Errors_Detected;
28140 No_Constit : Boolean;
28142 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28145 -- Do not analyze the pragma multiple times
28147 if Is_Analyzed_Pragma (N) then
28151 Spec_Id := Unique_Defining_Entity (Body_Decl);
28153 -- Use the anonymous object as the proper spec when Refined_Global
28154 -- applies to the body of a single task type. The object carries the
28155 -- proper Chars as well as all non-refined versions of pragmas.
28157 if Is_Single_Concurrent_Type (Spec_Id) then
28158 Spec_Id := Anonymous_Object (Spec_Id);
28161 Global := Get_Pragma (Spec_Id, Pragma_Global);
28162 Items := Expression (Get_Argument (N, Spec_Id));
28164 -- The subprogram declaration lacks pragma Global. This renders
28165 -- Refined_Global useless as there is nothing to refine.
28167 if No (Global) then
28169 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28170 & "& lacks aspect or pragma Global"), N, Spec_Id);
28174 -- Extract all relevant items from the corresponding Global pragma
28176 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28178 -- Package and subprogram bodies are instantiated individually in
28179 -- a separate compiler pass. Due to this mode of instantiation, the
28180 -- refinement of a state may no longer be visible when a subprogram
28181 -- body contract is instantiated. Since the generic template is legal,
28182 -- do not perform this check in the instance to circumvent this oddity.
28184 if In_Instance then
28187 -- Non-instance case
28190 -- The corresponding Global pragma must mention at least one
28191 -- state with a visible refinement at the point Refined_Global
28192 -- is processed. States with null refinements need Refined_Global
28193 -- pragma (SPARK RM 7.2.4(2)).
28195 if not Has_In_State
28196 and then not Has_In_Out_State
28197 and then not Has_Out_State
28198 and then not Has_Proof_In_State
28199 and then not Has_Null_State
28202 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28203 & "depend on abstract state with visible refinement"),
28207 -- The global refinement of inputs and outputs cannot be null when
28208 -- the corresponding Global pragma contains at least one item except
28209 -- in the case where we have states with null refinements.
28211 elsif Nkind (Items) = N_Null
28213 (Present (In_Items)
28214 or else Present (In_Out_Items)
28215 or else Present (Out_Items)
28216 or else Present (Proof_In_Items))
28217 and then not Has_Null_State
28220 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28221 & "global items"), N, Spec_Id);
28226 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28227 -- This ensures that the categorization of all refined global items is
28228 -- consistent with their role.
28230 Analyze_Global_In_Decl_Part (N);
28232 -- Perform all refinement checks with respect to completeness and mode
28235 if Serious_Errors_Detected = Errors then
28236 Check_Refined_Global_List (Items);
28239 -- Store the information that no constituent is used in the global
28240 -- refinement, prior to calling checking procedures which remove items
28241 -- from the list of constituents.
28245 and then No (In_Out_Constits)
28246 and then No (Out_Constits)
28247 and then No (Proof_In_Constits);
28249 -- For Input states with visible refinement, at least one constituent
28250 -- must be used as an Input in the global refinement.
28252 if Serious_Errors_Detected = Errors then
28253 Check_Input_States;
28256 -- Verify all possible completion variants for In_Out states with
28257 -- visible refinement.
28259 if Serious_Errors_Detected = Errors then
28260 Check_In_Out_States;
28263 -- For Output states with visible refinement, all constituents must be
28264 -- used as Outputs in the global refinement.
28266 if Serious_Errors_Detected = Errors then
28267 Check_Output_States;
28270 -- For Proof_In states with visible refinement, at least one constituent
28271 -- must be used as Proof_In in the global refinement.
28273 if Serious_Errors_Detected = Errors then
28274 Check_Proof_In_States;
28277 -- Emit errors for all constituents that belong to other states with
28278 -- visible refinement that do not appear in Global.
28280 if Serious_Errors_Detected = Errors then
28281 Report_Extra_Constituents;
28284 -- Emit errors for all items in Global that are not repeated in the
28285 -- global refinement and for which there is no full visible refinement
28286 -- and, in the case of states with partial visible refinement, no
28287 -- constituent is mentioned in the global refinement.
28289 if Serious_Errors_Detected = Errors then
28290 Report_Missing_Items;
28293 -- Emit an error if no constituent is used in the global refinement
28294 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28295 -- one may be issued by the checking procedures. Do not perform this
28296 -- check in an instance because it was already performed successfully
28297 -- in the generic template.
28299 if Serious_Errors_Detected = Errors
28300 and then not In_Instance
28301 and then not Has_Null_State
28302 and then No_Constit
28304 SPARK_Msg_N ("missing refinement", N);
28308 Set_Is_Analyzed_Pragma (N);
28309 end Analyze_Refined_Global_In_Decl_Part;
28311 ----------------------------------------
28312 -- Analyze_Refined_State_In_Decl_Part --
28313 ----------------------------------------
28315 procedure Analyze_Refined_State_In_Decl_Part
28317 Freeze_Id : Entity_Id := Empty)
28319 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28320 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28321 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28323 Available_States : Elist_Id := No_Elist;
28324 -- A list of all abstract states defined in the package declaration that
28325 -- are available for refinement. The list is used to report unrefined
28328 Body_States : Elist_Id := No_Elist;
28329 -- A list of all hidden states that appear in the body of the related
28330 -- package. The list is used to report unused hidden states.
28332 Constituents_Seen : Elist_Id := No_Elist;
28333 -- A list that contains all constituents processed so far. The list is
28334 -- used to detect multiple uses of the same constituent.
28336 Freeze_Posted : Boolean := False;
28337 -- A flag that controls the output of a freezing-related error (see use
28340 Refined_States_Seen : Elist_Id := No_Elist;
28341 -- A list that contains all refined states processed so far. The list is
28342 -- used to detect duplicate refinements.
28344 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28345 -- Perform full analysis of a single refinement clause
28347 procedure Report_Unrefined_States (States : Elist_Id);
28348 -- Emit errors for all unrefined abstract states found in list States
28350 -------------------------------
28351 -- Analyze_Refinement_Clause --
28352 -------------------------------
28354 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28355 AR_Constit : Entity_Id := Empty;
28356 AW_Constit : Entity_Id := Empty;
28357 ER_Constit : Entity_Id := Empty;
28358 EW_Constit : Entity_Id := Empty;
28359 -- The entities of external constituents that contain one of the
28360 -- following enabled properties: Async_Readers, Async_Writers,
28361 -- Effective_Reads and Effective_Writes.
28363 External_Constit_Seen : Boolean := False;
28364 -- Flag used to mark when at least one external constituent is part
28365 -- of the state refinement.
28367 Non_Null_Seen : Boolean := False;
28368 Null_Seen : Boolean := False;
28369 -- Flags used to detect multiple uses of null in a single clause or a
28370 -- mixture of null and non-null constituents.
28372 Part_Of_Constits : Elist_Id := No_Elist;
28373 -- A list of all candidate constituents subject to indicator Part_Of
28374 -- where the encapsulating state is the current state.
28377 State_Id : Entity_Id;
28378 -- The current state being refined
28380 procedure Analyze_Constituent (Constit : Node_Id);
28381 -- Perform full analysis of a single constituent
28383 procedure Check_External_Property
28384 (Prop_Nam : Name_Id;
28386 Constit : Entity_Id);
28387 -- Determine whether a property denoted by name Prop_Nam is present
28388 -- in the refined state. Emit an error if this is not the case. Flag
28389 -- Enabled should be set when the property applies to the refined
28390 -- state. Constit denotes the constituent (if any) which introduces
28391 -- the property in the refinement.
28393 procedure Match_State;
28394 -- Determine whether the state being refined appears in list
28395 -- Available_States. Emit an error when attempting to re-refine the
28396 -- state or when the state is not defined in the package declaration,
28397 -- otherwise remove the state from Available_States.
28399 procedure Report_Unused_Constituents (Constits : Elist_Id);
28400 -- Emit errors for all unused Part_Of constituents in list Constits
28402 -------------------------
28403 -- Analyze_Constituent --
28404 -------------------------
28406 procedure Analyze_Constituent (Constit : Node_Id) is
28407 procedure Match_Constituent (Constit_Id : Entity_Id);
28408 -- Determine whether constituent Constit denoted by its entity
28409 -- Constit_Id appears in Body_States. Emit an error when the
28410 -- constituent is not a valid hidden state of the related package
28411 -- or when it is used more than once. Otherwise remove the
28412 -- constituent from Body_States.
28414 -----------------------
28415 -- Match_Constituent --
28416 -----------------------
28418 procedure Match_Constituent (Constit_Id : Entity_Id) is
28419 procedure Collect_Constituent;
28420 -- Verify the legality of constituent Constit_Id and add it to
28421 -- the refinements of State_Id.
28423 -------------------------
28424 -- Collect_Constituent --
28425 -------------------------
28427 procedure Collect_Constituent is
28428 Constits : Elist_Id;
28431 -- The Ghost policy in effect at the point of abstract state
28432 -- declaration and constituent must match (SPARK RM 6.9(15))
28434 Check_Ghost_Refinement
28435 (State, State_Id, Constit, Constit_Id);
28437 -- A synchronized state must be refined by a synchronized
28438 -- object or another synchronized state (SPARK RM 9.6).
28440 if Is_Synchronized_State (State_Id)
28441 and then not Is_Synchronized_Object (Constit_Id)
28442 and then not Is_Synchronized_State (Constit_Id)
28445 ("constituent of synchronized state & must be "
28446 & "synchronized", Constit, State_Id);
28449 -- Add the constituent to the list of processed items to aid
28450 -- with the detection of duplicates.
28452 Append_New_Elmt (Constit_Id, Constituents_Seen);
28454 -- Collect the constituent in the list of refinement items
28455 -- and establish a relation between the refined state and
28458 Constits := Refinement_Constituents (State_Id);
28460 if No (Constits) then
28461 Constits := New_Elmt_List;
28462 Set_Refinement_Constituents (State_Id, Constits);
28465 Append_Elmt (Constit_Id, Constits);
28466 Set_Encapsulating_State (Constit_Id, State_Id);
28468 -- The state has at least one legal constituent, mark the
28469 -- start of the refinement region. The region ends when the
28470 -- body declarations end (see routine Analyze_Declarations).
28472 Set_Has_Visible_Refinement (State_Id);
28474 -- When the constituent is external, save its relevant
28475 -- property for further checks.
28477 if Async_Readers_Enabled (Constit_Id) then
28478 AR_Constit := Constit_Id;
28479 External_Constit_Seen := True;
28482 if Async_Writers_Enabled (Constit_Id) then
28483 AW_Constit := Constit_Id;
28484 External_Constit_Seen := True;
28487 if Effective_Reads_Enabled (Constit_Id) then
28488 ER_Constit := Constit_Id;
28489 External_Constit_Seen := True;
28492 if Effective_Writes_Enabled (Constit_Id) then
28493 EW_Constit := Constit_Id;
28494 External_Constit_Seen := True;
28496 end Collect_Constituent;
28500 State_Elmt : Elmt_Id;
28502 -- Start of processing for Match_Constituent
28505 -- Detect a duplicate use of a constituent
28507 if Contains (Constituents_Seen, Constit_Id) then
28509 ("duplicate use of constituent &", Constit, Constit_Id);
28513 -- The constituent is subject to a Part_Of indicator
28515 if Present (Encapsulating_State (Constit_Id)) then
28516 if Encapsulating_State (Constit_Id) = State_Id then
28517 Remove (Part_Of_Constits, Constit_Id);
28518 Collect_Constituent;
28520 -- The constituent is part of another state and is used
28521 -- incorrectly in the refinement of the current state.
28524 Error_Msg_Name_1 := Chars (State_Id);
28526 ("& cannot act as constituent of state %",
28527 Constit, Constit_Id);
28529 ("\Part_Of indicator specifies encapsulator &",
28530 Constit, Encapsulating_State (Constit_Id));
28533 -- The only other source of legal constituents is the body
28534 -- state space of the related package.
28537 if Present (Body_States) then
28538 State_Elmt := First_Elmt (Body_States);
28539 while Present (State_Elmt) loop
28541 -- Consume a valid constituent to signal that it has
28542 -- been encountered.
28544 if Node (State_Elmt) = Constit_Id then
28545 Remove_Elmt (Body_States, State_Elmt);
28546 Collect_Constituent;
28550 Next_Elmt (State_Elmt);
28554 -- At this point it is known that the constituent is not
28555 -- part of the package hidden state and cannot be used in
28556 -- a refinement (SPARK RM 7.2.2(9)).
28558 Error_Msg_Name_1 := Chars (Spec_Id);
28560 ("cannot use & in refinement, constituent is not a hidden "
28561 & "state of package %", Constit, Constit_Id);
28563 end Match_Constituent;
28567 Constit_Id : Entity_Id;
28568 Constits : Elist_Id;
28570 -- Start of processing for Analyze_Constituent
28573 -- Detect multiple uses of null in a single refinement clause or a
28574 -- mixture of null and non-null constituents.
28576 if Nkind (Constit) = N_Null then
28579 ("multiple null constituents not allowed", Constit);
28581 elsif Non_Null_Seen then
28583 ("cannot mix null and non-null constituents", Constit);
28588 -- Collect the constituent in the list of refinement items
28590 Constits := Refinement_Constituents (State_Id);
28592 if No (Constits) then
28593 Constits := New_Elmt_List;
28594 Set_Refinement_Constituents (State_Id, Constits);
28597 Append_Elmt (Constit, Constits);
28599 -- The state has at least one legal constituent, mark the
28600 -- start of the refinement region. The region ends when the
28601 -- body declarations end (see Analyze_Declarations).
28603 Set_Has_Visible_Refinement (State_Id);
28606 -- Non-null constituents
28609 Non_Null_Seen := True;
28613 ("cannot mix null and non-null constituents", Constit);
28617 Resolve_State (Constit);
28619 -- Ensure that the constituent denotes a valid state or a
28620 -- whole object (SPARK RM 7.2.2(5)).
28622 if Is_Entity_Name (Constit) then
28623 Constit_Id := Entity_Of (Constit);
28625 -- When a constituent is declared after a subprogram body
28626 -- that caused freezing of the related contract where
28627 -- pragma Refined_State resides, the constituent appears
28628 -- undefined and carries Any_Id as its entity.
28630 -- package body Pack
28631 -- with Refined_State => (State => Constit)
28634 -- with Refined_Global => (Input => Constit)
28642 if Constit_Id = Any_Id then
28643 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28645 -- Emit a specialized info message when the contract of
28646 -- the related package body was "frozen" by another body.
28647 -- Note that it is not possible to precisely identify why
28648 -- the constituent is undefined because it is not visible
28649 -- when pragma Refined_State is analyzed. This message is
28650 -- a reasonable approximation.
28652 if Present (Freeze_Id) and then not Freeze_Posted then
28653 Freeze_Posted := True;
28655 Error_Msg_Name_1 := Chars (Body_Id);
28656 Error_Msg_Sloc := Sloc (Freeze_Id);
28658 ("body & declared # freezes the contract of %",
28661 ("\all constituents must be declared before body #",
28664 -- A misplaced constituent is a critical error because
28665 -- pragma Refined_Depends or Refined_Global depends on
28666 -- the proper link between a state and a constituent.
28667 -- Stop the compilation, as this leads to a multitude
28668 -- of misleading cascaded errors.
28670 raise Unrecoverable_Error;
28673 -- The constituent is a valid state or object
28675 elsif Ekind (Constit_Id) in
28676 E_Abstract_State | E_Constant | E_Variable
28678 Match_Constituent (Constit_Id);
28680 -- The variable may eventually become a constituent of a
28681 -- single protected/task type. Record the reference now
28682 -- and verify its legality when analyzing the contract of
28683 -- the variable (SPARK RM 9.3).
28685 if Ekind (Constit_Id) = E_Variable then
28686 Record_Possible_Part_Of_Reference
28687 (Var_Id => Constit_Id,
28691 -- Otherwise the constituent is illegal
28695 ("constituent & must denote object or state",
28696 Constit, Constit_Id);
28699 -- The constituent is illegal
28702 SPARK_Msg_N ("malformed constituent", Constit);
28705 end Analyze_Constituent;
28707 -----------------------------
28708 -- Check_External_Property --
28709 -----------------------------
28711 procedure Check_External_Property
28712 (Prop_Nam : Name_Id;
28714 Constit : Entity_Id)
28717 -- The property is missing in the declaration of the state, but
28718 -- a constituent is introducing it in the state refinement
28719 -- (SPARK RM 7.2.8(2)).
28721 if not Enabled and then Present (Constit) then
28722 Error_Msg_Name_1 := Prop_Nam;
28723 Error_Msg_Name_2 := Chars (State_Id);
28725 ("constituent & introduces external property % in refinement "
28726 & "of state %", State, Constit);
28728 Error_Msg_Sloc := Sloc (State_Id);
28730 ("\property is missing in abstract state declaration #",
28733 end Check_External_Property;
28739 procedure Match_State is
28740 State_Elmt : Elmt_Id;
28743 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28745 if Contains (Refined_States_Seen, State_Id) then
28747 ("duplicate refinement of state &", State, State_Id);
28751 -- Inspect the abstract states defined in the package declaration
28752 -- looking for a match.
28754 State_Elmt := First_Elmt (Available_States);
28755 while Present (State_Elmt) loop
28757 -- A valid abstract state is being refined in the body. Add
28758 -- the state to the list of processed refined states to aid
28759 -- with the detection of duplicate refinements. Remove the
28760 -- state from Available_States to signal that it has already
28763 if Node (State_Elmt) = State_Id then
28764 Append_New_Elmt (State_Id, Refined_States_Seen);
28765 Remove_Elmt (Available_States, State_Elmt);
28769 Next_Elmt (State_Elmt);
28772 -- If we get here, we are refining a state that is not defined in
28773 -- the package declaration.
28775 Error_Msg_Name_1 := Chars (Spec_Id);
28777 ("cannot refine state, & is not defined in package %",
28781 --------------------------------
28782 -- Report_Unused_Constituents --
28783 --------------------------------
28785 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28786 Constit_Elmt : Elmt_Id;
28787 Constit_Id : Entity_Id;
28788 Posted : Boolean := False;
28791 if Present (Constits) then
28792 Constit_Elmt := First_Elmt (Constits);
28793 while Present (Constit_Elmt) loop
28794 Constit_Id := Node (Constit_Elmt);
28796 -- Generate an error message of the form:
28798 -- state ... has unused Part_Of constituents
28799 -- abstract state ... defined at ...
28800 -- constant ... defined at ...
28801 -- variable ... defined at ...
28806 ("state & has unused Part_Of constituents",
28810 Error_Msg_Sloc := Sloc (Constit_Id);
28812 if Ekind (Constit_Id) = E_Abstract_State then
28814 ("\abstract state & defined #", State, Constit_Id);
28816 elsif Ekind (Constit_Id) = E_Constant then
28818 ("\constant & defined #", State, Constit_Id);
28821 pragma Assert (Ekind (Constit_Id) = E_Variable);
28822 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28825 Next_Elmt (Constit_Elmt);
28828 end Report_Unused_Constituents;
28830 -- Local declarations
28832 Body_Ref : Node_Id;
28833 Body_Ref_Elmt : Elmt_Id;
28835 Extra_State : Node_Id;
28837 -- Start of processing for Analyze_Refinement_Clause
28840 -- A refinement clause appears as a component association where the
28841 -- sole choice is the state and the expressions are the constituents.
28842 -- This is a syntax error, always report.
28844 if Nkind (Clause) /= N_Component_Association then
28845 Error_Msg_N ("malformed state refinement clause", Clause);
28849 -- Analyze the state name of a refinement clause
28851 State := First (Choices (Clause));
28854 Resolve_State (State);
28856 -- Ensure that the state name denotes a valid abstract state that is
28857 -- defined in the spec of the related package.
28859 if Is_Entity_Name (State) then
28860 State_Id := Entity_Of (State);
28862 -- When the abstract state is undefined, it appears as Any_Id. Do
28863 -- not continue with the analysis of the clause.
28865 if State_Id = Any_Id then
28868 -- Catch any attempts to re-refine a state or refine a state that
28869 -- is not defined in the package declaration.
28871 elsif Ekind (State_Id) = E_Abstract_State then
28875 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28879 -- References to a state with visible refinement are illegal.
28880 -- When nested packages are involved, detecting such references is
28881 -- tricky because pragma Refined_State is analyzed later than the
28882 -- offending pragma Depends or Global. References that occur in
28883 -- such nested context are stored in a list. Emit errors for all
28884 -- references found in Body_References (SPARK RM 6.1.4(8)).
28886 if Present (Body_References (State_Id)) then
28887 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28888 while Present (Body_Ref_Elmt) loop
28889 Body_Ref := Node (Body_Ref_Elmt);
28891 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28892 Error_Msg_Sloc := Sloc (State);
28893 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28895 Next_Elmt (Body_Ref_Elmt);
28899 -- The state name is illegal. This is a syntax error, always report.
28902 Error_Msg_N ("malformed state name in refinement clause", State);
28906 -- A refinement clause may only refine one state at a time
28908 Extra_State := Next (State);
28910 if Present (Extra_State) then
28912 ("refinement clause cannot cover multiple states", Extra_State);
28915 -- Replicate the Part_Of constituents of the refined state because
28916 -- the algorithm will consume items.
28918 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28920 -- Analyze all constituents of the refinement. Multiple constituents
28921 -- appear as an aggregate.
28923 Constit := Expression (Clause);
28925 if Nkind (Constit) = N_Aggregate then
28926 if Present (Component_Associations (Constit)) then
28928 ("constituents of refinement clause must appear in "
28929 & "positional form", Constit);
28931 else pragma Assert (Present (Expressions (Constit)));
28932 Constit := First (Expressions (Constit));
28933 while Present (Constit) loop
28934 Analyze_Constituent (Constit);
28939 -- Various forms of a single constituent. Note that these may include
28940 -- malformed constituents.
28943 Analyze_Constituent (Constit);
28946 -- Verify that external constituents do not introduce new external
28947 -- property in the state refinement (SPARK RM 7.2.8(2)).
28949 if Is_External_State (State_Id) then
28950 Check_External_Property
28951 (Prop_Nam => Name_Async_Readers,
28952 Enabled => Async_Readers_Enabled (State_Id),
28953 Constit => AR_Constit);
28955 Check_External_Property
28956 (Prop_Nam => Name_Async_Writers,
28957 Enabled => Async_Writers_Enabled (State_Id),
28958 Constit => AW_Constit);
28960 Check_External_Property
28961 (Prop_Nam => Name_Effective_Reads,
28962 Enabled => Effective_Reads_Enabled (State_Id),
28963 Constit => ER_Constit);
28965 Check_External_Property
28966 (Prop_Nam => Name_Effective_Writes,
28967 Enabled => Effective_Writes_Enabled (State_Id),
28968 Constit => EW_Constit);
28970 -- When a refined state is not external, it should not have external
28971 -- constituents (SPARK RM 7.2.8(1)).
28973 elsif External_Constit_Seen then
28975 ("non-external state & cannot contain external constituents in "
28976 & "refinement", State, State_Id);
28979 -- Ensure that all Part_Of candidate constituents have been mentioned
28980 -- in the refinement clause.
28982 Report_Unused_Constituents (Part_Of_Constits);
28983 end Analyze_Refinement_Clause;
28985 -----------------------------
28986 -- Report_Unrefined_States --
28987 -----------------------------
28989 procedure Report_Unrefined_States (States : Elist_Id) is
28990 State_Elmt : Elmt_Id;
28993 if Present (States) then
28994 State_Elmt := First_Elmt (States);
28995 while Present (State_Elmt) loop
28997 ("abstract state & must be refined", Node (State_Elmt));
28999 Next_Elmt (State_Elmt);
29002 end Report_Unrefined_States;
29004 -- Local declarations
29006 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29009 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29012 -- Do not analyze the pragma multiple times
29014 if Is_Analyzed_Pragma (N) then
29018 -- Save the scenario for examination by the ABE Processing phase
29020 Record_Elaboration_Scenario (N);
29022 -- Replicate the abstract states declared by the package because the
29023 -- matching algorithm will consume states.
29025 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29027 -- Gather all abstract states and objects declared in the visible
29028 -- state space of the package body. These items must be utilized as
29029 -- constituents in a state refinement.
29031 Body_States := Collect_Body_States (Body_Id);
29033 -- Multiple non-null state refinements appear as an aggregate
29035 if Nkind (Clauses) = N_Aggregate then
29036 if Present (Expressions (Clauses)) then
29038 ("state refinements must appear as component associations",
29041 else pragma Assert (Present (Component_Associations (Clauses)));
29042 Clause := First (Component_Associations (Clauses));
29043 while Present (Clause) loop
29044 Analyze_Refinement_Clause (Clause);
29049 -- Various forms of a single state refinement. Note that these may
29050 -- include malformed refinements.
29053 Analyze_Refinement_Clause (Clauses);
29056 -- List all abstract states that were left unrefined
29058 Report_Unrefined_States (Available_States);
29060 Set_Is_Analyzed_Pragma (N);
29061 end Analyze_Refined_State_In_Decl_Part;
29063 ---------------------------------------------
29064 -- Analyze_Subprogram_Variant_In_Decl_Part --
29065 ---------------------------------------------
29067 -- WARNING: This routine manages Ghost regions. Return statements must be
29068 -- replaced by gotos which jump to the end of the routine and restore the
29071 procedure Analyze_Subprogram_Variant_In_Decl_Part
29073 Freeze_Id : Entity_Id := Empty)
29075 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29076 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29078 procedure Analyze_Variant (Variant : Node_Id);
29079 -- Verify the legality of a single contract case
29081 ---------------------
29082 -- Analyze_Variant --
29083 ---------------------
29085 procedure Analyze_Variant (Variant : Node_Id) is
29086 Direction : Node_Id;
29089 Extra_Direction : Node_Id;
29092 if Nkind (Variant) /= N_Component_Association then
29093 Error_Msg_N ("wrong syntax in subprogram variant", Variant);
29097 Direction := First (Choices (Variant));
29098 Expr := Expression (Variant);
29100 -- Each variant must have exactly one direction
29102 Extra_Direction := Next (Direction);
29104 if Present (Extra_Direction) then
29106 ("subprogram variant case must have exactly one direction",
29110 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
29112 if Nkind (Direction) = N_Identifier then
29113 if Chars (Direction) /= Name_Decreases
29115 Chars (Direction) /= Name_Increases
29117 Error_Msg_N ("wrong direction", Direction);
29120 Error_Msg_N ("wrong syntax", Direction);
29123 Errors := Serious_Errors_Detected;
29124 Preanalyze_Assert_Expression (Expr, Any_Discrete);
29126 -- Emit a clarification message when the variant expression
29127 -- contains at least one undefined reference, possibly due
29128 -- to contract freezing.
29130 if Errors /= Serious_Errors_Detected
29131 and then Present (Freeze_Id)
29132 and then Has_Undefined_Reference (Expr)
29134 Contract_Freeze_Error (Spec_Id, Freeze_Id);
29136 end Analyze_Variant;
29140 Variants : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29142 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
29143 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
29144 -- Save the Ghost-related attributes to restore on exit
29147 Restore_Scope : Boolean := False;
29149 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
29152 -- Do not analyze the pragma multiple times
29154 if Is_Analyzed_Pragma (N) then
29158 -- Set the Ghost mode in effect from the pragma. Due to the delayed
29159 -- analysis of the pragma, the Ghost mode at point of declaration and
29160 -- point of analysis may not necessarily be the same. Use the mode in
29161 -- effect at the point of declaration.
29163 Set_Ghost_Mode (N);
29165 -- Single and multiple contract cases must appear in aggregate form. If
29166 -- this is not the case, then either the parser of the analysis of the
29167 -- pragma failed to produce an aggregate.
29169 pragma Assert (Nkind (Variants) = N_Aggregate);
29171 if Present (Component_Associations (Variants)) then
29173 -- Ensure that the formal parameters are visible when analyzing all
29174 -- clauses. This falls out of the general rule of aspects pertaining
29175 -- to subprogram declarations.
29177 if not In_Open_Scopes (Spec_Id) then
29178 Restore_Scope := True;
29179 Push_Scope (Spec_Id);
29181 if Is_Generic_Subprogram (Spec_Id) then
29182 Install_Generic_Formals (Spec_Id);
29184 Install_Formals (Spec_Id);
29188 Variant := First (Component_Associations (Variants));
29189 while Present (Variant) loop
29190 Analyze_Variant (Variant);
29194 if Restore_Scope then
29198 -- Otherwise the pragma is illegal
29201 Error_Msg_N ("wrong syntax for subprogram variant", N);
29204 Set_Is_Analyzed_Pragma (N);
29206 Restore_Ghost_Region (Saved_GM, Saved_IGR);
29207 end Analyze_Subprogram_Variant_In_Decl_Part;
29209 ------------------------------------
29210 -- Analyze_Test_Case_In_Decl_Part --
29211 ------------------------------------
29213 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29214 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29215 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29217 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29218 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29219 -- denoted by Arg_Nam.
29221 ------------------------------
29222 -- Preanalyze_Test_Case_Arg --
29223 ------------------------------
29225 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29229 -- Preanalyze the original aspect argument for a generic subprogram
29230 -- to properly capture global references.
29232 if Is_Generic_Subprogram (Spec_Id) then
29236 Arg_Nam => Arg_Nam,
29237 From_Aspect => True);
29239 if Present (Arg) then
29240 Preanalyze_Assert_Expression
29241 (Expression (Arg), Standard_Boolean);
29245 Arg := Test_Case_Arg (N, Arg_Nam);
29247 if Present (Arg) then
29248 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29250 end Preanalyze_Test_Case_Arg;
29254 Restore_Scope : Boolean := False;
29256 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29259 -- Do not analyze the pragma multiple times
29261 if Is_Analyzed_Pragma (N) then
29265 -- Ensure that the formal parameters are visible when analyzing all
29266 -- clauses. This falls out of the general rule of aspects pertaining
29267 -- to subprogram declarations.
29269 if not In_Open_Scopes (Spec_Id) then
29270 Restore_Scope := True;
29271 Push_Scope (Spec_Id);
29273 if Is_Generic_Subprogram (Spec_Id) then
29274 Install_Generic_Formals (Spec_Id);
29276 Install_Formals (Spec_Id);
29280 Preanalyze_Test_Case_Arg (Name_Requires);
29281 Preanalyze_Test_Case_Arg (Name_Ensures);
29283 if Restore_Scope then
29287 -- Currently it is not possible to inline pre/postconditions on a
29288 -- subprogram subject to pragma Inline_Always.
29290 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29292 Set_Is_Analyzed_Pragma (N);
29293 end Analyze_Test_Case_In_Decl_Part;
29299 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29304 if Present (List) then
29305 Elmt := First_Elmt (List);
29306 while Present (Elmt) loop
29307 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29310 Id := Entity_Of (Node (Elmt));
29313 if Id = Item_Id then
29324 -----------------------------------
29325 -- Build_Pragma_Check_Equivalent --
29326 -----------------------------------
29328 function Build_Pragma_Check_Equivalent
29330 Subp_Id : Entity_Id := Empty;
29331 Inher_Id : Entity_Id := Empty;
29332 Keep_Pragma_Id : Boolean := False) return Node_Id
29334 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29335 -- Detect whether node N references a formal parameter subject to
29336 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29337 -- to False to suppress the generation of a reference when analyzing
29340 ------------------------
29341 -- Suppress_Reference --
29342 ------------------------
29344 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29345 Formal : Entity_Id;
29348 if Is_Entity_Name (N) and then Present (Entity (N)) then
29349 Formal := Entity (N);
29351 -- The formal parameter is subject to pragma Unreferenced. Prevent
29352 -- the generation of references by resetting the Comes_From_Source
29355 if Is_Formal (Formal)
29356 and then Has_Pragma_Unreferenced (Formal)
29358 Set_Comes_From_Source (N, False);
29363 end Suppress_Reference;
29365 procedure Suppress_References is
29366 new Traverse_Proc (Suppress_Reference);
29370 Loc : constant Source_Ptr := Sloc (Prag);
29371 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29372 Check_Prag : Node_Id;
29376 Needs_Wrapper : Boolean;
29377 pragma Unreferenced (Needs_Wrapper);
29379 -- Start of processing for Build_Pragma_Check_Equivalent
29382 -- When the pre- or postcondition is inherited, map the formals of the
29383 -- inherited subprogram to those of the current subprogram. In addition,
29384 -- map primitive operations of the parent type into the corresponding
29385 -- primitive operations of the descendant.
29387 if Present (Inher_Id) then
29388 pragma Assert (Present (Subp_Id));
29390 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29392 -- Use generic machinery to copy inherited pragma, as if it were an
29393 -- instantiation, resetting source locations appropriately, so that
29394 -- expressions inside the inherited pragma use chained locations.
29395 -- This is used in particular in GNATprove to locate precisely
29396 -- messages on a given inherited pragma.
29398 Set_Copied_Sloc_For_Inherited_Pragma
29399 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29400 Check_Prag := New_Copy_Tree (Source => Prag);
29402 -- Build the inherited class-wide condition
29404 Build_Class_Wide_Expression
29405 (Prag => Check_Prag,
29407 Par_Subp => Inher_Id,
29408 Adjust_Sloc => True,
29409 Needs_Wrapper => Needs_Wrapper);
29411 -- If not an inherited condition simply copy the original pragma
29414 Check_Prag := New_Copy_Tree (Source => Prag);
29417 -- Mark the pragma as being internally generated and reset the Analyzed
29420 Set_Analyzed (Check_Prag, False);
29421 Set_Comes_From_Source (Check_Prag, False);
29423 -- The tree of the original pragma may contain references to the
29424 -- formal parameters of the related subprogram. At the same time
29425 -- the corresponding body may mark the formals as unreferenced:
29427 -- procedure Proc (Formal : ...)
29428 -- with Pre => Formal ...;
29430 -- procedure Proc (Formal : ...) is
29431 -- pragma Unreferenced (Formal);
29434 -- This creates problems because all pragma Check equivalents are
29435 -- analyzed at the end of the body declarations. Since all source
29436 -- references have already been accounted for, reset any references
29437 -- to such formals in the generated pragma Check equivalent.
29439 Suppress_References (Check_Prag);
29441 if Present (Corresponding_Aspect (Prag)) then
29442 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29447 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29448 -- the copied pragma in the newly created pragma, convert the copy into
29449 -- pragma Check by correcting the name and adding a check_kind argument.
29451 if not Keep_Pragma_Id then
29452 Set_Class_Present (Check_Prag, False);
29454 Set_Pragma_Identifier
29455 (Check_Prag, Make_Identifier (Loc, Name_Check));
29457 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29458 Make_Pragma_Argument_Association (Loc,
29459 Expression => Make_Identifier (Loc, Nam)));
29462 -- Update the error message when the pragma is inherited
29464 if Present (Inher_Id) then
29465 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29467 if Chars (Msg_Arg) = Name_Message then
29468 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29470 -- Insert "inherited" to improve the error message
29472 if Name_Buffer (1 .. 8) = "failed p" then
29473 Insert_Str_In_Name_Buffer ("inherited ", 8);
29474 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29480 end Build_Pragma_Check_Equivalent;
29482 -----------------------------
29483 -- Check_Applicable_Policy --
29484 -----------------------------
29486 procedure Check_Applicable_Policy (N : Node_Id) is
29490 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29493 -- No effect if not valid assertion kind name
29495 if not Is_Valid_Assertion_Kind (Ename) then
29499 -- Loop through entries in check policy list
29501 PP := Opt.Check_Policy_List;
29502 while Present (PP) loop
29504 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29505 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29509 or else Pnm = Name_Assertion
29510 or else (Pnm = Name_Statement_Assertions
29511 and then Ename in Name_Assert
29512 | Name_Assert_And_Cut
29514 | Name_Loop_Invariant
29515 | Name_Loop_Variant)
29517 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29523 -- In CodePeer mode and GNATprove mode, we need to
29524 -- consider all assertions, unless they are disabled.
29525 -- Force Is_Checked on ignored assertions, in particular
29526 -- because transformations of the AST may depend on
29527 -- assertions being checked (e.g. the translation of
29528 -- attribute 'Loop_Entry).
29530 if CodePeer_Mode or GNATprove_Mode then
29531 Set_Is_Checked (N, True);
29532 Set_Is_Ignored (N, False);
29534 Set_Is_Checked (N, False);
29535 Set_Is_Ignored (N, True);
29541 Set_Is_Checked (N, True);
29542 Set_Is_Ignored (N, False);
29544 when Name_Disable =>
29545 Set_Is_Ignored (N, True);
29546 Set_Is_Checked (N, False);
29547 Set_Is_Disabled (N, True);
29549 -- That should be exhaustive, the null here is a defence
29550 -- against a malformed tree from previous errors.
29559 PP := Next_Pragma (PP);
29563 -- If there are no specific entries that matched, then we let the
29564 -- setting of assertions govern. Note that this provides the needed
29565 -- compatibility with the RM for the cases of assertion, invariant,
29566 -- precondition, predicate, and postcondition. Note also that
29567 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29569 if Assertions_Enabled then
29570 Set_Is_Checked (N, True);
29571 Set_Is_Ignored (N, False);
29573 Set_Is_Checked (N, False);
29574 Set_Is_Ignored (N, True);
29576 end Check_Applicable_Policy;
29578 -------------------------------
29579 -- Check_External_Properties --
29580 -------------------------------
29582 procedure Check_External_Properties
29590 -- All properties enabled
29592 if AR and AW and ER and EW then
29595 -- Async_Readers + Effective_Writes
29596 -- Async_Readers + Async_Writers + Effective_Writes
29598 elsif AR and EW and not ER then
29601 -- Async_Writers + Effective_Reads
29602 -- Async_Readers + Async_Writers + Effective_Reads
29604 elsif AW and ER and not EW then
29607 -- Async_Readers + Async_Writers
29609 elsif AR and AW and not ER and not EW then
29614 elsif AR and not AW and not ER and not EW then
29619 elsif AW and not AR and not ER and not EW then
29624 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29627 end Check_External_Properties;
29633 function Check_Kind (Nam : Name_Id) return Name_Id is
29637 -- Loop through entries in check policy list
29639 PP := Opt.Check_Policy_List;
29640 while Present (PP) loop
29642 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29643 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29647 or else (Pnm = Name_Assertion
29648 and then Is_Valid_Assertion_Kind (Nam))
29649 or else (Pnm = Name_Statement_Assertions
29650 and then Nam in Name_Assert
29651 | Name_Assert_And_Cut
29653 | Name_Loop_Invariant
29654 | Name_Loop_Variant)
29656 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29665 return Name_Ignore;
29667 when Name_Disable =>
29668 return Name_Disable;
29671 raise Program_Error;
29675 PP := Next_Pragma (PP);
29680 -- If there are no specific entries that matched, then we let the
29681 -- setting of assertions govern. Note that this provides the needed
29682 -- compatibility with the RM for the cases of assertion, invariant,
29683 -- precondition, predicate, and postcondition.
29685 if Assertions_Enabled then
29688 return Name_Ignore;
29692 ---------------------------
29693 -- Check_Missing_Part_Of --
29694 ---------------------------
29696 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29697 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29698 -- Determine whether a package denoted by Pack_Id declares at least one
29701 -----------------------
29702 -- Has_Visible_State --
29703 -----------------------
29705 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29706 Item_Id : Entity_Id;
29709 -- Traverse the entity chain of the package trying to find at least
29710 -- one visible abstract state, variable or a package [instantiation]
29711 -- that declares a visible state.
29713 Item_Id := First_Entity (Pack_Id);
29714 while Present (Item_Id)
29715 and then not In_Private_Part (Item_Id)
29717 -- Do not consider internally generated items
29719 if not Comes_From_Source (Item_Id) then
29722 -- Do not consider generic formals or their corresponding actuals
29723 -- because they are not part of a visible state. Note that both
29724 -- entities are marked as hidden.
29726 elsif Is_Hidden (Item_Id) then
29729 -- A visible state has been found. Note that constants are not
29730 -- considered here because it is not possible to determine whether
29731 -- they depend on variable input. This check is left to the SPARK
29734 elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
29737 -- Recursively peek into nested packages and instantiations
29739 elsif Ekind (Item_Id) = E_Package
29740 and then Has_Visible_State (Item_Id)
29745 Next_Entity (Item_Id);
29749 end Has_Visible_State;
29753 Pack_Id : Entity_Id;
29754 Placement : State_Space_Kind;
29756 -- Start of processing for Check_Missing_Part_Of
29759 -- Do not consider abstract states, variables or package instantiations
29760 -- coming from an instance as those always inherit the Part_Of indicator
29761 -- of the instance itself.
29763 if In_Instance then
29766 -- Do not consider internally generated entities as these can never
29767 -- have a Part_Of indicator.
29769 elsif not Comes_From_Source (Item_Id) then
29772 -- Perform these checks only when SPARK_Mode is enabled as they will
29773 -- interfere with standard Ada rules and produce false positives.
29775 elsif SPARK_Mode /= On then
29778 -- Do not consider constants, because the compiler cannot accurately
29779 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29780 -- act as a hidden state of a package.
29782 elsif Ekind (Item_Id) = E_Constant then
29786 -- Find where the abstract state, variable or package instantiation
29787 -- lives with respect to the state space.
29789 Find_Placement_In_State_Space
29790 (Item_Id => Item_Id,
29791 Placement => Placement,
29792 Pack_Id => Pack_Id);
29794 -- Items that appear in a non-package construct (subprogram, block, etc)
29795 -- do not require a Part_Of indicator because they can never act as a
29798 if Placement = Not_In_Package then
29801 -- An item declared in the body state space of a package always act as a
29802 -- constituent and does not need explicit Part_Of indicator.
29804 elsif Placement = Body_State_Space then
29807 -- In general an item declared in the visible state space of a package
29808 -- does not require a Part_Of indicator. The only exception is when the
29809 -- related package is a nongeneric private child unit, in which case
29810 -- Part_Of must denote a state in the parent unit or in one of its
29813 elsif Placement = Visible_State_Space then
29814 if Is_Child_Unit (Pack_Id)
29815 and then not Is_Generic_Unit (Pack_Id)
29816 and then Is_Private_Descendant (Pack_Id)
29818 -- A package instantiation does not need a Part_Of indicator when
29819 -- the related generic template has no visible state.
29821 if Ekind (Item_Id) = E_Package
29822 and then Is_Generic_Instance (Item_Id)
29823 and then not Has_Visible_State (Item_Id)
29827 -- All other cases require Part_Of
29831 ("indicator Part_Of is required in this context "
29832 & "(SPARK RM 7.2.6(3))", Item_Id);
29833 Error_Msg_Name_1 := Chars (Pack_Id);
29835 ("\& is declared in the visible part of private child "
29836 & "unit %", Item_Id);
29840 -- When the item appears in the private state space of a package, it
29841 -- must be a part of some state declared by the said package.
29843 else pragma Assert (Placement = Private_State_Space);
29845 -- The related package does not declare a state, the item cannot act
29846 -- as a Part_Of constituent.
29848 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29851 -- A package instantiation does not need a Part_Of indicator when the
29852 -- related generic template has no visible state.
29854 elsif Ekind (Item_Id) = E_Package
29855 and then Is_Generic_Instance (Item_Id)
29856 and then not Has_Visible_State (Item_Id)
29860 -- All other cases require Part_Of
29864 ("indicator Part_Of is required in this context "
29865 & "(SPARK RM 7.2.6(2))", Item_Id);
29866 Error_Msg_Name_1 := Chars (Pack_Id);
29868 ("\& is declared in the private part of package %", Item_Id);
29871 end Check_Missing_Part_Of;
29873 ---------------------------------------------------
29874 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29875 ---------------------------------------------------
29877 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29879 Spec_Id : Entity_Id)
29882 if Warn_On_Redundant_Constructs
29883 and then Has_Pragma_Inline_Always (Spec_Id)
29884 and then Assertions_Enabled
29886 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29888 if From_Aspect_Specification (Prag) then
29890 ("aspect % not enforced on inlined subprogram &?r?",
29891 Corresponding_Aspect (Prag), Spec_Id);
29894 ("pragma % not enforced on inlined subprogram &?r?",
29898 end Check_Postcondition_Use_In_Inlined_Subprogram;
29900 -------------------------------------
29901 -- Check_State_And_Constituent_Use --
29902 -------------------------------------
29904 procedure Check_State_And_Constituent_Use
29905 (States : Elist_Id;
29906 Constits : Elist_Id;
29909 Constit_Elmt : Elmt_Id;
29910 Constit_Id : Entity_Id;
29911 State_Id : Entity_Id;
29914 -- Nothing to do if there are no states or constituents
29916 if No (States) or else No (Constits) then
29920 -- Inspect the list of constituents and try to determine whether its
29921 -- encapsulating state is in list States.
29923 Constit_Elmt := First_Elmt (Constits);
29924 while Present (Constit_Elmt) loop
29925 Constit_Id := Node (Constit_Elmt);
29927 -- Determine whether the constituent is part of an encapsulating
29928 -- state that appears in the same context and if this is the case,
29929 -- emit an error (SPARK RM 7.2.6(7)).
29931 State_Id := Find_Encapsulating_State (States, Constit_Id);
29933 if Present (State_Id) then
29934 Error_Msg_Name_1 := Chars (Constit_Id);
29936 ("cannot mention state & and its constituent % in the same "
29937 & "context", Context, State_Id);
29941 Next_Elmt (Constit_Elmt);
29943 end Check_State_And_Constituent_Use;
29945 ---------------------------------------------
29946 -- Collect_Inherited_Class_Wide_Conditions --
29947 ---------------------------------------------
29949 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29950 Parent_Subp : constant Entity_Id :=
29951 Ultimate_Alias (Overridden_Operation (Subp));
29952 -- The Overridden_Operation may itself be inherited and as such have no
29953 -- explicit contract.
29955 Prags : constant Node_Id := Contract (Parent_Subp);
29956 In_Spec_Expr : Boolean := In_Spec_Expression;
29957 Installed : Boolean;
29959 New_Prag : Node_Id;
29962 Installed := False;
29964 -- Iterate over the contract of the overridden subprogram to find all
29965 -- inherited class-wide pre- and postconditions.
29967 if Present (Prags) then
29968 Prag := Pre_Post_Conditions (Prags);
29970 while Present (Prag) loop
29971 if Pragma_Name_Unmapped (Prag)
29972 in Name_Precondition | Name_Postcondition
29973 and then Class_Present (Prag)
29975 -- The generated pragma must be analyzed in the context of
29976 -- the subprogram, to make its formals visible. In addition,
29977 -- we must inhibit freezing and full analysis because the
29978 -- controlling type of the subprogram is not frozen yet, and
29979 -- may have further primitives.
29981 if not Installed then
29984 Install_Formals (Subp);
29985 In_Spec_Expr := In_Spec_Expression;
29986 In_Spec_Expression := True;
29990 Build_Pragma_Check_Equivalent
29991 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29993 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29994 Preanalyze (New_Prag);
29996 -- Prevent further analysis in subsequent processing of the
29997 -- current list of declarations
29999 Set_Analyzed (New_Prag);
30002 Prag := Next_Pragma (Prag);
30006 In_Spec_Expression := In_Spec_Expr;
30010 end Collect_Inherited_Class_Wide_Conditions;
30012 ---------------------------------------
30013 -- Collect_Subprogram_Inputs_Outputs --
30014 ---------------------------------------
30016 procedure Collect_Subprogram_Inputs_Outputs
30017 (Subp_Id : Entity_Id;
30018 Synthesize : Boolean := False;
30019 Subp_Inputs : in out Elist_Id;
30020 Subp_Outputs : in out Elist_Id;
30021 Global_Seen : out Boolean)
30023 procedure Collect_Dependency_Clause (Clause : Node_Id);
30024 -- Collect all relevant items from a dependency clause
30026 procedure Collect_Global_List
30028 Mode : Name_Id := Name_Input);
30029 -- Collect all relevant items from a global list
30031 -------------------------------
30032 -- Collect_Dependency_Clause --
30033 -------------------------------
30035 procedure Collect_Dependency_Clause (Clause : Node_Id) is
30036 procedure Collect_Dependency_Item
30038 Is_Input : Boolean);
30039 -- Add an item to the proper subprogram input or output collection
30041 -----------------------------
30042 -- Collect_Dependency_Item --
30043 -----------------------------
30045 procedure Collect_Dependency_Item
30047 Is_Input : Boolean)
30052 -- Nothing to collect when the item is null
30054 if Nkind (Item) = N_Null then
30057 -- Ditto for attribute 'Result
30059 elsif Is_Attribute_Result (Item) then
30062 -- Multiple items appear as an aggregate
30064 elsif Nkind (Item) = N_Aggregate then
30065 Extra := First (Expressions (Item));
30066 while Present (Extra) loop
30067 Collect_Dependency_Item (Extra, Is_Input);
30071 -- Otherwise this is a solitary item
30075 Append_New_Elmt (Item, Subp_Inputs);
30077 Append_New_Elmt (Item, Subp_Outputs);
30080 end Collect_Dependency_Item;
30082 -- Start of processing for Collect_Dependency_Clause
30085 if Nkind (Clause) = N_Null then
30088 -- A dependency clause appears as component association
30090 elsif Nkind (Clause) = N_Component_Association then
30091 Collect_Dependency_Item
30092 (Item => Expression (Clause),
30095 Collect_Dependency_Item
30096 (Item => First (Choices (Clause)),
30097 Is_Input => False);
30099 -- To accommodate partial decoration of disabled SPARK features, this
30100 -- routine may be called with illegal input. If this is the case, do
30101 -- not raise Program_Error.
30106 end Collect_Dependency_Clause;
30108 -------------------------
30109 -- Collect_Global_List --
30110 -------------------------
30112 procedure Collect_Global_List
30114 Mode : Name_Id := Name_Input)
30116 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
30117 -- Add an item to the proper subprogram input or output collection
30119 -------------------------
30120 -- Collect_Global_Item --
30121 -------------------------
30123 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
30125 if Mode in Name_In_Out | Name_Input then
30126 Append_New_Elmt (Item, Subp_Inputs);
30129 if Mode in Name_In_Out | Name_Output then
30130 Append_New_Elmt (Item, Subp_Outputs);
30132 end Collect_Global_Item;
30139 -- Start of processing for Collect_Global_List
30142 if Nkind (List) = N_Null then
30145 -- Single global item declaration
30147 elsif Nkind (List) in N_Expanded_Name
30149 | N_Selected_Component
30151 Collect_Global_Item (List, Mode);
30153 -- Simple global list or moded global list declaration
30155 elsif Nkind (List) = N_Aggregate then
30156 if Present (Expressions (List)) then
30157 Item := First (Expressions (List));
30158 while Present (Item) loop
30159 Collect_Global_Item (Item, Mode);
30164 Assoc := First (Component_Associations (List));
30165 while Present (Assoc) loop
30166 Collect_Global_List
30167 (List => Expression (Assoc),
30168 Mode => Chars (First (Choices (Assoc))));
30173 -- To accommodate partial decoration of disabled SPARK features, this
30174 -- routine may be called with illegal input. If this is the case, do
30175 -- not raise Program_Error.
30180 end Collect_Global_List;
30187 Formal : Entity_Id;
30189 Spec_Id : Entity_Id := Empty;
30190 Subp_Decl : Node_Id;
30193 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30196 Global_Seen := False;
30198 -- Process all formal parameters of entries, [generic] subprograms, and
30201 if Ekind (Subp_Id) in E_Entry
30204 | E_Generic_Function
30205 | E_Generic_Procedure
30207 | E_Subprogram_Body
30209 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30210 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30212 -- Process all formal parameters
30214 Formal := First_Entity (Spec_Id);
30215 while Present (Formal) loop
30216 if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
30217 Append_New_Elmt (Formal, Subp_Inputs);
30220 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
30221 Append_New_Elmt (Formal, Subp_Outputs);
30223 -- Out parameters can act as inputs when the related type is
30224 -- tagged, unconstrained array, unconstrained record, or record
30225 -- with unconstrained components.
30227 if Ekind (Formal) = E_Out_Parameter
30228 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30230 Append_New_Elmt (Formal, Subp_Inputs);
30234 Next_Entity (Formal);
30237 -- Otherwise the input denotes a task type, a task body, or the
30238 -- anonymous object created for a single task type.
30240 elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
30241 or else Is_Single_Task_Object (Subp_Id)
30243 Subp_Decl := Declaration_Node (Subp_Id);
30244 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30247 -- When processing an entry, subprogram or task body, look for pragmas
30248 -- Refined_Depends and Refined_Global as they specify the inputs and
30251 if Is_Entry_Body (Subp_Id)
30252 or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
30254 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30255 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30257 -- Subprogram declaration or stand-alone body case, look for pragmas
30258 -- Depends and Global
30261 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30262 Global := Get_Pragma (Spec_Id, Pragma_Global);
30265 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30266 -- because it provides finer granularity of inputs and outputs.
30268 if Present (Global) then
30269 Global_Seen := True;
30270 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30272 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30273 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30274 -- the inputs and outputs from [Refined_]Depends.
30276 elsif Synthesize and then Present (Depends) then
30277 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30279 -- Multiple dependency clauses appear as an aggregate
30281 if Nkind (Clauses) = N_Aggregate then
30282 Clause := First (Component_Associations (Clauses));
30283 while Present (Clause) loop
30284 Collect_Dependency_Clause (Clause);
30288 -- Otherwise this is a single dependency clause
30291 Collect_Dependency_Clause (Clauses);
30295 -- The current instance of a protected type acts as a formal parameter
30296 -- of mode IN for functions and IN OUT for entries and procedures
30297 -- (SPARK RM 6.1.4).
30299 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30300 Typ := Scope (Spec_Id);
30302 -- Use the anonymous object when the type is single protected
30304 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30305 Typ := Anonymous_Object (Typ);
30308 Append_New_Elmt (Typ, Subp_Inputs);
30310 if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
30311 Append_New_Elmt (Typ, Subp_Outputs);
30314 -- The current instance of a task type acts as a formal parameter of
30315 -- mode IN OUT (SPARK RM 6.1.4).
30317 elsif Ekind (Spec_Id) = E_Task_Type then
30320 -- Use the anonymous object when the type is single task
30322 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30323 Typ := Anonymous_Object (Typ);
30326 Append_New_Elmt (Typ, Subp_Inputs);
30327 Append_New_Elmt (Typ, Subp_Outputs);
30329 elsif Is_Single_Task_Object (Spec_Id) then
30330 Append_New_Elmt (Spec_Id, Subp_Inputs);
30331 Append_New_Elmt (Spec_Id, Subp_Outputs);
30333 end Collect_Subprogram_Inputs_Outputs;
30335 ---------------------------
30336 -- Contract_Freeze_Error --
30337 ---------------------------
30339 procedure Contract_Freeze_Error
30340 (Contract_Id : Entity_Id;
30341 Freeze_Id : Entity_Id)
30344 Error_Msg_Name_1 := Chars (Contract_Id);
30345 Error_Msg_Sloc := Sloc (Freeze_Id);
30348 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30350 ("\all contractual items must be declared before body #", Contract_Id);
30351 end Contract_Freeze_Error;
30353 ---------------------------------
30354 -- Delay_Config_Pragma_Analyze --
30355 ---------------------------------
30357 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30359 return Pragma_Name_Unmapped (N)
30360 in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
30361 end Delay_Config_Pragma_Analyze;
30363 -----------------------
30364 -- Duplication_Error --
30365 -----------------------
30367 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30368 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30369 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30372 Error_Msg_Sloc := Sloc (Prev);
30373 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30375 -- Emit a precise message to distinguish between source pragmas and
30376 -- pragmas generated from aspects. The ordering of the two pragmas is
30380 -- Prag -- duplicate
30382 -- No error is emitted when both pragmas come from aspects because this
30383 -- is already detected by the general aspect analysis mechanism.
30385 if Prag_From_Asp and Prev_From_Asp then
30387 elsif Prag_From_Asp then
30388 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30389 elsif Prev_From_Asp then
30390 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30392 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30394 end Duplication_Error;
30396 ------------------------------
30397 -- Find_Encapsulating_State --
30398 ------------------------------
30400 function Find_Encapsulating_State
30401 (States : Elist_Id;
30402 Constit_Id : Entity_Id) return Entity_Id
30404 State_Id : Entity_Id;
30407 -- Since a constituent may be part of a larger constituent set, climb
30408 -- the encapsulating state chain looking for a state that appears in
30411 State_Id := Encapsulating_State (Constit_Id);
30412 while Present (State_Id) loop
30413 if Contains (States, State_Id) then
30417 State_Id := Encapsulating_State (State_Id);
30421 end Find_Encapsulating_State;
30423 --------------------------
30424 -- Find_Related_Context --
30425 --------------------------
30427 function Find_Related_Context
30429 Do_Checks : Boolean := False) return Node_Id
30434 Stmt := Prev (Prag);
30435 while Present (Stmt) loop
30437 -- Skip prior pragmas, but check for duplicates
30439 if Nkind (Stmt) = N_Pragma then
30441 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30448 -- Skip internally generated code
30450 elsif not Comes_From_Source (Stmt)
30451 and then not Comes_From_Source (Original_Node (Stmt))
30454 -- The anonymous object created for a single concurrent type is a
30455 -- suitable context.
30457 if Nkind (Stmt) = N_Object_Declaration
30458 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30463 -- Return the current source construct
30473 end Find_Related_Context;
30475 --------------------------------------
30476 -- Find_Related_Declaration_Or_Body --
30477 --------------------------------------
30479 function Find_Related_Declaration_Or_Body
30481 Do_Checks : Boolean := False) return Node_Id
30483 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30485 procedure Expression_Function_Error;
30486 -- Emit an error concerning pragma Prag that illegaly applies to an
30487 -- expression function.
30489 -------------------------------
30490 -- Expression_Function_Error --
30491 -------------------------------
30493 procedure Expression_Function_Error is
30495 Error_Msg_Name_1 := Prag_Nam;
30497 -- Emit a precise message to distinguish between source pragmas and
30498 -- pragmas generated from aspects.
30500 if From_Aspect_Specification (Prag) then
30502 ("aspect % cannot apply to a stand alone expression function",
30506 ("pragma % cannot apply to a stand alone expression function",
30509 end Expression_Function_Error;
30513 Context : constant Node_Id := Parent (Prag);
30516 Look_For_Body : constant Boolean :=
30517 Prag_Nam in Name_Refined_Depends
30518 | Name_Refined_Global
30519 | Name_Refined_Post
30520 | Name_Refined_State;
30521 -- Refinement pragmas must be associated with a subprogram body [stub]
30523 -- Start of processing for Find_Related_Declaration_Or_Body
30526 Stmt := Prev (Prag);
30527 while Present (Stmt) loop
30529 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30530 -- by splitting a complex pre/postcondition are not considered to
30533 if Nkind (Stmt) = N_Pragma then
30535 and then not Split_PPC (Stmt)
30536 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30543 -- Emit an error when a refinement pragma appears on an expression
30544 -- function without a completion.
30547 and then Look_For_Body
30548 and then Nkind (Stmt) = N_Subprogram_Declaration
30549 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30550 and then not Has_Completion (Defining_Entity (Stmt))
30552 Expression_Function_Error;
30555 -- The refinement pragma applies to a subprogram body stub
30557 elsif Look_For_Body
30558 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30562 -- Skip internally generated code
30564 elsif not Comes_From_Source (Stmt) then
30566 -- The anonymous object created for a single concurrent type is a
30567 -- suitable context.
30569 if Nkind (Stmt) = N_Object_Declaration
30570 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30574 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30576 -- The subprogram declaration is an internally generated spec
30577 -- for an expression function.
30579 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30582 -- The subprogram declaration is an internally generated spec
30583 -- for a stand-alone subrogram body declared inside a protected
30586 elsif Present (Corresponding_Body (Stmt))
30587 and then Comes_From_Source (Corresponding_Body (Stmt))
30588 and then Is_Protected_Type (Current_Scope)
30592 -- The subprogram is actually an instance housed within an
30593 -- anonymous wrapper package.
30595 elsif Present (Generic_Parent (Specification (Stmt))) then
30598 -- Ada 2020: contract on formal subprogram or on generated
30599 -- Access_Subprogram_Wrapper, which appears after the related
30600 -- Access_Subprogram declaration.
30602 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30603 and then Ada_Version >= Ada_2020
30607 elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
30608 and then Ada_Version >= Ada_2020
30614 -- Return the current construct which is either a subprogram body,
30615 -- a subprogram declaration or is illegal.
30624 -- If we fall through, then the pragma was either the first declaration
30625 -- or it was preceded by other pragmas and no source constructs.
30627 -- The pragma is associated with a library-level subprogram
30629 if Nkind (Context) = N_Compilation_Unit_Aux then
30630 return Unit (Parent (Context));
30632 -- The pragma appears inside the declarations of an entry body
30634 elsif Nkind (Context) = N_Entry_Body then
30637 -- The pragma appears inside the statements of a subprogram body. This
30638 -- placement is the result of subprogram contract expansion.
30640 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30641 return Parent (Context);
30643 -- The pragma appears inside the declarative part of a package body
30645 elsif Nkind (Context) = N_Package_Body then
30648 -- The pragma appears inside the declarative part of a subprogram body
30650 elsif Nkind (Context) = N_Subprogram_Body then
30653 -- The pragma appears inside the declarative part of a task body
30655 elsif Nkind (Context) = N_Task_Body then
30658 -- The pragma appears inside the visible part of a package specification
30660 elsif Nkind (Context) = N_Package_Specification then
30661 return Parent (Context);
30663 -- The pragma is a byproduct of aspect expansion, return the related
30664 -- context of the original aspect. This case has a lower priority as
30665 -- the above circuitry pinpoints precisely the related context.
30667 elsif Present (Corresponding_Aspect (Prag)) then
30668 return Parent (Corresponding_Aspect (Prag));
30670 -- No candidate subprogram [body] found
30675 end Find_Related_Declaration_Or_Body;
30677 ----------------------------------
30678 -- Find_Related_Package_Or_Body --
30679 ----------------------------------
30681 function Find_Related_Package_Or_Body
30683 Do_Checks : Boolean := False) return Node_Id
30685 Context : constant Node_Id := Parent (Prag);
30686 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30690 Stmt := Prev (Prag);
30691 while Present (Stmt) loop
30693 -- Skip prior pragmas, but check for duplicates
30695 if Nkind (Stmt) = N_Pragma then
30696 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30702 -- Skip internally generated code
30704 elsif not Comes_From_Source (Stmt) then
30705 if Nkind (Stmt) = N_Subprogram_Declaration then
30707 -- The subprogram declaration is an internally generated spec
30708 -- for an expression function.
30710 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30713 -- The subprogram is actually an instance housed within an
30714 -- anonymous wrapper package.
30716 elsif Present (Generic_Parent (Specification (Stmt))) then
30721 -- Return the current source construct which is illegal
30730 -- If we fall through, then the pragma was either the first declaration
30731 -- or it was preceded by other pragmas and no source constructs.
30733 -- The pragma is associated with a package. The immediate context in
30734 -- this case is the specification of the package.
30736 if Nkind (Context) = N_Package_Specification then
30737 return Parent (Context);
30739 -- The pragma appears in the declarations of a package body
30741 elsif Nkind (Context) = N_Package_Body then
30744 -- The pragma appears in the statements of a package body
30746 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30747 and then Nkind (Parent (Context)) = N_Package_Body
30749 return Parent (Context);
30751 -- The pragma is a byproduct of aspect expansion, return the related
30752 -- context of the original aspect. This case has a lower priority as
30753 -- the above circuitry pinpoints precisely the related context.
30755 elsif Present (Corresponding_Aspect (Prag)) then
30756 return Parent (Corresponding_Aspect (Prag));
30758 -- No candidate package [body] found
30763 end Find_Related_Package_Or_Body;
30769 function Get_Argument
30771 Context_Id : Entity_Id := Empty) return Node_Id
30773 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30776 -- Use the expression of the original aspect when analyzing the template
30777 -- of a generic unit. In both cases the aspect's tree must be decorated
30778 -- to save the global references in the generic context.
30780 if From_Aspect_Specification (Prag)
30781 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30783 return Corresponding_Aspect (Prag);
30785 -- Otherwise use the expression of the pragma
30787 elsif Present (Args) then
30788 return First (Args);
30795 -------------------------
30796 -- Get_Base_Subprogram --
30797 -------------------------
30799 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30801 -- Follow subprogram renaming chain
30803 if Is_Subprogram (Def_Id)
30804 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30805 N_Subprogram_Renaming_Declaration
30806 and then Present (Alias (Def_Id))
30808 return Alias (Def_Id);
30812 end Get_Base_Subprogram;
30814 -----------------------
30815 -- Get_SPARK_Mode_Type --
30816 -----------------------
30818 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30820 if N = Name_On then
30822 elsif N = Name_Off then
30825 -- Any other argument is illegal. Assume that no SPARK mode applies to
30826 -- avoid potential cascaded errors.
30831 end Get_SPARK_Mode_Type;
30833 ------------------------------------
30834 -- Get_SPARK_Mode_From_Annotation --
30835 ------------------------------------
30837 function Get_SPARK_Mode_From_Annotation
30838 (N : Node_Id) return SPARK_Mode_Type
30843 if Nkind (N) = N_Aspect_Specification then
30844 Mode := Expression (N);
30846 else pragma Assert (Nkind (N) = N_Pragma);
30847 Mode := First (Pragma_Argument_Associations (N));
30849 if Present (Mode) then
30850 Mode := Get_Pragma_Arg (Mode);
30854 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30856 if Present (Mode) then
30857 if Nkind (Mode) = N_Identifier then
30858 return Get_SPARK_Mode_Type (Chars (Mode));
30860 -- In case of a malformed aspect or pragma, return the default None
30866 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30871 end Get_SPARK_Mode_From_Annotation;
30873 ---------------------------
30874 -- Has_Extra_Parentheses --
30875 ---------------------------
30877 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30881 -- The aggregate should not have an expression list because a clause
30882 -- is always interpreted as a component association. The only way an
30883 -- expression list can sneak in is by adding extra parentheses around
30884 -- the individual clauses:
30886 -- Depends (Output => Input) -- proper form
30887 -- Depends ((Output => Input)) -- extra parentheses
30889 -- Since the extra parentheses are not allowed by the syntax of the
30890 -- pragma, flag them now to avoid emitting misleading errors down the
30893 if Nkind (Clause) = N_Aggregate
30894 and then Present (Expressions (Clause))
30896 Expr := First (Expressions (Clause));
30897 while Present (Expr) loop
30899 -- A dependency clause surrounded by extra parentheses appears
30900 -- as an aggregate of component associations with an optional
30901 -- Paren_Count set.
30903 if Nkind (Expr) = N_Aggregate
30904 and then Present (Component_Associations (Expr))
30907 ("dependency clause contains extra parentheses", Expr);
30909 -- Otherwise the expression is a malformed construct
30912 SPARK_Msg_N ("malformed dependency clause", Expr);
30922 end Has_Extra_Parentheses;
30928 procedure Initialize is
30931 Compile_Time_Warnings_Errors.Init;
30940 Dummy := Dummy + 1;
30943 -----------------------------
30944 -- Is_Config_Static_String --
30945 -----------------------------
30947 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30949 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30950 -- This is an internal recursive function that is just like the outer
30951 -- function except that it adds the string to the name buffer rather
30952 -- than placing the string in the name buffer.
30954 ------------------------------
30955 -- Add_Config_Static_String --
30956 ------------------------------
30958 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30965 if Nkind (N) = N_Op_Concat then
30966 if Add_Config_Static_String (Left_Opnd (N)) then
30967 N := Right_Opnd (N);
30973 if Nkind (N) /= N_String_Literal then
30974 Error_Msg_N ("string literal expected for pragma argument", N);
30978 for J in 1 .. String_Length (Strval (N)) loop
30979 C := Get_String_Char (Strval (N), J);
30981 if not In_Character_Range (C) then
30983 ("string literal contains invalid wide character",
30984 Sloc (N) + 1 + Source_Ptr (J));
30988 Add_Char_To_Name_Buffer (Get_Character (C));
30993 end Add_Config_Static_String;
30995 -- Start of processing for Is_Config_Static_String
31000 return Add_Config_Static_String (Arg);
31001 end Is_Config_Static_String;
31003 -------------------------------
31004 -- Is_Elaboration_SPARK_Mode --
31005 -------------------------------
31007 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
31010 (Nkind (N) = N_Pragma
31011 and then Pragma_Name (N) = Name_SPARK_Mode
31012 and then Is_List_Member (N));
31014 -- Pragma SPARK_Mode affects the elaboration of a package body when it
31015 -- appears in the statement part of the body.
31018 Present (Parent (N))
31019 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
31020 and then List_Containing (N) = Statements (Parent (N))
31021 and then Present (Parent (Parent (N)))
31022 and then Nkind (Parent (Parent (N))) = N_Package_Body;
31023 end Is_Elaboration_SPARK_Mode;
31025 -----------------------
31026 -- Is_Enabled_Pragma --
31027 -----------------------
31029 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
31033 if Present (Prag) then
31034 Arg := First (Pragma_Argument_Associations (Prag));
31036 if Present (Arg) then
31037 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
31039 -- The lack of a Boolean argument automatically enables the pragma
31045 -- The pragma is missing, therefore it is not enabled
31050 end Is_Enabled_Pragma;
31052 -----------------------------------------
31053 -- Is_Non_Significant_Pragma_Reference --
31054 -----------------------------------------
31056 -- This function makes use of the following static table which indicates
31057 -- whether appearance of some name in a given pragma is to be considered
31058 -- as a reference for the purposes of warnings about unreferenced objects.
31060 -- -1 indicates that appearence in any argument is significant
31061 -- 0 indicates that appearance in any argument is not significant
31062 -- +n indicates that appearance as argument n is significant, but all
31063 -- other arguments are not significant
31064 -- 9n arguments from n on are significant, before n insignificant
31066 Sig_Flags : constant array (Pragma_Id) of Int :=
31067 (Pragma_Abort_Defer => -1,
31068 Pragma_Abstract_State => -1,
31069 Pragma_Ada_83 => -1,
31070 Pragma_Ada_95 => -1,
31071 Pragma_Ada_05 => -1,
31072 Pragma_Ada_2005 => -1,
31073 Pragma_Ada_12 => -1,
31074 Pragma_Ada_2012 => -1,
31075 Pragma_Ada_2020 => -1,
31076 Pragma_Aggregate_Individually_Assign => 0,
31077 Pragma_All_Calls_Remote => -1,
31078 Pragma_Allow_Integer_Address => -1,
31079 Pragma_Annotate => 93,
31080 Pragma_Assert => -1,
31081 Pragma_Assert_And_Cut => -1,
31082 Pragma_Assertion_Policy => 0,
31083 Pragma_Assume => -1,
31084 Pragma_Assume_No_Invalid_Values => 0,
31085 Pragma_Async_Readers => 0,
31086 Pragma_Async_Writers => 0,
31087 Pragma_Asynchronous => 0,
31088 Pragma_Atomic => 0,
31089 Pragma_Atomic_Components => 0,
31090 Pragma_Attach_Handler => -1,
31091 Pragma_Attribute_Definition => 92,
31092 Pragma_Check => -1,
31093 Pragma_Check_Float_Overflow => 0,
31094 Pragma_Check_Name => 0,
31095 Pragma_Check_Policy => 0,
31096 Pragma_CPP_Class => 0,
31097 Pragma_CPP_Constructor => 0,
31098 Pragma_CPP_Virtual => 0,
31099 Pragma_CPP_Vtable => 0,
31101 Pragma_C_Pass_By_Copy => 0,
31102 Pragma_Comment => -1,
31103 Pragma_Common_Object => 0,
31104 Pragma_CUDA_Execute => -1,
31105 Pragma_CUDA_Global => -1,
31106 Pragma_Compile_Time_Error => -1,
31107 Pragma_Compile_Time_Warning => -1,
31108 Pragma_Compiler_Unit => -1,
31109 Pragma_Compiler_Unit_Warning => -1,
31110 Pragma_Complete_Representation => 0,
31111 Pragma_Complex_Representation => 0,
31112 Pragma_Component_Alignment => 0,
31113 Pragma_Constant_After_Elaboration => 0,
31114 Pragma_Contract_Cases => -1,
31115 Pragma_Controlled => 0,
31116 Pragma_Convention => 0,
31117 Pragma_Convention_Identifier => 0,
31118 Pragma_Deadline_Floor => -1,
31119 Pragma_Debug => -1,
31120 Pragma_Debug_Policy => 0,
31121 Pragma_Default_Initial_Condition => -1,
31122 Pragma_Default_Scalar_Storage_Order => 0,
31123 Pragma_Default_Storage_Pool => 0,
31124 Pragma_Depends => -1,
31125 Pragma_Detect_Blocking => 0,
31126 Pragma_Disable_Atomic_Synchronization => 0,
31127 Pragma_Discard_Names => 0,
31128 Pragma_Dispatching_Domain => -1,
31129 Pragma_Effective_Reads => 0,
31130 Pragma_Effective_Writes => 0,
31131 Pragma_Elaborate => 0,
31132 Pragma_Elaborate_All => 0,
31133 Pragma_Elaborate_Body => 0,
31134 Pragma_Elaboration_Checks => 0,
31135 Pragma_Eliminate => 0,
31136 Pragma_Enable_Atomic_Synchronization => 0,
31137 Pragma_Export => -1,
31138 Pragma_Export_Function => -1,
31139 Pragma_Export_Object => -1,
31140 Pragma_Export_Procedure => -1,
31141 Pragma_Export_Value => -1,
31142 Pragma_Export_Valued_Procedure => -1,
31143 Pragma_Extend_System => -1,
31144 Pragma_Extensions_Allowed => 0,
31145 Pragma_Extensions_Visible => 0,
31146 Pragma_External => -1,
31147 Pragma_External_Name_Casing => 0,
31148 Pragma_Fast_Math => 0,
31149 Pragma_Favor_Top_Level => 0,
31150 Pragma_Finalize_Storage_Only => 0,
31152 Pragma_Global => -1,
31153 Pragma_Ident => -1,
31154 Pragma_Ignore_Pragma => 0,
31155 Pragma_Implementation_Defined => -1,
31156 Pragma_Implemented => -1,
31157 Pragma_Implicit_Packing => 0,
31158 Pragma_Import => 93,
31159 Pragma_Import_Function => 0,
31160 Pragma_Import_Object => 0,
31161 Pragma_Import_Procedure => 0,
31162 Pragma_Import_Valued_Procedure => 0,
31163 Pragma_Independent => 0,
31164 Pragma_Independent_Components => 0,
31165 Pragma_Initial_Condition => -1,
31166 Pragma_Initialize_Scalars => 0,
31167 Pragma_Initializes => -1,
31168 Pragma_Inline => 0,
31169 Pragma_Inline_Always => 0,
31170 Pragma_Inline_Generic => 0,
31171 Pragma_Inspection_Point => -1,
31172 Pragma_Interface => 92,
31173 Pragma_Interface_Name => 0,
31174 Pragma_Interrupt_Handler => -1,
31175 Pragma_Interrupt_Priority => -1,
31176 Pragma_Interrupt_State => -1,
31177 Pragma_Invariant => -1,
31178 Pragma_Keep_Names => 0,
31179 Pragma_License => 0,
31180 Pragma_Link_With => -1,
31181 Pragma_Linker_Alias => -1,
31182 Pragma_Linker_Constructor => -1,
31183 Pragma_Linker_Destructor => -1,
31184 Pragma_Linker_Options => -1,
31185 Pragma_Linker_Section => -1,
31187 Pragma_Lock_Free => 0,
31188 Pragma_Locking_Policy => 0,
31189 Pragma_Loop_Invariant => -1,
31190 Pragma_Loop_Optimize => 0,
31191 Pragma_Loop_Variant => -1,
31192 Pragma_Machine_Attribute => -1,
31194 Pragma_Main_Storage => -1,
31195 Pragma_Max_Entry_Queue_Depth => 0,
31196 Pragma_Max_Entry_Queue_Length => 0,
31197 Pragma_Max_Queue_Length => 0,
31198 Pragma_Memory_Size => 0,
31199 Pragma_No_Body => 0,
31200 Pragma_No_Caching => 0,
31201 Pragma_No_Component_Reordering => -1,
31202 Pragma_No_Elaboration_Code_All => 0,
31203 Pragma_No_Heap_Finalization => 0,
31204 Pragma_No_Inline => 0,
31205 Pragma_No_Return => 0,
31206 Pragma_No_Run_Time => -1,
31207 Pragma_No_Strict_Aliasing => -1,
31208 Pragma_No_Tagged_Streams => 0,
31209 Pragma_Normalize_Scalars => 0,
31210 Pragma_Obsolescent => 0,
31211 Pragma_Optimize => 0,
31212 Pragma_Optimize_Alignment => 0,
31213 Pragma_Ordered => 0,
31214 Pragma_Overflow_Mode => 0,
31215 Pragma_Overriding_Renamings => 0,
31218 Pragma_Part_Of => 0,
31219 Pragma_Partition_Elaboration_Policy => 0,
31220 Pragma_Passive => 0,
31221 Pragma_Persistent_BSS => 0,
31223 Pragma_Postcondition => -1,
31224 Pragma_Post_Class => -1,
31226 Pragma_Precondition => -1,
31227 Pragma_Predicate => -1,
31228 Pragma_Predicate_Failure => -1,
31229 Pragma_Preelaborable_Initialization => -1,
31230 Pragma_Preelaborate => 0,
31231 Pragma_Prefix_Exception_Messages => 0,
31232 Pragma_Pre_Class => -1,
31233 Pragma_Priority => -1,
31234 Pragma_Priority_Specific_Dispatching => 0,
31235 Pragma_Profile => 0,
31236 Pragma_Profile_Warnings => 0,
31237 Pragma_Propagate_Exceptions => 0,
31238 Pragma_Provide_Shift_Operators => 0,
31239 Pragma_Psect_Object => 0,
31241 Pragma_Pure_Function => 0,
31242 Pragma_Queuing_Policy => 0,
31243 Pragma_Rational => 0,
31244 Pragma_Ravenscar => 0,
31245 Pragma_Refined_Depends => -1,
31246 Pragma_Refined_Global => -1,
31247 Pragma_Refined_Post => -1,
31248 Pragma_Refined_State => -1,
31249 Pragma_Relative_Deadline => 0,
31250 Pragma_Remote_Access_Type => -1,
31251 Pragma_Remote_Call_Interface => -1,
31252 Pragma_Remote_Types => -1,
31253 Pragma_Rename_Pragma => 0,
31254 Pragma_Restricted_Run_Time => 0,
31255 Pragma_Restriction_Warnings => 0,
31256 Pragma_Restrictions => 0,
31257 Pragma_Reviewable => -1,
31258 Pragma_Secondary_Stack_Size => -1,
31259 Pragma_Share_Generic => 0,
31260 Pragma_Shared => 0,
31261 Pragma_Shared_Passive => 0,
31262 Pragma_Short_Circuit_And_Or => 0,
31263 Pragma_Short_Descriptors => 0,
31264 Pragma_Simple_Storage_Pool_Type => 0,
31265 Pragma_Source_File_Name => 0,
31266 Pragma_Source_File_Name_Project => 0,
31267 Pragma_Source_Reference => 0,
31268 Pragma_SPARK_Mode => 0,
31269 Pragma_Static_Elaboration_Desired => 0,
31270 Pragma_Storage_Size => -1,
31271 Pragma_Storage_Unit => 0,
31272 Pragma_Stream_Convert => 0,
31273 Pragma_Style_Checks => 0,
31274 Pragma_Subprogram_Variant => -1,
31275 Pragma_Subtitle => 0,
31276 Pragma_Suppress => 0,
31277 Pragma_Suppress_All => 0,
31278 Pragma_Suppress_Debug_Info => 0,
31279 Pragma_Suppress_Exception_Locations => 0,
31280 Pragma_Suppress_Initialization => 0,
31281 Pragma_System_Name => 0,
31282 Pragma_Task_Dispatching_Policy => 0,
31283 Pragma_Task_Info => -1,
31284 Pragma_Task_Name => -1,
31285 Pragma_Task_Storage => -1,
31286 Pragma_Test_Case => -1,
31287 Pragma_Thread_Local_Storage => -1,
31288 Pragma_Time_Slice => -1,
31290 Pragma_Type_Invariant => -1,
31291 Pragma_Type_Invariant_Class => -1,
31292 Pragma_Unchecked_Union => 0,
31293 Pragma_Unevaluated_Use_Of_Old => 0,
31294 Pragma_Unimplemented_Unit => 0,
31295 Pragma_Universal_Aliasing => 0,
31296 Pragma_Universal_Data => 0,
31297 Pragma_Unmodified => 0,
31298 Pragma_Unreferenced => 0,
31299 Pragma_Unreferenced_Objects => 0,
31300 Pragma_Unreserve_All_Interrupts => 0,
31301 Pragma_Unsuppress => 0,
31302 Pragma_Unused => 0,
31303 Pragma_Use_VADS_Size => 0,
31304 Pragma_Validity_Checks => 0,
31305 Pragma_Volatile => 0,
31306 Pragma_Volatile_Components => 0,
31307 Pragma_Volatile_Full_Access => 0,
31308 Pragma_Volatile_Function => 0,
31309 Pragma_Warning_As_Error => 0,
31310 Pragma_Warnings => 0,
31311 Pragma_Weak_External => 0,
31312 Pragma_Wide_Character_Encoding => 0,
31313 Unknown_Pragma => 0);
31315 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31321 function Arg_No return Nat;
31322 -- Returns an integer showing what argument we are in. A value of
31323 -- zero means we are not in any of the arguments.
31329 function Arg_No return Nat is
31334 A := First (Pragma_Argument_Associations (Parent (P)));
31348 -- Start of processing for Non_Significant_Pragma_Reference
31353 if Nkind (P) /= N_Pragma_Argument_Association then
31357 Id := Get_Pragma_Id (Parent (P));
31358 C := Sig_Flags (Id);
31373 return AN < (C - 90);
31379 end Is_Non_Significant_Pragma_Reference;
31381 ------------------------------
31382 -- Is_Pragma_String_Literal --
31383 ------------------------------
31385 -- This function returns true if the corresponding pragma argument is a
31386 -- static string expression. These are the only cases in which string
31387 -- literals can appear as pragma arguments. We also allow a string literal
31388 -- as the first argument to pragma Assert (although it will of course
31389 -- always generate a type error).
31391 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31392 Pragn : constant Node_Id := Parent (Par);
31393 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31394 Pname : constant Name_Id := Pragma_Name (Pragn);
31400 N := First (Assoc);
31407 if Pname = Name_Assert then
31410 elsif Pname = Name_Export then
31413 elsif Pname = Name_Ident then
31416 elsif Pname = Name_Import then
31419 elsif Pname = Name_Interface_Name then
31422 elsif Pname = Name_Linker_Alias then
31425 elsif Pname = Name_Linker_Section then
31428 elsif Pname = Name_Machine_Attribute then
31431 elsif Pname = Name_Source_File_Name then
31434 elsif Pname = Name_Source_Reference then
31437 elsif Pname = Name_Title then
31440 elsif Pname = Name_Subtitle then
31446 end Is_Pragma_String_Literal;
31448 ---------------------------
31449 -- Is_Private_SPARK_Mode --
31450 ---------------------------
31452 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31455 (Nkind (N) = N_Pragma
31456 and then Pragma_Name (N) = Name_SPARK_Mode
31457 and then Is_List_Member (N));
31459 -- For pragma SPARK_Mode to be private, it has to appear in the private
31460 -- declarations of a package.
31463 Present (Parent (N))
31464 and then Nkind (Parent (N)) = N_Package_Specification
31465 and then List_Containing (N) = Private_Declarations (Parent (N));
31466 end Is_Private_SPARK_Mode;
31468 -------------------------------------
31469 -- Is_Unconstrained_Or_Tagged_Item --
31470 -------------------------------------
31472 function Is_Unconstrained_Or_Tagged_Item
31473 (Item : Entity_Id) return Boolean
31475 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31476 -- Determine whether record type Typ has at least one unconstrained
31479 ---------------------------------
31480 -- Has_Unconstrained_Component --
31481 ---------------------------------
31483 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31487 Comp := First_Component (Typ);
31488 while Present (Comp) loop
31489 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31493 Next_Component (Comp);
31497 end Has_Unconstrained_Component;
31501 Typ : constant Entity_Id := Etype (Item);
31503 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31506 if Is_Tagged_Type (Typ) then
31509 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31512 elsif Is_Record_Type (Typ) then
31513 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31516 return Has_Unconstrained_Component (Typ);
31519 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31525 end Is_Unconstrained_Or_Tagged_Item;
31527 -----------------------------
31528 -- Is_Valid_Assertion_Kind --
31529 -----------------------------
31531 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31538 | Name_Assertion_Policy
31539 | Name_Static_Predicate
31540 | Name_Dynamic_Predicate
31545 | Name_Type_Invariant
31546 | Name_uType_Invariant
31550 | Name_Assert_And_Cut
31552 | Name_Contract_Cases
31554 | Name_Default_Initial_Condition
31556 | Name_Initial_Condition
31559 | Name_Loop_Invariant
31560 | Name_Loop_Variant
31561 | Name_Postcondition
31562 | Name_Precondition
31564 | Name_Refined_Post
31565 | Name_Statement_Assertions
31566 | Name_Subprogram_Variant
31573 end Is_Valid_Assertion_Kind;
31575 --------------------------------------
31576 -- Process_Compilation_Unit_Pragmas --
31577 --------------------------------------
31579 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31581 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31582 -- strange because it comes at the end of the unit. Rational has the
31583 -- same name for a pragma, but treats it as a program unit pragma, In
31584 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31585 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31586 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31587 -- the context clause to ensure the correct processing.
31589 if Has_Pragma_Suppress_All (N) then
31590 Prepend_To (Context_Items (N),
31591 Make_Pragma (Sloc (N),
31592 Chars => Name_Suppress,
31593 Pragma_Argument_Associations => New_List (
31594 Make_Pragma_Argument_Association (Sloc (N),
31595 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31598 -- Nothing else to do at the current time
31600 end Process_Compilation_Unit_Pragmas;
31602 --------------------------------------------
31603 -- Validate_Compile_Time_Warning_Or_Error --
31604 --------------------------------------------
31606 procedure Validate_Compile_Time_Warning_Or_Error
31610 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31611 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31612 Arg2 : constant Node_Id := Next (Arg1);
31614 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31615 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31618 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31620 if Compile_Time_Known_Value (Arg1x) then
31621 if Is_True (Expr_Value (Arg1x)) then
31623 -- We have already verified that the second argument is a static
31624 -- string expression. Its string value must be retrieved
31625 -- explicitly if it is a declared constant, otherwise it has
31626 -- been constant-folded previously.
31629 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31630 Str : constant String_Id :=
31631 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31632 Str_Len : constant Nat := String_Length (Str);
31634 Force : constant Boolean :=
31635 Prag_Id = Pragma_Compile_Time_Warning
31636 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31637 and then (Ekind (Cent) /= E_Package
31638 or else not In_Private_Part (Cent));
31639 -- Set True if this is the warning case, and we are in the
31640 -- visible part of a package spec, or in a subprogram spec,
31641 -- in which case we want to force the client to see the
31642 -- warning, even though it is not in the main unit.
31650 -- Loop through segments of message separated by line feeds.
31651 -- We output these segments as separate messages with
31652 -- continuation marks for all but the first.
31657 Error_Msg_Strlen := 0;
31659 -- Loop to copy characters from argument to error message
31663 exit when Ptr > Str_Len;
31664 CC := Get_String_Char (Str, Ptr);
31667 -- Ignore wide chars ??? else store character
31669 if In_Character_Range (CC) then
31670 C := Get_Character (CC);
31671 exit when C = ASCII.LF;
31672 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31673 Error_Msg_String (Error_Msg_Strlen) := C;
31677 -- Here with one line ready to go
31679 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31681 -- If this is a warning in a spec, then we want clients
31682 -- to see the warning, so mark the message with the
31683 -- special sequence !! to force the warning. In the case
31684 -- of a package spec, we do not force this if we are in
31685 -- the private part of the spec.
31688 if Cont = False then
31690 ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31694 ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31697 -- Error, rather than warning, or in a body, so we do not
31698 -- need to force visibility for client (error will be
31699 -- output in any case, and this is the situation in which
31700 -- we do not want a client to get a warning, since the
31701 -- warning is in the body or the spec private part).
31704 if Cont = False then
31706 ("<<~", Eloc, Is_Compile_Time_Pragma => True);
31710 ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
31714 exit when Ptr > Str_Len;
31719 -- Arg1x is not known at compile time, so possibly issue an error
31720 -- or warning. This can happen only if the pragma's processing
31721 -- was deferred until after the back end is run (see
31722 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31723 -- control switch applies to only the warning case.
31725 elsif Prag_Id = Pragma_Compile_Time_Error then
31726 Error_Msg_N ("condition is not known at compile time", Arg1x);
31728 elsif Warn_On_Unknown_Compile_Time_Warning then
31729 Error_Msg_N ("??condition is not known at compile time", Arg1x);
31731 end Validate_Compile_Time_Warning_Or_Error;
31733 ------------------------------------
31734 -- Record_Possible_Body_Reference --
31735 ------------------------------------
31737 procedure Record_Possible_Body_Reference
31738 (State_Id : Entity_Id;
31742 Spec_Id : Entity_Id;
31745 -- Ensure that we are dealing with a reference to a state
31747 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31749 -- Climb the tree starting from the reference looking for a package body
31750 -- whose spec declares the referenced state. This criteria automatically
31751 -- excludes references in package specs which are legal. Note that it is
31752 -- not wise to emit an error now as the package body may lack pragma
31753 -- Refined_State or the referenced state may not be mentioned in the
31754 -- refinement. This approach avoids the generation of misleading errors.
31757 while Present (Context) loop
31758 if Nkind (Context) = N_Package_Body then
31759 Spec_Id := Corresponding_Spec (Context);
31761 if Present (Abstract_States (Spec_Id))
31762 and then Contains (Abstract_States (Spec_Id), State_Id)
31764 if No (Body_References (State_Id)) then
31765 Set_Body_References (State_Id, New_Elmt_List);
31768 Append_Elmt (Ref, To => Body_References (State_Id));
31773 Context := Parent (Context);
31775 end Record_Possible_Body_Reference;
31777 ------------------------------------------
31778 -- Relocate_Pragmas_To_Anonymous_Object --
31779 ------------------------------------------
31781 procedure Relocate_Pragmas_To_Anonymous_Object
31782 (Typ_Decl : Node_Id;
31783 Obj_Decl : Node_Id)
31787 Next_Decl : Node_Id;
31790 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31791 Def := Protected_Definition (Typ_Decl);
31793 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31794 Def := Task_Definition (Typ_Decl);
31797 -- The concurrent definition has a visible declaration list. Inspect it
31798 -- and relocate all canidate pragmas.
31800 if Present (Def) and then Present (Visible_Declarations (Def)) then
31801 Decl := First (Visible_Declarations (Def));
31802 while Present (Decl) loop
31804 -- Preserve the following declaration for iteration purposes due
31805 -- to possible relocation of a pragma.
31807 Next_Decl := Next (Decl);
31809 if Nkind (Decl) = N_Pragma
31810 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31813 Insert_After (Obj_Decl, Decl);
31815 -- Skip internally generated code
31817 elsif not Comes_From_Source (Decl) then
31820 -- No candidate pragmas are available for relocation
31829 end Relocate_Pragmas_To_Anonymous_Object;
31831 ------------------------------
31832 -- Relocate_Pragmas_To_Body --
31833 ------------------------------
31835 procedure Relocate_Pragmas_To_Body
31836 (Subp_Body : Node_Id;
31837 Target_Body : Node_Id := Empty)
31839 procedure Relocate_Pragma (Prag : Node_Id);
31840 -- Remove a single pragma from its current list and add it to the
31841 -- declarations of the proper body (either Subp_Body or Target_Body).
31843 ---------------------
31844 -- Relocate_Pragma --
31845 ---------------------
31847 procedure Relocate_Pragma (Prag : Node_Id) is
31852 -- When subprogram stubs or expression functions are involves, the
31853 -- destination declaration list belongs to the proper body.
31855 if Present (Target_Body) then
31856 Target := Target_Body;
31858 Target := Subp_Body;
31861 Decls := Declarations (Target);
31865 Set_Declarations (Target, Decls);
31868 -- Unhook the pragma from its current list
31871 Prepend (Prag, Decls);
31872 end Relocate_Pragma;
31876 Body_Id : constant Entity_Id :=
31877 Defining_Unit_Name (Specification (Subp_Body));
31878 Next_Stmt : Node_Id;
31881 -- Start of processing for Relocate_Pragmas_To_Body
31884 -- Do not process a body that comes from a separate unit as no construct
31885 -- can possibly follow it.
31887 if not Is_List_Member (Subp_Body) then
31890 -- Do not relocate pragmas that follow a stub if the stub does not have
31893 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31894 and then No (Target_Body)
31898 -- Do not process internally generated routine _Postconditions
31900 elsif Ekind (Body_Id) = E_Procedure
31901 and then Chars (Body_Id) = Name_uPostconditions
31906 -- Look at what is following the body. We are interested in certain kind
31907 -- of pragmas (either from source or byproducts of expansion) that can
31908 -- apply to a body [stub].
31910 Stmt := Next (Subp_Body);
31911 while Present (Stmt) loop
31913 -- Preserve the following statement for iteration purposes due to a
31914 -- possible relocation of a pragma.
31916 Next_Stmt := Next (Stmt);
31918 -- Move a candidate pragma following the body to the declarations of
31921 if Nkind (Stmt) = N_Pragma
31922 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31925 -- If a source pragma Warnings follows the body, it applies to
31926 -- following statements and does not belong in the body.
31928 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31929 and then Comes_From_Source (Stmt)
31933 Relocate_Pragma (Stmt);
31936 -- Skip internally generated code
31938 elsif not Comes_From_Source (Stmt) then
31941 -- No candidate pragmas are available for relocation
31949 end Relocate_Pragmas_To_Body;
31951 -------------------
31952 -- Resolve_State --
31953 -------------------
31955 procedure Resolve_State (N : Node_Id) is
31960 if Is_Entity_Name (N) and then Present (Entity (N)) then
31961 Func := Entity (N);
31963 -- Handle overloading of state names by functions. Traverse the
31964 -- homonym chain looking for an abstract state.
31966 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31967 pragma Assert (Is_Overloaded (N));
31969 State := Homonym (Func);
31970 while Present (State) loop
31971 if Ekind (State) = E_Abstract_State then
31973 -- Resolve the overloading by setting the proper entity of
31974 -- the reference to that of the state.
31976 Set_Etype (N, Standard_Void_Type);
31977 Set_Entity (N, State);
31978 Set_Is_Overloaded (N, False);
31980 Generate_Reference (State, N);
31984 State := Homonym (State);
31987 -- A function can never act as a state. If the homonym chain does
31988 -- not contain a corresponding state, then something went wrong in
31989 -- the overloading mechanism.
31991 raise Program_Error;
31996 ----------------------------
31997 -- Rewrite_Assertion_Kind --
31998 ----------------------------
32000 procedure Rewrite_Assertion_Kind
32002 From_Policy : Boolean := False)
32008 if Nkind (N) = N_Attribute_Reference
32009 and then Attribute_Name (N) = Name_Class
32010 and then Nkind (Prefix (N)) = N_Identifier
32012 case Chars (Prefix (N)) is
32019 when Name_Type_Invariant =>
32020 Nam := Name_uType_Invariant;
32022 when Name_Invariant =>
32023 Nam := Name_uInvariant;
32029 -- Recommend standard use of aspect names Pre/Post
32031 elsif Nkind (N) = N_Identifier
32032 and then From_Policy
32033 and then Serious_Errors_Detected = 0
32035 if Chars (N) = Name_Precondition
32036 or else Chars (N) = Name_Postcondition
32038 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
32040 ("\use Assertion_Policy and aspect names Pre/Post for "
32041 & "Ada2012 conformance?", N);
32047 if Nam /= No_Name then
32048 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
32050 end Rewrite_Assertion_Kind;
32058 Dummy := Dummy + 1;
32061 --------------------------------
32062 -- Set_Encoded_Interface_Name --
32063 --------------------------------
32065 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
32066 Str : constant String_Id := Strval (S);
32067 Len : constant Nat := String_Length (Str);
32072 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
32075 -- Stores encoded value of character code CC. The encoding we use an
32076 -- underscore followed by four lower case hex digits.
32082 procedure Encode is
32084 Store_String_Char (Get_Char_Code ('_'));
32086 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
32088 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
32090 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
32092 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
32095 -- Start of processing for Set_Encoded_Interface_Name
32098 -- If first character is asterisk, this is a link name, and we leave it
32099 -- completely unmodified. We also ignore null strings (the latter case
32100 -- happens only in error cases).
32103 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
32105 Set_Interface_Name (E, S);
32110 CC := Get_String_Char (Str, J);
32112 exit when not In_Character_Range (CC);
32114 C := Get_Character (CC);
32116 exit when C /= '_' and then C /= '$'
32117 and then C not in '0' .. '9'
32118 and then C not in 'a' .. 'z'
32119 and then C not in 'A' .. 'Z';
32122 Set_Interface_Name (E, S);
32130 -- Here we need to encode. The encoding we use as follows:
32131 -- three underscores + four hex digits (lower case)
32135 for J in 1 .. String_Length (Str) loop
32136 CC := Get_String_Char (Str, J);
32138 if not In_Character_Range (CC) then
32141 C := Get_Character (CC);
32143 if C = '_' or else C = '$'
32144 or else C in '0' .. '9'
32145 or else C in 'a' .. 'z'
32146 or else C in 'A' .. 'Z'
32148 Store_String_Char (CC);
32155 Set_Interface_Name (E,
32156 Make_String_Literal (Sloc (S),
32157 Strval => End_String));
32159 end Set_Encoded_Interface_Name;
32161 ------------------------
32162 -- Set_Elab_Unit_Name --
32163 ------------------------
32165 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32170 if Nkind (N) = N_Identifier
32171 and then Nkind (With_Item) = N_Identifier
32173 Set_Entity (N, Entity (With_Item));
32175 elsif Nkind (N) = N_Selected_Component then
32176 Change_Selected_Component_To_Expanded_Name (N);
32177 Set_Entity (N, Entity (With_Item));
32178 Set_Entity (Selector_Name (N), Entity (N));
32180 Pref := Prefix (N);
32181 Scop := Scope (Entity (N));
32182 while Nkind (Pref) = N_Selected_Component loop
32183 Change_Selected_Component_To_Expanded_Name (Pref);
32184 Set_Entity (Selector_Name (Pref), Scop);
32185 Set_Entity (Pref, Scop);
32186 Pref := Prefix (Pref);
32187 Scop := Scope (Scop);
32190 Set_Entity (Pref, Scop);
32193 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32194 end Set_Elab_Unit_Name;
32196 -----------------------
32197 -- Set_Overflow_Mode --
32198 -----------------------
32200 procedure Set_Overflow_Mode (N : Node_Id) is
32202 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
32203 -- Function to process one pragma argument, Arg
32205 -----------------------
32206 -- Get_Overflow_Mode --
32207 -----------------------
32209 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
32210 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
32213 if Chars (Argx) = Name_Strict then
32216 elsif Chars (Argx) = Name_Minimized then
32219 elsif Chars (Argx) = Name_Eliminated then
32223 raise Program_Error;
32225 end Get_Overflow_Mode;
32229 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32230 Arg2 : constant Node_Id := Next (Arg1);
32232 -- Start of processing for Set_Overflow_Mode
32235 -- Process first argument
32237 Scope_Suppress.Overflow_Mode_General :=
32238 Get_Overflow_Mode (Arg1);
32240 -- Case of only one argument
32243 Scope_Suppress.Overflow_Mode_Assertions :=
32244 Scope_Suppress.Overflow_Mode_General;
32246 -- Case of two arguments present
32249 Scope_Suppress.Overflow_Mode_Assertions :=
32250 Get_Overflow_Mode (Arg2);
32252 end Set_Overflow_Mode;
32254 -------------------
32255 -- Test_Case_Arg --
32256 -------------------
32258 function Test_Case_Arg
32261 From_Aspect : Boolean := False) return Node_Id
32263 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32269 (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
32271 -- The caller requests the aspect argument
32273 if From_Aspect then
32274 if Present (Aspect)
32275 and then Nkind (Expression (Aspect)) = N_Aggregate
32277 Args := Expression (Aspect);
32279 -- "Name" and "Mode" may appear without an identifier as a
32280 -- positional association.
32282 if Present (Expressions (Args)) then
32283 Arg := First (Expressions (Args));
32285 if Present (Arg) and then Arg_Nam = Name_Name then
32293 if Present (Arg) and then Arg_Nam = Name_Mode then
32298 -- Some or all arguments may appear as component associatons
32300 if Present (Component_Associations (Args)) then
32301 Arg := First (Component_Associations (Args));
32302 while Present (Arg) loop
32303 if Chars (First (Choices (Arg))) = Arg_Nam then
32312 -- Otherwise retrieve the argument directly from the pragma
32315 Arg := First (Pragma_Argument_Associations (Prag));
32317 if Present (Arg) and then Arg_Nam = Name_Name then
32321 -- Skip argument "Name"
32325 if Present (Arg) and then Arg_Nam = Name_Mode then
32329 -- Skip argument "Mode"
32333 -- Arguments "Requires" and "Ensures" are optional and may not be
32336 while Present (Arg) loop
32337 if Chars (Arg) = Arg_Nam then
32348 --------------------------------------------
32349 -- Defer_Compile_Time_Warning_Error_To_BE --
32350 --------------------------------------------
32352 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32353 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32355 Compile_Time_Warnings_Errors.Append
32356 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32357 Scope => Current_Scope,
32360 -- If the Boolean expression contains T'Size, and we're not in the main
32361 -- unit being compiled, then we need to copy the pragma into the main
32362 -- unit, because otherwise T'Size might never be computed, leaving it
32365 if not In_Extended_Main_Code_Unit (N) then
32366 Insert_Library_Level_Action (New_Copy_Tree (N));
32368 end Defer_Compile_Time_Warning_Error_To_BE;
32370 ------------------------------------------
32371 -- Validate_Compile_Time_Warning_Errors --
32372 ------------------------------------------
32374 procedure Validate_Compile_Time_Warning_Errors is
32375 procedure Set_Scope (S : Entity_Id);
32376 -- Install all enclosing scopes of S along with S itself
32378 procedure Unset_Scope (S : Entity_Id);
32379 -- Uninstall all enclosing scopes of S along with S itself
32385 procedure Set_Scope (S : Entity_Id) is
32387 if S /= Standard_Standard then
32388 Set_Scope (Scope (S));
32398 procedure Unset_Scope (S : Entity_Id) is
32400 if S /= Standard_Standard then
32401 Unset_Scope (Scope (S));
32407 -- Start of processing for Validate_Compile_Time_Warning_Errors
32410 Expander_Mode_Save_And_Set (False);
32411 In_Compile_Time_Warning_Or_Error := True;
32413 for N in Compile_Time_Warnings_Errors.First ..
32414 Compile_Time_Warnings_Errors.Last
32417 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32420 Set_Scope (T.Scope);
32421 Reset_Analyzed_Flags (T.Prag);
32422 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32423 Unset_Scope (T.Scope);
32427 In_Compile_Time_Warning_Or_Error := False;
32428 Expander_Mode_Restore;
32429 end Validate_Compile_Time_Warning_Errors;