1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Einfo.Entities; use Einfo.Entities;
41 with Einfo.Utils; use Einfo.Utils;
42 with Elists; use Elists;
43 with Errout; use Errout;
44 with Exp_Dist; use Exp_Dist;
45 with Exp_Util; use Exp_Util;
46 with Expander; use Expander;
47 with Freeze; use Freeze;
48 with Ghost; use Ghost;
49 with GNAT_CUDA; use GNAT_CUDA;
50 with Gnatvsn; use Gnatvsn;
52 with Lib.Writ; use Lib.Writ;
53 with Lib.Xref; use Lib.Xref;
54 with Namet.Sp; use Namet.Sp;
55 with Nlists; use Nlists;
56 with Nmake; use Nmake;
57 with Output; use Output;
58 with Par_SCO; use Par_SCO;
59 with Restrict; use Restrict;
60 with Rident; use Rident;
61 with Rtsfind; use Rtsfind;
63 with Sem_Aux; use Sem_Aux;
64 with Sem_Ch3; use Sem_Ch3;
65 with Sem_Ch6; use Sem_Ch6;
66 with Sem_Ch7; use Sem_Ch7;
67 with Sem_Ch8; use Sem_Ch8;
68 with Sem_Ch12; use Sem_Ch12;
69 with Sem_Ch13; use Sem_Ch13;
70 with Sem_Disp; use Sem_Disp;
71 with Sem_Dist; use Sem_Dist;
72 with Sem_Elab; use Sem_Elab;
73 with Sem_Elim; use Sem_Elim;
74 with Sem_Eval; use Sem_Eval;
75 with Sem_Intr; use Sem_Intr;
76 with Sem_Mech; use Sem_Mech;
77 with Sem_Res; use Sem_Res;
78 with Sem_Type; use Sem_Type;
79 with Sem_Util; use Sem_Util;
80 with Sem_Warn; use Sem_Warn;
81 with Stand; use Stand;
82 with Sinfo; use Sinfo;
83 with Sinfo.Nodes; use Sinfo.Nodes;
84 with Sinfo.Utils; use Sinfo.Utils;
85 with Sinfo.CN; use Sinfo.CN;
86 with Sinput; use Sinput;
87 with Stringt; use Stringt;
88 with Strub; use Strub;
89 with Stylesw; use Stylesw;
91 with Targparm; use Targparm;
92 with Tbuild; use Tbuild;
94 with Uintp; use Uintp;
95 with Uname; use Uname;
96 with Urealp; use Urealp;
97 with Validsw; use Validsw;
98 with Warnsw; use Warnsw;
100 with System.Case_Util;
102 package body Sem_Prag is
104 ----------------------------------------------
105 -- Common Handling of Import-Export Pragmas --
106 ----------------------------------------------
108 -- In the following section, a number of Import_xxx and Export_xxx pragmas
109 -- are defined by GNAT. These are compatible with the DEC pragmas of the
110 -- same name, and all have the following common form and processing:
113 -- [Internal =>] LOCAL_NAME
114 -- [, [External =>] EXTERNAL_SYMBOL]
115 -- [, other optional parameters ]);
118 -- [Internal =>] LOCAL_NAME
119 -- [, [External =>] EXTERNAL_SYMBOL]
120 -- [, other optional parameters ]);
122 -- EXTERNAL_SYMBOL ::=
124 -- | static_string_EXPRESSION
126 -- The internal LOCAL_NAME designates the entity that is imported or
127 -- exported, and must refer to an entity in the current declarative
128 -- part (as required by the rules for LOCAL_NAME).
130 -- The external linker name is designated by the External parameter if
131 -- given, or the Internal parameter if not (if there is no External
132 -- parameter, the External parameter is a copy of the Internal name).
134 -- If the External parameter is given as a string, then this string is
135 -- treated as an external name (exactly as though it had been given as an
136 -- External_Name parameter for a normal Import pragma).
138 -- If the External parameter is given as an identifier (or there is no
139 -- External parameter, so that the Internal identifier is used), then
140 -- the external name is the characters of the identifier, translated
141 -- to all lower case letters.
143 -- Note: the external name specified or implied by any of these special
144 -- Import_xxx or Export_xxx pragmas override an external or link name
145 -- specified in a previous Import or Export pragma.
147 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
148 -- named notation, following the standard rules for subprogram calls, i.e.
149 -- parameters can be given in any order if named notation is used, and
150 -- positional and named notation can be mixed, subject to the rule that all
151 -- positional parameters must appear first.
153 -- Note: All these pragmas are implemented exactly following the DEC design
154 -- and implementation and are intended to be fully compatible with the use
155 -- of these pragmas in the DEC Ada compiler.
157 --------------------------------------------
158 -- Checking for Duplicated External Names --
159 --------------------------------------------
161 -- It is suspicious if two separate Export pragmas use the same external
162 -- name. The following table is used to diagnose this situation so that
163 -- an appropriate warning can be issued.
165 -- The Node_Id stored is for the N_String_Literal node created to hold
166 -- the value of the external name. The Sloc of this node is used to
167 -- cross-reference the location of the duplication.
169 package Externals is new Table.Table (
170 Table_Component_Type => Node_Id,
171 Table_Index_Type => Int,
172 Table_Low_Bound => 0,
173 Table_Initial => 100,
174 Table_Increment => 100,
175 Table_Name => "Name_Externals");
177 -------------------------------------
178 -- Local Subprograms and Variables --
179 -------------------------------------
181 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
182 -- This routine is used for possible casing adjustment of an explicit
183 -- external name supplied as a string literal (the node N), according to
184 -- the casing requirement of Opt.External_Name_Casing. If this is set to
185 -- As_Is, then the string literal is returned unchanged, but if it is set
186 -- to Uppercase or Lowercase, then a new string literal with appropriate
187 -- casing is constructed.
189 procedure Analyze_If_Present_Internal
193 -- Inspect the remainder of the list containing pragma N and look for a
194 -- pragma that matches Id. If found, analyze the pragma. If Included is
195 -- True, N is included in the search.
197 procedure Analyze_Part_Of
201 Encap_Id : out Entity_Id;
202 Legal : out Boolean);
203 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
204 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
205 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
206 -- package instantiation. Encap denotes the encapsulating state or single
207 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
208 -- the indicator is legal.
210 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
211 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
212 -- Query whether a particular item appears in a mixed list of nodes and
213 -- entities. It is assumed that all nodes in the list have entities.
215 procedure Check_Postcondition_Use_In_Inlined_Subprogram
217 Spec_Id : Entity_Id);
218 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
219 -- Precondition, Refined_Post, Subprogram_Variant, and Test_Case. Emit a
220 -- warning when pragma Prag is associated with subprogram Spec_Id subject
221 -- to Inline_Always, assertions are enabled and inling is done in the
224 procedure Check_State_And_Constituent_Use
228 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
229 -- Global and Initializes. Determine whether a state from list States and a
230 -- corresponding constituent from list Constits (if any) appear in the same
231 -- context denoted by Context. If this is the case, emit an error.
233 procedure Contract_Freeze_Error
234 (Contract_Id : Entity_Id;
235 Freeze_Id : Entity_Id);
236 -- Subsidiary to the analysis of pragmas Contract_Cases, Exceptional_Cases,
237 -- Part_Of, Post, Pre and Subprogram_Variant. Emit a freezing-related error
238 -- message where Freeze_Id is the entity of a body which caused contract
239 -- freezing and Contract_Id denotes the entity of the affected contstruct.
241 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
242 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
243 -- Prag that duplicates previous pragma Prev.
245 function Find_Encapsulating_State
247 Constit_Id : Entity_Id) return Entity_Id;
248 -- Given the entity of a constituent Constit_Id, find the corresponding
249 -- encapsulating state which appears in States. The routine returns Empty
250 -- if no such state is found.
252 function Find_Related_Context
254 Do_Checks : Boolean := False) return Node_Id;
255 -- Subsidiary to the analysis of pragmas
258 -- Constant_After_Elaboration
263 -- Find the first source declaration or statement found while traversing
264 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
265 -- set, the routine reports duplicate pragmas. The routine returns Empty
266 -- when reaching the start of the node chain.
268 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
269 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
270 -- original one, following the renaming chain) is returned. Otherwise the
271 -- entity is returned unchanged. Should be in Einfo???
273 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
274 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
275 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
276 -- value of type SPARK_Mode_Type.
278 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
279 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
280 -- Determine whether dependency clause Clause is surrounded by extra
281 -- parentheses. If this is the case, issue an error message.
283 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
284 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
285 -- pragma Depends. Determine whether the type of dependency item Item is
286 -- tagged, unconstrained array or unconstrained record.
288 procedure Record_Possible_Body_Reference
289 (State_Id : Entity_Id;
291 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
292 -- Global. Given an abstract state denoted by State_Id and a reference Ref
293 -- to it, determine whether the reference appears in a package body that
294 -- will eventually refine the state. If this is the case, record the
295 -- reference for future checks (see Analyze_Refined_State_In_Decls).
297 procedure Resolve_State (N : Node_Id);
298 -- Handle the overloading of state names by functions. When N denotes a
299 -- function, this routine finds the corresponding state and sets the entity
300 -- of N to that of the state.
302 procedure Rewrite_Assertion_Kind
304 From_Policy : Boolean := False);
305 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
306 -- then it is rewritten as an identifier with the corresponding special
307 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
308 -- and Check_Policy. If the names are Precondition or Postcondition, this
309 -- combination is deprecated in favor of Assertion_Policy and Ada2012
310 -- Aspect names. The parameter From_Policy indicates that the pragma
311 -- is the old non-standard Check_Policy and not a rewritten pragma.
313 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
314 -- Place semantic information on the argument of an Elaborate/Elaborate_All
315 -- pragma. Entity name for unit and its parents is taken from item in
316 -- previous with_clause that mentions the unit.
318 procedure Validate_Compile_Time_Warning_Or_Error
321 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
322 -- pragma N. Called when the pragma is processed as part of its regular
323 -- analysis but also called after calling the back end to validate these
324 -- pragmas for size and alignment appropriateness.
326 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
327 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
328 -- expression is not known at compile time during the front end. This
329 -- procedure makes an entry in a table. The actual checking is performed by
330 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
333 Dummy : Integer := 0;
334 pragma Volatile (Dummy);
335 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
338 pragma No_Inline (ip);
339 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
340 -- is just to help debugging the front end. If a pragma Inspection_Point
341 -- is added to a source program, then breaking on ip will get you to that
342 -- point in the program.
345 pragma No_Inline (rv);
346 -- This is a dummy function called by the processing for pragma Reviewable.
347 -- It is there for assisting front end debugging. By placing a Reviewable
348 -- pragma in the source program, a breakpoint on rv catches this place in
349 -- the source, allowing convenient stepping to the point of interest.
351 ------------------------------------------------------
352 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
353 ------------------------------------------------------
355 -- The following table collects pragmas Compile_Time_Error and Compile_
356 -- Time_Warning for validation. Entries are made by calls to subprogram
357 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
358 -- Validate_Compile_Time_Warning_Errors does the actual error checking
359 -- and posting of warning and error messages. The reason for this delayed
360 -- processing is to take advantage of back-annotations of attributes size
361 -- and alignment values performed by the back end.
363 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
364 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
365 -- will already have modified all Sloc values if the -gnatD option is set.
367 type CTWE_Entry is record
369 -- Source location used in warnings and error messages
372 -- Pragma Compile_Time_Error or Compile_Time_Warning
375 -- The scope which encloses the pragma
378 package Compile_Time_Warnings_Errors is new Table.Table (
379 Table_Component_Type => CTWE_Entry,
380 Table_Index_Type => Int,
381 Table_Low_Bound => 1,
383 Table_Increment => 200,
384 Table_Name => "Compile_Time_Warnings_Errors");
386 -------------------------------
387 -- Adjust_External_Name_Case --
388 -------------------------------
390 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
394 -- Adjust case of literal if required
396 if Opt.External_Name_Exp_Casing = As_Is then
400 -- Copy existing string
406 for J in 1 .. String_Length (Strval (N)) loop
407 CC := Get_String_Char (Strval (N), J);
409 if Opt.External_Name_Exp_Casing = Uppercase
410 and then CC in Get_Char_Code ('a') .. Get_Char_Code ('z')
412 Store_String_Char (CC - 32);
414 elsif Opt.External_Name_Exp_Casing = Lowercase
415 and then CC in Get_Char_Code ('A') .. Get_Char_Code ('Z')
417 Store_String_Char (CC + 32);
420 Store_String_Char (CC);
425 Make_String_Literal (Sloc (N),
426 Strval => End_String);
428 end Adjust_External_Name_Case;
430 --------------------------------------------
431 -- Analyze_Always_Terminates_In_Decl_Part --
432 --------------------------------------------
434 procedure Analyze_Always_Terminates_In_Decl_Part
436 Freeze_Id : Entity_Id := Empty)
438 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
439 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
440 Arg1 : constant Node_Id :=
441 First (Pragma_Argument_Associations (N));
443 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
444 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
445 -- Save the Ghost-related attributes to restore on exit
448 Restore_Scope : Boolean := False;
451 -- Do not analyze the pragma multiple times
453 if Is_Analyzed_Pragma (N) then
457 if Present (Arg1) then
459 -- Set the Ghost mode in effect from the pragma. Due to the delayed
460 -- analysis of the pragma, the Ghost mode at point of declaration and
461 -- point of analysis may not necessarily be the same. Use the mode in
462 -- effect at the point of declaration.
466 -- Ensure that the subprogram and its formals are visible when
467 -- analyzing the expression of the pragma.
469 if not In_Open_Scopes (Spec_Id) then
470 Restore_Scope := True;
472 if Is_Generic_Subprogram (Spec_Id) then
473 Push_Scope (Spec_Id);
474 Install_Generic_Formals (Spec_Id);
476 Push_Scope (Spec_Id);
477 Install_Formals (Spec_Id);
481 Errors := Serious_Errors_Detected;
482 Preanalyze_Assert_Expression (Expression (Arg1), Standard_Boolean);
484 -- Emit a clarification message when the expression contains at least
485 -- one undefined reference, possibly due to contract freezing.
487 if Errors /= Serious_Errors_Detected
488 and then Present (Freeze_Id)
489 and then Has_Undefined_Reference (Expression (Arg1))
491 Contract_Freeze_Error (Spec_Id, Freeze_Id);
494 if Restore_Scope then
498 Restore_Ghost_Region (Saved_GM, Saved_IGR);
501 Set_Is_Analyzed_Pragma (N);
503 end Analyze_Always_Terminates_In_Decl_Part;
505 -----------------------------------------
506 -- Analyze_Contract_Cases_In_Decl_Part --
507 -----------------------------------------
509 -- WARNING: This routine manages Ghost regions. Return statements must be
510 -- replaced by gotos which jump to the end of the routine and restore the
513 procedure Analyze_Contract_Cases_In_Decl_Part
515 Freeze_Id : Entity_Id := Empty)
517 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
518 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
520 Others_Seen : Boolean := False;
521 -- This flag is set when an "others" choice is encountered. It is used
522 -- to detect multiple illegal occurrences of "others".
524 procedure Analyze_Contract_Case (CCase : Node_Id);
525 -- Verify the legality of a single contract case
527 ---------------------------
528 -- Analyze_Contract_Case --
529 ---------------------------
531 procedure Analyze_Contract_Case (CCase : Node_Id) is
532 Case_Guard : Node_Id;
535 Extra_Guard : Node_Id;
538 if Nkind (CCase) = N_Component_Association then
539 Case_Guard := First (Choices (CCase));
540 Conseq := Expression (CCase);
542 -- Each contract case must have exactly one case guard
544 Extra_Guard := Next (Case_Guard);
546 if Present (Extra_Guard) then
548 ("contract case must have exactly one case guard",
552 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
554 if Nkind (Case_Guard) = N_Others_Choice then
557 ("only one OTHERS choice allowed in contract cases",
563 elsif Others_Seen then
565 ("OTHERS must be the last choice in contract cases", N);
568 -- Preanalyze the case guard and consequence
570 if Nkind (Case_Guard) /= N_Others_Choice then
571 Errors := Serious_Errors_Detected;
572 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
574 -- Emit a clarification message when the case guard contains
575 -- at least one undefined reference, possibly due to contract
578 if Errors /= Serious_Errors_Detected
579 and then Present (Freeze_Id)
580 and then Has_Undefined_Reference (Case_Guard)
582 Contract_Freeze_Error (Spec_Id, Freeze_Id);
586 Errors := Serious_Errors_Detected;
587 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
589 -- Emit a clarification message when the consequence contains
590 -- at least one undefined reference, possibly due to contract
593 if Errors /= Serious_Errors_Detected
594 and then Present (Freeze_Id)
595 and then Has_Undefined_Reference (Conseq)
597 Contract_Freeze_Error (Spec_Id, Freeze_Id);
600 -- The contract case is malformed
603 Error_Msg_N ("wrong syntax in contract case", CCase);
605 end Analyze_Contract_Case;
609 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
611 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
612 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
613 -- Save the Ghost-related attributes to restore on exit
616 Restore_Scope : Boolean := False;
618 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
621 -- Do not analyze the pragma multiple times
623 if Is_Analyzed_Pragma (N) then
627 -- Set the Ghost mode in effect from the pragma. Due to the delayed
628 -- analysis of the pragma, the Ghost mode at point of declaration and
629 -- point of analysis may not necessarily be the same. Use the mode in
630 -- effect at the point of declaration.
634 -- Single and multiple contract cases must appear in aggregate form. If
635 -- this is not the case, then either the parser or the analysis of the
636 -- pragma failed to produce an aggregate, e.g. when the contract is
637 -- "null" or a "(null record)".
640 (if Nkind (CCases) = N_Aggregate
641 then Null_Record_Present (CCases)
642 xor (Present (Component_Associations (CCases))
644 Present (Expressions (CCases)))
645 else Nkind (CCases) = N_Null);
647 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
649 if Nkind (CCases) = N_Aggregate
650 and then Present (Component_Associations (CCases))
651 and then No (Expressions (CCases))
654 -- Check that the expression is a proper aggregate (no parentheses)
656 if Paren_Count (CCases) /= 0 then
657 Error_Msg_F -- CODEFIX
658 ("redundant parentheses", CCases);
661 -- Ensure that the formal parameters are visible when analyzing all
662 -- clauses. This falls out of the general rule of aspects pertaining
663 -- to subprogram declarations.
665 if not In_Open_Scopes (Spec_Id) then
666 Restore_Scope := True;
667 Push_Scope (Spec_Id);
669 if Is_Generic_Subprogram (Spec_Id) then
670 Install_Generic_Formals (Spec_Id);
672 Install_Formals (Spec_Id);
676 CCase := First (Component_Associations (CCases));
677 while Present (CCase) loop
678 Analyze_Contract_Case (CCase);
682 if Restore_Scope then
686 -- Currently it is not possible to inline pre/postconditions on a
687 -- subprogram subject to pragma Inline_Always.
689 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
691 -- Otherwise the pragma is illegal
694 Error_Msg_N ("wrong syntax for contract cases", N);
697 Set_Is_Analyzed_Pragma (N);
699 Restore_Ghost_Region (Saved_GM, Saved_IGR);
700 end Analyze_Contract_Cases_In_Decl_Part;
702 ----------------------------------
703 -- Analyze_Depends_In_Decl_Part --
704 ----------------------------------
706 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
707 Loc : constant Source_Ptr := Sloc (N);
708 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
709 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
711 All_Inputs_Seen : Elist_Id := No_Elist;
712 -- A list containing the entities of all the inputs processed so far.
713 -- The list is populated with unique entities because the same input
714 -- may appear in multiple input lists.
716 All_Outputs_Seen : Elist_Id := No_Elist;
717 -- A list containing the entities of all the outputs processed so far.
718 -- The list is populated with unique entities because output items are
719 -- unique in a dependence relation.
721 Constits_Seen : Elist_Id := No_Elist;
722 -- A list containing the entities of all constituents processed so far.
723 -- It aids in detecting illegal usage of a state and a corresponding
724 -- constituent in pragma [Refinde_]Depends.
726 Global_Seen : Boolean := False;
727 -- A flag set when pragma Global has been processed
729 Null_Output_Seen : Boolean := False;
730 -- A flag used to track the legality of a null output
732 Result_Seen : Boolean := False;
733 -- A flag set when Spec_Id'Result is processed
735 States_Seen : Elist_Id := No_Elist;
736 -- A list containing the entities of all states processed so far. It
737 -- helps in detecting illegal usage of a state and a corresponding
738 -- constituent in pragma [Refined_]Depends.
740 Subp_Inputs : Elist_Id := No_Elist;
741 Subp_Outputs : Elist_Id := No_Elist;
742 -- Two lists containing the full set of inputs and output of the related
743 -- subprograms. Note that these lists contain both nodes and entities.
745 Task_Input_Seen : Boolean := False;
746 Task_Output_Seen : Boolean := False;
747 -- Flags used to track the implicit dependence of a task unit on itself
749 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
750 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
751 -- to the name buffer. The individual kinds are as follows:
752 -- E_Abstract_State - "state"
753 -- E_Constant - "constant"
754 -- E_Generic_In_Out_Parameter - "generic parameter"
755 -- E_Generic_In_Parameter - "generic parameter"
756 -- E_In_Parameter - "parameter"
757 -- E_In_Out_Parameter - "parameter"
758 -- E_Loop_Parameter - "loop parameter"
759 -- E_Out_Parameter - "parameter"
760 -- E_Protected_Type - "current instance of protected type"
761 -- E_Task_Type - "current instance of task type"
762 -- E_Variable - "global"
764 procedure Analyze_Dependency_Clause
767 -- Verify the legality of a single dependency clause. Flag Is_Last
768 -- denotes whether Clause is the last clause in the relation.
770 procedure Check_Function_Return;
771 -- Verify that Funtion'Result appears as one of the outputs
772 -- (SPARK RM 6.1.5(10)).
779 -- Ensure that an item fulfills its designated input and/or output role
780 -- as specified by pragma Global (if any) or the enclosing context. If
781 -- this is not the case, emit an error. Item and Item_Id denote the
782 -- attributes of an item. Flag Is_Input should be set when item comes
783 -- from an input list. Flag Self_Ref should be set when the item is an
784 -- output and the dependency clause has operator "+".
786 procedure Check_Usage
787 (Subp_Items : Elist_Id;
788 Used_Items : Elist_Id;
790 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
791 -- error if this is not the case.
793 procedure Normalize_Clause (Clause : Node_Id);
794 -- Remove a self-dependency "+" from the input list of a clause
796 -----------------------------
797 -- Add_Item_To_Name_Buffer --
798 -----------------------------
800 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
802 if Ekind (Item_Id) = E_Abstract_State then
803 Add_Str_To_Name_Buffer ("state");
805 elsif Ekind (Item_Id) = E_Constant then
806 Add_Str_To_Name_Buffer ("constant");
808 elsif Is_Formal_Object (Item_Id) then
809 Add_Str_To_Name_Buffer ("generic parameter");
811 elsif Is_Formal (Item_Id) then
812 Add_Str_To_Name_Buffer ("parameter");
814 elsif Ekind (Item_Id) = E_Loop_Parameter then
815 Add_Str_To_Name_Buffer ("loop parameter");
817 elsif Ekind (Item_Id) = E_Protected_Type
818 or else Is_Single_Protected_Object (Item_Id)
820 Add_Str_To_Name_Buffer ("current instance of protected type");
822 elsif Ekind (Item_Id) = E_Task_Type
823 or else Is_Single_Task_Object (Item_Id)
825 Add_Str_To_Name_Buffer ("current instance of task type");
827 elsif Ekind (Item_Id) = E_Variable then
828 Add_Str_To_Name_Buffer ("global");
830 -- The routine should not be called with non-SPARK items
835 end Add_Item_To_Name_Buffer;
837 -------------------------------
838 -- Analyze_Dependency_Clause --
839 -------------------------------
841 procedure Analyze_Dependency_Clause
845 procedure Analyze_Input_List (Inputs : Node_Id);
846 -- Verify the legality of a single input list
848 procedure Analyze_Input_Output
853 Seen : in out Elist_Id;
854 Null_Seen : in out Boolean;
855 Non_Null_Seen : in out Boolean);
856 -- Verify the legality of a single input or output item. Flag
857 -- Is_Input should be set whenever Item is an input, False when it
858 -- denotes an output. Flag Self_Ref should be set when the item is an
859 -- output and the dependency clause has a "+". Flag Top_Level should
860 -- be set whenever Item appears immediately within an input or output
861 -- list. Seen is a collection of all abstract states, objects and
862 -- formals processed so far. Flag Null_Seen denotes whether a null
863 -- input or output has been encountered. Flag Non_Null_Seen denotes
864 -- whether a non-null input or output has been encountered.
866 ------------------------
867 -- Analyze_Input_List --
868 ------------------------
870 procedure Analyze_Input_List (Inputs : Node_Id) is
871 Inputs_Seen : Elist_Id := No_Elist;
872 -- A list containing the entities of all inputs that appear in the
873 -- current input list.
875 Non_Null_Input_Seen : Boolean := False;
876 Null_Input_Seen : Boolean := False;
877 -- Flags used to check the legality of an input list
882 -- Multiple inputs appear as an aggregate
884 if Nkind (Inputs) = N_Aggregate then
885 if Present (Component_Associations (Inputs)) then
887 ("nested dependency relations not allowed", Inputs);
889 elsif Present (Expressions (Inputs)) then
890 Input := First (Expressions (Inputs));
891 while Present (Input) loop
898 Null_Seen => Null_Input_Seen,
899 Non_Null_Seen => Non_Null_Input_Seen);
904 -- Syntax error, always report
907 Error_Msg_N ("malformed input dependency list", Inputs);
910 -- Process a solitary input
919 Null_Seen => Null_Input_Seen,
920 Non_Null_Seen => Non_Null_Input_Seen);
923 -- Detect an illegal dependency clause of the form
927 if Null_Output_Seen and then Null_Input_Seen then
929 ("null dependency clause cannot have a null input list",
932 end Analyze_Input_List;
934 --------------------------
935 -- Analyze_Input_Output --
936 --------------------------
938 procedure Analyze_Input_Output
943 Seen : in out Elist_Id;
944 Null_Seen : in out Boolean;
945 Non_Null_Seen : in out Boolean)
947 procedure Current_Task_Instance_Seen;
948 -- Set the appropriate global flag when the current instance of a
949 -- task unit is encountered.
951 --------------------------------
952 -- Current_Task_Instance_Seen --
953 --------------------------------
955 procedure Current_Task_Instance_Seen is
958 Task_Input_Seen := True;
960 Task_Output_Seen := True;
962 end Current_Task_Instance_Seen;
966 Is_Output : constant Boolean := not Is_Input;
970 -- Start of processing for Analyze_Input_Output
973 -- Multiple input or output items appear as an aggregate
975 if Nkind (Item) = N_Aggregate then
976 if not Top_Level then
977 SPARK_Msg_N ("nested grouping of items not allowed", Item);
979 elsif Present (Component_Associations (Item)) then
981 ("nested dependency relations not allowed", Item);
983 -- Recursively analyze the grouped items
985 elsif Present (Expressions (Item)) then
986 Grouped := First (Expressions (Item));
987 while Present (Grouped) loop
990 Is_Input => Is_Input,
991 Self_Ref => Self_Ref,
994 Null_Seen => Null_Seen,
995 Non_Null_Seen => Non_Null_Seen);
1000 -- Syntax error, always report
1003 Error_Msg_N ("malformed dependency list", Item);
1006 -- Process attribute 'Result in the context of a dependency clause
1008 elsif Is_Attribute_Result (Item) then
1009 Non_Null_Seen := True;
1013 -- Attribute 'Result is allowed to appear on the output side of
1014 -- a dependency clause (SPARK RM 6.1.5(6)).
1017 SPARK_Msg_N ("function result cannot act as input", Item);
1019 elsif Null_Seen then
1021 ("cannot mix null and non-null dependency items", Item);
1024 Result_Seen := True;
1027 -- Detect multiple uses of null in a single dependency list or
1028 -- throughout the whole relation. Verify the placement of a null
1029 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
1031 elsif Nkind (Item) = N_Null then
1034 ("multiple null dependency relations not allowed", Item);
1036 elsif Non_Null_Seen then
1038 ("cannot mix null and non-null dependency items", Item);
1046 ("null output list must be the last clause in a "
1047 & "dependency relation", Item);
1049 -- Catch a useless dependence of the form:
1054 ("useless dependence, null depends on itself", Item);
1062 Non_Null_Seen := True;
1065 SPARK_Msg_N ("cannot mix null and non-null items", Item);
1069 Resolve_State (Item);
1071 -- Find the entity of the item. If this is a renaming, climb
1072 -- the renaming chain to reach the root object. Renamings of
1073 -- non-entire objects do not yield an entity (Empty).
1075 Item_Id := Entity_Of (Item);
1077 if Present (Item_Id) then
1081 if Ekind (Item_Id) in E_Constant | E_Loop_Parameter
1084 -- Current instances of concurrent types
1086 Ekind (Item_Id) in E_Protected_Type | E_Task_Type
1089 -- Formal parameters
1091 Ekind (Item_Id) in E_Generic_In_Out_Parameter
1092 | E_Generic_In_Parameter
1094 | E_In_Out_Parameter
1098 -- States, variables
1100 Ekind (Item_Id) in E_Abstract_State | E_Variable
1102 -- A [generic] function is not allowed to have Output
1103 -- items in its dependency relations. Note that "null"
1104 -- and attribute 'Result are still valid items.
1106 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1107 and then not Is_Function_With_Side_Effects (Spec_Id)
1108 and then not Is_Input
1111 GEC_Output_In_Function_Global_Or_Depends;
1113 ("output item is not applicable to function '[[]']",
1117 -- The item denotes a concurrent type. Note that single
1118 -- protected/task types are not considered here because
1119 -- they behave as objects in the context of pragma
1120 -- [Refined_]Depends.
1122 if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
1124 -- This use is legal as long as the concurrent type is
1125 -- the current instance of an enclosing type.
1127 if Is_CCT_Instance (Item_Id, Spec_Id) then
1129 -- The dependence of a task unit on itself is
1130 -- implicit and may or may not be explicitly
1131 -- specified (SPARK RM 6.1.4).
1133 if Ekind (Item_Id) = E_Task_Type then
1134 Current_Task_Instance_Seen;
1137 -- Otherwise this is not the current instance
1141 ("invalid use of subtype mark in dependency "
1142 & "relation", Item);
1145 -- The dependency of a task unit on itself is implicit
1146 -- and may or may not be explicitly specified
1147 -- (SPARK RM 6.1.4).
1149 elsif Is_Single_Task_Object (Item_Id)
1150 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1152 Current_Task_Instance_Seen;
1155 -- Ensure that the item fulfills its role as input and/or
1156 -- output as specified by pragma Global or the enclosing
1159 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1161 -- Detect multiple uses of the same state, variable or
1162 -- formal parameter. If this is not the case, add the
1163 -- item to the list of processed relations.
1165 if Contains (Seen, Item_Id) then
1167 ("duplicate use of item &", Item, Item_Id);
1169 Append_New_Elmt (Item_Id, Seen);
1172 -- Detect illegal use of an input related to a null
1173 -- output. Such input items cannot appear in other
1174 -- input lists (SPARK RM 6.1.5(13)).
1177 and then Null_Output_Seen
1178 and then Contains (All_Inputs_Seen, Item_Id)
1181 ("input of a null output list cannot appear in "
1182 & "multiple input lists", Item);
1185 -- Add an input or a self-referential output to the list
1186 -- of all processed inputs.
1188 if Is_Input or else Self_Ref then
1189 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1192 -- State related checks (SPARK RM 6.1.5(3))
1194 if Ekind (Item_Id) = E_Abstract_State then
1196 -- Package and subprogram bodies are instantiated
1197 -- individually in a separate compiler pass. Due to
1198 -- this mode of instantiation, the refinement of a
1199 -- state may no longer be visible when a subprogram
1200 -- body contract is instantiated. Since the generic
1201 -- template is legal, do not perform this check in
1202 -- the instance to circumvent this oddity.
1207 -- An abstract state with visible refinement cannot
1208 -- appear in pragma [Refined_]Depends as its place
1209 -- must be taken by some of its constituents
1210 -- (SPARK RM 6.1.4(7)).
1212 elsif Has_Visible_Refinement (Item_Id) then
1214 ("cannot mention state & in dependence relation",
1216 SPARK_Msg_N ("\use its constituents instead", Item);
1219 -- If the reference to the abstract state appears in
1220 -- an enclosing package body that will eventually
1221 -- refine the state, record the reference for future
1225 Record_Possible_Body_Reference
1226 (State_Id => Item_Id,
1230 elsif Ekind (Item_Id) in E_Constant | E_Variable
1231 and then Present (Ultimate_Overlaid_Entity (Item_Id))
1234 ("overlaying object & cannot appear in Depends",
1237 ("\use the overlaid object & instead",
1238 Item, Ultimate_Overlaid_Entity (Item_Id));
1242 -- When the item renames an entire object, replace the
1243 -- item with a reference to the object.
1245 if Entity (Item) /= Item_Id then
1247 New_Occurrence_Of (Item_Id, Sloc (Item)));
1251 -- Add the entity of the current item to the list of
1254 if Ekind (Item_Id) = E_Abstract_State then
1255 Append_New_Elmt (Item_Id, States_Seen);
1257 -- The variable may eventually become a constituent of a
1258 -- single protected/task type. Record the reference now
1259 -- and verify its legality when analyzing the contract of
1260 -- the variable (SPARK RM 9.3).
1262 elsif Ekind (Item_Id) = E_Variable then
1263 Record_Possible_Part_Of_Reference
1268 if Ekind (Item_Id) in E_Abstract_State
1271 and then Present (Encapsulating_State (Item_Id))
1273 Append_New_Elmt (Item_Id, Constits_Seen);
1276 -- All other input/output items are illegal
1277 -- (SPARK RM 6.1.5(1)).
1281 ("item must denote parameter, variable, state or "
1282 & "current instance of concurrent type", Item);
1285 -- All other input/output items are illegal
1286 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1290 ("item must denote parameter, variable, state or current "
1291 & "instance of concurrent type", Item);
1294 end Analyze_Input_Output;
1302 Non_Null_Output_Seen : Boolean := False;
1303 -- Flag used to check the legality of an output list
1305 -- Start of processing for Analyze_Dependency_Clause
1308 Inputs := Expression (Clause);
1311 -- An input list with a self-dependency appears as operator "+" where
1312 -- the actuals inputs are the right operand.
1314 if Nkind (Inputs) = N_Op_Plus then
1315 Inputs := Right_Opnd (Inputs);
1319 -- Process the output_list of a dependency_clause
1321 Output := First (Choices (Clause));
1322 while Present (Output) loop
1323 Analyze_Input_Output
1326 Self_Ref => Self_Ref,
1328 Seen => All_Outputs_Seen,
1329 Null_Seen => Null_Output_Seen,
1330 Non_Null_Seen => Non_Null_Output_Seen);
1335 -- Process the input_list of a dependency_clause
1337 Analyze_Input_List (Inputs);
1338 end Analyze_Dependency_Clause;
1340 ---------------------------
1341 -- Check_Function_Return --
1342 ---------------------------
1344 procedure Check_Function_Return is
1346 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1347 and then not Result_Seen
1350 ("result of & must appear in exactly one output list",
1353 end Check_Function_Return;
1359 procedure Check_Role
1361 Item_Id : Entity_Id;
1366 (Item_Is_Input : out Boolean;
1367 Item_Is_Output : out Boolean);
1368 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1369 -- Item_Is_Output are set depending on the role.
1371 procedure Role_Error
1372 (Item_Is_Input : Boolean;
1373 Item_Is_Output : Boolean);
1374 -- Emit an error message concerning the incorrect use of Item in
1375 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1376 -- denote whether the item is an input and/or an output.
1383 (Item_Is_Input : out Boolean;
1384 Item_Is_Output : out Boolean)
1386 -- A constant or an IN parameter of a protected entry, procedure,
1387 -- or function with side-effects, if it is of an
1388 -- access-to-variable type, should be handled like a variable, as
1389 -- the underlying memory pointed-to can be modified. Use
1390 -- Adjusted_Kind to do this adjustment.
1392 Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
1395 if (Ekind (Item_Id) in E_Constant | E_Generic_In_Parameter
1397 (Ekind (Item_Id) = E_In_Parameter
1399 (Ekind (Scope (Item_Id)) not in E_Function
1400 | E_Generic_Function
1402 Is_Function_With_Side_Effects (Scope (Item_Id)))))
1403 and then Is_Access_Variable (Etype (Item_Id))
1404 and then (Ekind (Spec_Id) not in E_Function
1405 | E_Generic_Function
1406 or else Is_Function_With_Side_Effects (Spec_Id))
1408 Adjusted_Kind := E_Variable;
1411 case Adjusted_Kind is
1415 when E_Abstract_State =>
1417 -- When pragma Global is present it determines the mode of
1418 -- the abstract state.
1421 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1422 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1424 -- Otherwise the state has a default IN OUT mode, because it
1425 -- behaves as a variable.
1428 Item_Is_Input := True;
1429 Item_Is_Output := True;
1432 -- Constants and IN parameters
1435 | E_Generic_In_Parameter
1439 -- When pragma Global is present it determines the mode
1440 -- of constant objects as inputs (and such objects cannot
1441 -- appear as outputs in the Global contract).
1444 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1446 Item_Is_Input := True;
1449 Item_Is_Output := False;
1451 -- Variables and IN OUT parameters, as well as constants and
1452 -- IN parameters of access type which are handled like
1455 when E_Generic_In_Out_Parameter
1456 | E_In_Out_Parameter
1460 -- An OUT parameter of the related subprogram; it cannot
1461 -- appear in Global.
1463 if Adjusted_Kind = E_Out_Parameter
1464 and then Scope (Item_Id) = Spec_Id
1467 -- The parameter has mode IN if its type is unconstrained
1468 -- or tagged because array bounds, discriminants or tags
1472 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1474 Item_Is_Output := True;
1476 -- A parameter of an enclosing subprogram; it can appear
1477 -- in Global and behaves as a read-write variable.
1480 -- When pragma Global is present it determines the mode
1485 -- A variable has mode IN when its type is
1486 -- unconstrained or tagged because array bounds,
1487 -- discriminants, or tags can be read.
1490 Appears_In (Subp_Inputs, Item_Id)
1491 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1493 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1495 -- Otherwise the variable has a default IN OUT mode
1498 Item_Is_Input := True;
1499 Item_Is_Output := True;
1505 when E_Protected_Type =>
1508 -- A variable has mode IN when its type is unconstrained
1509 -- or tagged because array bounds, discriminants or tags
1513 Appears_In (Subp_Inputs, Item_Id)
1514 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1516 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1519 -- A protected type acts as a formal parameter of mode IN
1520 -- when it applies to a protected function.
1522 if Ekind (Spec_Id) = E_Function then
1523 Item_Is_Input := True;
1524 Item_Is_Output := False;
1526 -- Otherwise the protected type acts as a formal of mode
1530 Item_Is_Input := True;
1531 Item_Is_Output := True;
1539 -- When pragma Global is present it determines the mode of
1544 Appears_In (Subp_Inputs, Item_Id)
1545 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1547 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1549 -- Otherwise task types act as IN OUT parameters
1552 Item_Is_Input := True;
1553 Item_Is_Output := True;
1557 raise Program_Error;
1565 procedure Role_Error
1566 (Item_Is_Input : Boolean;
1567 Item_Is_Output : Boolean)
1572 -- When the item is not part of the input and the output set of
1573 -- the related subprogram, then it appears as extra in pragma
1574 -- [Refined_]Depends.
1576 if not Item_Is_Input and then not Item_Is_Output then
1577 Add_Item_To_Name_Buffer (Item_Id);
1578 Add_Str_To_Name_Buffer
1579 (" & cannot appear in dependence relation");
1581 SPARK_Msg_NE (To_String (Global_Name_Buffer), Item, Item_Id);
1583 Error_Msg_Name_1 := Chars (Spec_Id);
1585 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1586 & "set of subprogram %"), Item, Item_Id);
1588 -- The mode of the item and its role in pragma [Refined_]Depends
1589 -- are in conflict. Construct a detailed message explaining the
1590 -- illegality (SPARK RM 6.1.5(5-6)).
1593 if Item_Is_Input then
1594 Add_Str_To_Name_Buffer ("read-only");
1596 Add_Str_To_Name_Buffer ("write-only");
1599 Add_Char_To_Name_Buffer (' ');
1600 Add_Item_To_Name_Buffer (Item_Id);
1601 Add_Str_To_Name_Buffer (" & cannot appear as ");
1603 if Item_Is_Input then
1604 Add_Str_To_Name_Buffer ("output");
1606 Add_Str_To_Name_Buffer ("input");
1609 Add_Str_To_Name_Buffer (" in dependence relation");
1611 SPARK_Msg_NE (To_String (Global_Name_Buffer), Item, Item_Id);
1617 Item_Is_Input : Boolean;
1618 Item_Is_Output : Boolean;
1620 -- Start of processing for Check_Role
1623 Find_Role (Item_Is_Input, Item_Is_Output);
1628 if not Item_Is_Input then
1629 Role_Error (Item_Is_Input, Item_Is_Output);
1632 -- Self-referential item
1635 if not Item_Is_Input or else not Item_Is_Output then
1636 Role_Error (Item_Is_Input, Item_Is_Output);
1641 elsif not Item_Is_Output then
1642 Role_Error (Item_Is_Input, Item_Is_Output);
1650 procedure Check_Usage
1651 (Subp_Items : Elist_Id;
1652 Used_Items : Elist_Id;
1655 procedure Usage_Error (Item_Id : Entity_Id);
1656 -- Emit an error concerning the illegal usage of an item
1662 procedure Usage_Error (Item_Id : Entity_Id) is
1668 -- Unconstrained and tagged items are not part of the explicit
1669 -- input set of the related subprogram, they do not have to be
1670 -- present in a dependence relation and should not be flagged
1671 -- (SPARK RM 6.1.5(5)).
1673 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1676 Add_Item_To_Name_Buffer (Item_Id);
1677 Add_Str_To_Name_Buffer
1678 (" & is missing from input dependence list");
1680 SPARK_Msg_NE (To_String (Global_Name_Buffer), N, Item_Id);
1682 ("\add `null ='> &` dependency to ignore this input",
1686 -- Output case (SPARK RM 6.1.5(10))
1691 Add_Item_To_Name_Buffer (Item_Id);
1692 Add_Str_To_Name_Buffer
1693 (" & is missing from output dependence list");
1695 SPARK_Msg_NE (To_String (Global_Name_Buffer), N, Item_Id);
1703 Item_Id : Entity_Id;
1705 -- Start of processing for Check_Usage
1708 if No (Subp_Items) then
1712 -- Each input or output of the subprogram must appear in a dependency
1715 Elmt := First_Elmt (Subp_Items);
1716 while Present (Elmt) loop
1717 Item := Node (Elmt);
1719 if Nkind (Item) = N_Defining_Identifier then
1722 Item_Id := Entity_Of (Item);
1725 -- The item does not appear in a dependency
1727 if Present (Item_Id)
1728 and then not Contains (Used_Items, Item_Id)
1730 if Is_Formal (Item_Id) then
1731 Usage_Error (Item_Id);
1733 -- The current instance of a protected type behaves as a formal
1734 -- parameter (SPARK RM 6.1.4).
1736 elsif Ekind (Item_Id) = E_Protected_Type
1737 or else Is_Single_Protected_Object (Item_Id)
1739 Usage_Error (Item_Id);
1741 -- The current instance of a task type behaves as a formal
1742 -- parameter (SPARK RM 6.1.4).
1744 elsif Ekind (Item_Id) = E_Task_Type
1745 or else Is_Single_Task_Object (Item_Id)
1747 -- The dependence of a task unit on itself is implicit and
1748 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1749 -- Emit an error if only one input/output is present.
1751 if Task_Input_Seen /= Task_Output_Seen then
1752 Usage_Error (Item_Id);
1755 -- States and global objects are not used properly only when
1756 -- the subprogram is subject to pragma Global.
1759 and then Ekind (Item_Id) in E_Abstract_State
1767 Usage_Error (Item_Id);
1775 ----------------------
1776 -- Normalize_Clause --
1777 ----------------------
1779 procedure Normalize_Clause (Clause : Node_Id) is
1780 procedure Create_Or_Modify_Clause
1786 Multiple : Boolean);
1787 -- Create a brand new clause to represent the self-reference or
1788 -- modify the input and/or output lists of an existing clause. Output
1789 -- denotes a self-referencial output. Outputs is the output list of a
1790 -- clause. Inputs is the input list of a clause. After denotes the
1791 -- clause after which the new clause is to be inserted. Flag In_Place
1792 -- should be set when normalizing the last output of an output list.
1793 -- Flag Multiple should be set when Output comes from a list with
1796 -----------------------------
1797 -- Create_Or_Modify_Clause --
1798 -----------------------------
1800 procedure Create_Or_Modify_Clause
1808 procedure Propagate_Output
1811 -- Handle the various cases of output propagation to the input
1812 -- list. Output denotes a self-referencial output item. Inputs
1813 -- is the input list of a clause.
1815 ----------------------
1816 -- Propagate_Output --
1817 ----------------------
1819 procedure Propagate_Output
1823 function In_Input_List
1825 Inputs : List_Id) return Boolean;
1826 -- Determine whether a particulat item appears in the input
1827 -- list of a clause.
1833 function In_Input_List
1835 Inputs : List_Id) return Boolean
1840 Elmt := First (Inputs);
1841 while Present (Elmt) loop
1842 if Entity_Of (Elmt) = Item then
1854 Output_Id : constant Entity_Id := Entity_Of (Output);
1857 -- Start of processing for Propagate_Output
1860 -- The clause is of the form:
1862 -- (Output =>+ null)
1864 -- Remove null input and replace it with a copy of the output:
1866 -- (Output => Output)
1868 if Nkind (Inputs) = N_Null then
1869 Rewrite (Inputs, New_Copy_Tree (Output));
1871 -- The clause is of the form:
1873 -- (Output =>+ (Input1, ..., InputN))
1875 -- Determine whether the output is not already mentioned in the
1876 -- input list and if not, add it to the list of inputs:
1878 -- (Output => (Output, Input1, ..., InputN))
1880 elsif Nkind (Inputs) = N_Aggregate then
1881 Grouped := Expressions (Inputs);
1883 if not In_Input_List
1887 Prepend_To (Grouped, New_Copy_Tree (Output));
1890 -- The clause is of the form:
1892 -- (Output =>+ Input)
1894 -- If the input does not mention the output, group the two
1897 -- (Output => (Output, Input))
1899 elsif Entity_Of (Inputs) /= Output_Id then
1901 Make_Aggregate (Loc,
1902 Expressions => New_List (
1903 New_Copy_Tree (Output),
1904 New_Copy_Tree (Inputs))));
1906 end Propagate_Output;
1910 Loc : constant Source_Ptr := Sloc (Clause);
1911 New_Clause : Node_Id;
1913 -- Start of processing for Create_Or_Modify_Clause
1916 -- A null output depending on itself does not require any
1919 if Nkind (Output) = N_Null then
1922 -- A function result cannot depend on itself because it cannot
1923 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1925 elsif Is_Attribute_Result (Output) then
1926 SPARK_Msg_N ("function result cannot depend on itself", Output);
1930 -- When performing the transformation in place, simply add the
1931 -- output to the list of inputs (if not already there). This
1932 -- case arises when dealing with the last output of an output
1933 -- list. Perform the normalization in place to avoid generating
1934 -- a malformed tree.
1937 Propagate_Output (Output, Inputs);
1939 -- A list with multiple outputs is slowly trimmed until only
1940 -- one element remains. When this happens, replace aggregate
1941 -- with the element itself.
1945 Rewrite (Outputs, Output);
1951 -- Unchain the output from its output list as it will appear in
1952 -- a new clause. Note that we cannot simply rewrite the output
1953 -- as null because this will violate the semantics of pragma
1958 -- Generate a new clause of the form:
1959 -- (Output => Inputs)
1962 Make_Component_Association (Loc,
1963 Choices => New_List (Output),
1964 Expression => New_Copy_Tree (Inputs));
1966 -- The new clause contains replicated content that has already
1967 -- been analyzed. There is not need to reanalyze or renormalize
1970 Set_Analyzed (New_Clause);
1973 (Output => First (Choices (New_Clause)),
1974 Inputs => Expression (New_Clause));
1976 Insert_After (After, New_Clause);
1978 end Create_Or_Modify_Clause;
1982 Outputs : constant Node_Id := First (Choices (Clause));
1984 Last_Output : Node_Id;
1985 Next_Output : Node_Id;
1988 -- Start of processing for Normalize_Clause
1991 -- A self-dependency appears as operator "+". Remove the "+" from the
1992 -- tree by moving the real inputs to their proper place.
1994 if Nkind (Expression (Clause)) = N_Op_Plus then
1995 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1996 Inputs := Expression (Clause);
1998 -- Multiple outputs appear as an aggregate
2000 if Nkind (Outputs) = N_Aggregate then
2001 Last_Output := Last (Expressions (Outputs));
2003 Output := First (Expressions (Outputs));
2004 while Present (Output) loop
2006 -- Normalization may remove an output from its list,
2007 -- preserve the subsequent output now.
2009 Next_Output := Next (Output);
2011 Create_Or_Modify_Clause
2016 In_Place => Output = Last_Output,
2019 Output := Next_Output;
2025 Create_Or_Modify_Clause
2034 end Normalize_Clause;
2038 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2039 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2043 Last_Clause : Node_Id;
2044 Restore_Scope : Boolean := False;
2046 -- Start of processing for Analyze_Depends_In_Decl_Part
2049 -- Do not analyze the pragma multiple times
2051 if Is_Analyzed_Pragma (N) then
2055 -- Empty dependency list
2057 if Nkind (Deps) = N_Null then
2059 -- Gather all states, objects and formal parameters that the
2060 -- subprogram may depend on. These items are obtained from the
2061 -- parameter profile or pragma [Refined_]Global (if available).
2063 Collect_Subprogram_Inputs_Outputs
2064 (Subp_Id => Subp_Id,
2065 Subp_Inputs => Subp_Inputs,
2066 Subp_Outputs => Subp_Outputs,
2067 Global_Seen => Global_Seen);
2069 -- Verify that every input or output of the subprogram appear in a
2072 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2073 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2074 Check_Function_Return;
2076 -- Dependency clauses appear as component associations of an aggregate
2078 elsif Nkind (Deps) = N_Aggregate then
2080 -- Do not attempt to perform analysis of a syntactically illegal
2081 -- clause as this will lead to misleading errors.
2083 if Has_Extra_Parentheses (Deps) then
2087 if Present (Component_Associations (Deps)) then
2088 Last_Clause := Last (Component_Associations (Deps));
2090 -- Gather all states, objects and formal parameters that the
2091 -- subprogram may depend on. These items are obtained from the
2092 -- parameter profile or pragma [Refined_]Global (if available).
2094 Collect_Subprogram_Inputs_Outputs
2095 (Subp_Id => Subp_Id,
2096 Subp_Inputs => Subp_Inputs,
2097 Subp_Outputs => Subp_Outputs,
2098 Global_Seen => Global_Seen);
2100 -- When pragma [Refined_]Depends appears on a single concurrent
2101 -- type, it is relocated to the anonymous object.
2103 if Is_Single_Concurrent_Object (Spec_Id) then
2106 -- Ensure that the formal parameters are visible when analyzing
2107 -- all clauses. This falls out of the general rule of aspects
2108 -- pertaining to subprogram declarations.
2110 elsif not In_Open_Scopes (Spec_Id) then
2111 Restore_Scope := True;
2112 Push_Scope (Spec_Id);
2114 if Ekind (Spec_Id) = E_Task_Type then
2116 -- Task discriminants cannot appear in the [Refined_]Depends
2117 -- contract, but must be present for the analysis so that we
2118 -- can reject them with an informative error message.
2120 if Has_Discriminants (Spec_Id) then
2121 Install_Discriminants (Spec_Id);
2124 elsif Is_Generic_Subprogram (Spec_Id) then
2125 Install_Generic_Formals (Spec_Id);
2128 Install_Formals (Spec_Id);
2132 Clause := First (Component_Associations (Deps));
2133 while Present (Clause) loop
2134 Errors := Serious_Errors_Detected;
2136 -- The normalization mechanism may create extra clauses that
2137 -- contain replicated input and output names. There is no need
2138 -- to reanalyze them.
2140 if not Analyzed (Clause) then
2141 Set_Analyzed (Clause);
2143 Analyze_Dependency_Clause
2145 Is_Last => Clause = Last_Clause);
2148 -- Do not normalize a clause if errors were detected (count
2149 -- of Serious_Errors has increased) because the inputs and/or
2150 -- outputs may denote illegal items.
2152 if Serious_Errors_Detected = Errors then
2153 Normalize_Clause (Clause);
2159 if Restore_Scope then
2163 -- Verify that every input or output of the subprogram appear in a
2166 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2167 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2168 Check_Function_Return;
2170 -- The dependency list is malformed. This is a syntax error, always
2174 Error_Msg_N ("malformed dependency relation", Deps);
2178 -- The top level dependency relation is malformed. This is a syntax
2179 -- error, always report.
2182 Error_Msg_N ("malformed dependency relation", Deps);
2186 -- Ensure that a state and a corresponding constituent do not appear
2187 -- together in pragma [Refined_]Depends.
2189 Check_State_And_Constituent_Use
2190 (States => States_Seen,
2191 Constits => Constits_Seen,
2195 Set_Is_Analyzed_Pragma (N);
2196 end Analyze_Depends_In_Decl_Part;
2198 --------------------------------------------
2199 -- Analyze_Exceptional_Cases_In_Decl_Part --
2200 --------------------------------------------
2202 -- WARNING: This routine manages Ghost regions. Return statements must be
2203 -- replaced by gotos which jump to the end of the routine and restore the
2206 procedure Analyze_Exceptional_Cases_In_Decl_Part
2208 Freeze_Id : Entity_Id := Empty)
2210 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2211 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2213 procedure Analyze_Exceptional_Contract (Exceptional_Contract : Node_Id);
2214 -- Verify the legality of a single exceptional contract
2216 procedure Check_Duplication (Id : Node_Id; Contracts : List_Id);
2217 -- Iterate through the identifiers in each contract to find duplicates
2219 ----------------------------------
2220 -- Analyze_Exceptional_Contract --
2221 ----------------------------------
2223 procedure Analyze_Exceptional_Contract (Exceptional_Contract : Node_Id)
2225 Exception_Choice : Node_Id;
2226 Consequence : Node_Id;
2230 if Nkind (Exceptional_Contract) /= N_Component_Association then
2232 ("wrong syntax in exceptional contract", Exceptional_Contract);
2236 Exception_Choice := First (Choices (Exceptional_Contract));
2237 Consequence := Expression (Exceptional_Contract);
2239 while Present (Exception_Choice) loop
2240 if Nkind (Exception_Choice) = N_Others_Choice then
2241 if Present (Next (Exception_Choice))
2242 or else Present (Next (Exceptional_Contract))
2243 or else Present (Prev (Exception_Choice))
2246 ("OTHERS must appear alone and last", Exception_Choice);
2250 Analyze (Exception_Choice);
2252 if Is_Entity_Name (Exception_Choice)
2253 and then Ekind (Entity (Exception_Choice)) = E_Exception
2255 if Present (Renamed_Entity (Entity (Exception_Choice)))
2256 and then Entity (Exception_Choice) = Standard_Numeric_Error
2259 (No_Obsolescent_Features, Exception_Choice);
2261 if Warn_On_Obsolescent_Feature then
2263 ("Numeric_Error is an obsolescent feature " &
2267 ("\use Constraint_Error instead?j?",
2273 (Exception_Choice, List_Containing (Exceptional_Contract));
2275 -- Check for exception declared within generic formal
2276 -- package (which is illegal, see RM 11.2(8)).
2279 Ent : Entity_Id := Entity (Exception_Choice);
2283 if Present (Renamed_Entity (Ent)) then
2284 Ent := Renamed_Entity (Ent);
2287 Scop := Scope (Ent);
2288 while Scop /= Standard_Standard
2289 and then Ekind (Scop) = E_Package
2291 if Nkind (Declaration_Node (Scop)) =
2292 N_Package_Specification
2294 Nkind (Original_Node (Parent
2295 (Declaration_Node (Scop)))) =
2296 N_Formal_Package_Declaration
2299 ("exception& is declared in generic formal "
2300 & "package", Exception_Choice, Ent);
2302 ("\and therefore cannot appear in contract "
2303 & "(RM 11.2(8))", Exception_Choice);
2306 -- If the exception is declared in an inner instance,
2307 -- nothing else to check.
2309 elsif Is_Generic_Instance (Scop) then
2313 Scop := Scope (Scop);
2317 Error_Msg_N ("exception name expected", Exception_Choice);
2321 Next (Exception_Choice);
2324 -- Now analyze the expressions of this contract
2326 Errors := Serious_Errors_Detected;
2328 -- Preanalyze_Assert_Expression, but without enforcing any of the two
2329 -- acceptable types.
2331 Preanalyze_Assert_Expression (Consequence, Any_Boolean);
2333 -- Emit a clarification message when the consequence contains at
2334 -- least one undefined reference, possibly due to contract freezing.
2336 if Errors /= Serious_Errors_Detected
2337 and then Present (Freeze_Id)
2338 and then Has_Undefined_Reference (Consequence)
2340 Contract_Freeze_Error (Spec_Id, Freeze_Id);
2342 end Analyze_Exceptional_Contract;
2344 -----------------------
2345 -- Check_Duplication --
2346 -----------------------
2348 procedure Check_Duplication (Id : Node_Id; Contracts : List_Id) is
2351 Id_Entity : Entity_Id := Entity (Id);
2354 if Present (Renamed_Entity (Id_Entity)) then
2355 Id_Entity := Renamed_Entity (Id_Entity);
2358 Contract := First (Contracts);
2359 while Present (Contract) loop
2360 Id1 := First (Choices (Contract));
2361 while Present (Id1) loop
2363 -- Only check against the exception choices which precede
2364 -- Id in the contract, since the ones that follow Id have not
2365 -- been analyzed yet and will be checked in a subsequent call.
2370 -- Duplication both simple and via a renaming across different
2371 -- exceptional contracts is illegal.
2373 elsif Nkind (Id1) /= N_Others_Choice
2375 (Id_Entity = Entity (Id1)
2376 or else Id_Entity = Renamed_Entity (Entity (Id1)))
2377 and then Contract /= Parent (Id)
2379 Error_Msg_Sloc := Sloc (Id1);
2380 Error_Msg_NE ("exception choice duplicates &#", Id, Id1);
2388 end Check_Duplication;
2392 Exceptional_Contracts : constant Node_Id :=
2393 Expression (Get_Argument (N, Spec_Id));
2395 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2396 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2397 -- Save the Ghost-related attributes to restore on exit
2399 Exceptional_Contract : Node_Id;
2400 Restore_Scope : Boolean := False;
2402 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
2405 -- Do not analyze the pragma multiple times
2407 if Is_Analyzed_Pragma (N) then
2411 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2412 -- analysis of the pragma, the Ghost mode at point of declaration and
2413 -- point of analysis may not necessarily be the same. Use the mode in
2414 -- effect at the point of declaration.
2418 -- Single and multiple contracts must appear in aggregate form. If this
2419 -- is not the case, then either the parser of the analysis of the pragma
2420 -- failed to produce an aggregate, e.g. when the contract is "null" or a
2424 (if Nkind (Exceptional_Contracts) = N_Aggregate
2425 then Null_Record_Present (Exceptional_Contracts)
2426 xor (Present (Component_Associations (Exceptional_Contracts))
2428 Present (Expressions (Exceptional_Contracts)))
2429 else Nkind (Exceptional_Contracts) = N_Null);
2431 -- Only clauses of the following form are allowed:
2433 -- exceptional_contract ::=
2434 -- [choice_parameter_specification:]
2435 -- exception_choice {'|' exception_choice} => consequence
2439 -- consequence ::= Boolean_expression
2441 if Nkind (Exceptional_Contracts) = N_Aggregate
2442 and then Present (Component_Associations (Exceptional_Contracts))
2443 and then No (Expressions (Exceptional_Contracts))
2446 -- Check that the expression is a proper aggregate (no parentheses)
2448 if Paren_Count (Exceptional_Contracts) /= 0 then
2449 Error_Msg_F -- CODEFIX
2450 ("redundant parentheses", Exceptional_Contracts);
2453 -- Ensure that the formal parameters are visible when analyzing all
2454 -- clauses. This falls out of the general rule of aspects pertaining
2455 -- to subprogram declarations.
2457 if not In_Open_Scopes (Spec_Id) then
2458 Restore_Scope := True;
2459 Push_Scope (Spec_Id);
2461 if Is_Generic_Subprogram (Spec_Id) then
2462 Install_Generic_Formals (Spec_Id);
2464 Install_Formals (Spec_Id);
2468 Exceptional_Contract :=
2469 First (Component_Associations (Exceptional_Contracts));
2470 while Present (Exceptional_Contract) loop
2471 Analyze_Exceptional_Contract (Exceptional_Contract);
2472 Next (Exceptional_Contract);
2475 if Restore_Scope then
2479 -- Otherwise the pragma is illegal
2482 Error_Msg_N ("wrong syntax for exceptional cases", N);
2485 Set_Is_Analyzed_Pragma (N);
2487 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2488 end Analyze_Exceptional_Cases_In_Decl_Part;
2490 --------------------------------------------
2491 -- Analyze_External_Property_In_Decl_Part --
2492 --------------------------------------------
2494 procedure Analyze_External_Property_In_Decl_Part
2496 Expr_Val : out Boolean)
2498 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2499 Arg1 : constant Node_Id :=
2500 First (Pragma_Argument_Associations (N));
2501 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2502 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2503 Obj_Typ : Entity_Id;
2507 if Is_Type (Obj_Id) then
2510 Obj_Typ := Etype (Obj_Id);
2513 -- Ensure that the Boolean expression (if present) is static. A missing
2514 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2518 if Present (Arg1) then
2519 Expr := Get_Pragma_Arg (Arg1);
2521 if Is_OK_Static_Expression (Expr) then
2522 Expr_Val := Is_True (Expr_Value (Expr));
2526 -- The output parameter was set to the argument specified by the pragma.
2527 -- Do not analyze the pragma multiple times.
2529 if Is_Analyzed_Pragma (N) then
2533 Error_Msg_Name_1 := Pragma_Name (N);
2535 -- An external property pragma must apply to an effectively volatile
2536 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2537 -- The check is performed at the end of the declarative region due to a
2538 -- possible out-of-order arrangement of pragmas:
2541 -- pragma Async_Readers (Obj);
2542 -- pragma Volatile (Obj);
2544 if Prag_Id /= Pragma_No_Caching
2545 and then not Is_Effectively_Volatile (Obj_Id)
2547 if No_Caching_Enabled (Obj_Id) then
2548 if Expr_Val then -- Confirming value of False is allowed
2550 ("illegal combination of external property % and property "
2551 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2555 ("external property % must apply to a volatile type or object",
2559 -- Pragma No_Caching should only apply to volatile types or variables of
2560 -- a non-effectively volatile type (SPARK RM 7.1.2).
2562 elsif Prag_Id = Pragma_No_Caching then
2563 if Is_Effectively_Volatile (Obj_Typ) then
2564 SPARK_Msg_N ("property % must not apply to a type or object of "
2565 & "an effectively volatile type", N);
2566 elsif not Is_Volatile (Obj_Id) then
2568 ("property % must apply to a volatile type or object", N);
2572 Set_Is_Analyzed_Pragma (N);
2573 end Analyze_External_Property_In_Decl_Part;
2575 ---------------------------------
2576 -- Analyze_Global_In_Decl_Part --
2577 ---------------------------------
2579 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2580 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2581 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2582 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2584 Constits_Seen : Elist_Id := No_Elist;
2585 -- A list containing the entities of all constituents processed so far.
2586 -- It aids in detecting illegal usage of a state and a corresponding
2587 -- constituent in pragma [Refinde_]Global.
2589 Seen : Elist_Id := No_Elist;
2590 -- A list containing the entities of all the items processed so far. It
2591 -- plays a role in detecting distinct entities.
2593 States_Seen : Elist_Id := No_Elist;
2594 -- A list containing the entities of all states processed so far. It
2595 -- helps in detecting illegal usage of a state and a corresponding
2596 -- constituent in pragma [Refined_]Global.
2598 In_Out_Seen : Boolean := False;
2599 Input_Seen : Boolean := False;
2600 Output_Seen : Boolean := False;
2601 Proof_Seen : Boolean := False;
2602 -- Flags used to verify the consistency of modes
2604 procedure Analyze_Global_List
2606 Global_Mode : Name_Id := Name_Input);
2607 -- Verify the legality of a single global list declaration. Global_Mode
2608 -- denotes the current mode in effect.
2610 -------------------------
2611 -- Analyze_Global_List --
2612 -------------------------
2614 procedure Analyze_Global_List
2616 Global_Mode : Name_Id := Name_Input)
2618 procedure Analyze_Global_Item
2620 Global_Mode : Name_Id);
2621 -- Verify the legality of a single global item declaration denoted by
2622 -- Item. Global_Mode denotes the current mode in effect.
2624 procedure Check_Duplicate_Mode
2626 Status : in out Boolean);
2627 -- Flag Status denotes whether a particular mode has been seen while
2628 -- processing a global list. This routine verifies that Mode is not a
2629 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2631 procedure Check_Mode_Restriction_In_Enclosing_Context
2633 Item_Id : Entity_Id);
2634 -- Verify that an item of mode In_Out or Output does not appear as
2635 -- an input in the Global aspect of an enclosing subprogram or task
2636 -- unit. If this is the case, emit an error. Item and Item_Id are
2637 -- respectively the item and its entity.
2639 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2640 -- Mode denotes either In_Out or Output. Depending on the kind of the
2641 -- related subprogram, emit an error if those two modes apply to a
2642 -- function (SPARK RM 6.1.4(10)).
2644 -------------------------
2645 -- Analyze_Global_Item --
2646 -------------------------
2648 procedure Analyze_Global_Item
2650 Global_Mode : Name_Id)
2652 Item_Id : Entity_Id;
2655 -- Detect one of the following cases
2657 -- with Global => (null, Name)
2658 -- with Global => (Name_1, null, Name_2)
2659 -- with Global => (Name, null)
2661 if Nkind (Item) = N_Null then
2662 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2667 Resolve_State (Item);
2669 -- Find the entity of the item. If this is a renaming, climb the
2670 -- renaming chain to reach the root object. Renamings of non-
2671 -- entire objects do not yield an entity (Empty).
2673 Item_Id := Entity_Of (Item);
2675 if Present (Item_Id) then
2677 -- A global item may denote a formal parameter of an enclosing
2678 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2679 -- provide a better error diagnostic.
2681 if Is_Formal (Item_Id) then
2682 if Scope (Item_Id) = Spec_Id then
2684 (Fix_Msg (Spec_Id, "global item cannot reference "
2685 & "parameter of subprogram &"), Item, Spec_Id);
2689 -- A global item may denote a concurrent type as long as it is
2690 -- the current instance of an enclosing protected or task type
2691 -- (SPARK RM 6.1.4).
2693 elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
2694 if Is_CCT_Instance (Item_Id, Spec_Id) then
2696 -- Pragma [Refined_]Global associated with a protected
2697 -- subprogram cannot mention the current instance of a
2698 -- protected type because the instance behaves as a
2699 -- formal parameter.
2701 if Ekind (Item_Id) = E_Protected_Type then
2702 if Scope (Spec_Id) = Item_Id then
2703 Error_Msg_Name_1 := Chars (Item_Id);
2705 (Fix_Msg (Spec_Id, "global item of subprogram & "
2706 & "cannot reference current instance of "
2707 & "protected type %"), Item, Spec_Id);
2711 -- Pragma [Refined_]Global associated with a task type
2712 -- cannot mention the current instance of a task type
2713 -- because the instance behaves as a formal parameter.
2715 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2716 if Spec_Id = Item_Id then
2717 Error_Msg_Name_1 := Chars (Item_Id);
2719 (Fix_Msg (Spec_Id, "global item of subprogram & "
2720 & "cannot reference current instance of task "
2721 & "type %"), Item, Spec_Id);
2726 -- Otherwise the global item denotes a subtype mark that is
2727 -- not a current instance.
2731 ("invalid use of subtype mark in global list", Item);
2735 -- A global item may denote the anonymous object created for a
2736 -- single protected/task type as long as the current instance
2737 -- is the same single type (SPARK RM 6.1.4).
2739 elsif Is_Single_Concurrent_Object (Item_Id)
2740 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2742 -- Pragma [Refined_]Global associated with a protected
2743 -- subprogram cannot mention the current instance of a
2744 -- protected type because the instance behaves as a formal
2747 if Is_Single_Protected_Object (Item_Id) then
2748 if Scope (Spec_Id) = Etype (Item_Id) then
2749 Error_Msg_Name_1 := Chars (Item_Id);
2751 (Fix_Msg (Spec_Id, "global item of subprogram & "
2752 & "cannot reference current instance of protected "
2753 & "type %"), Item, Spec_Id);
2757 -- Pragma [Refined_]Global associated with a task type
2758 -- cannot mention the current instance of a task type
2759 -- because the instance behaves as a formal parameter.
2761 else pragma Assert (Is_Single_Task_Object (Item_Id));
2762 if Spec_Id = Item_Id then
2763 Error_Msg_Name_1 := Chars (Item_Id);
2765 (Fix_Msg (Spec_Id, "global item of subprogram & "
2766 & "cannot reference current instance of task "
2767 & "type %"), Item, Spec_Id);
2772 -- A formal object may act as a global item inside a generic
2774 elsif Is_Formal_Object (Item_Id) then
2777 elsif Ekind (Item_Id) in E_Constant | E_Variable
2778 and then Present (Ultimate_Overlaid_Entity (Item_Id))
2781 ("overlaying object & cannot appear in Global",
2784 ("\use the overlaid object & instead",
2785 Item, Ultimate_Overlaid_Entity (Item_Id));
2788 -- The only legal references are those to abstract states,
2789 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2791 elsif Ekind (Item_Id) not in E_Abstract_State
2797 ("global item must denote object, state or current "
2798 & "instance of concurrent type", Item);
2800 if Is_Named_Number (Item_Id) then
2802 ("\named number & is not an object", Item, Item_Id);
2808 -- State related checks
2810 if Ekind (Item_Id) = E_Abstract_State then
2812 -- Package and subprogram bodies are instantiated
2813 -- individually in a separate compiler pass. Due to this
2814 -- mode of instantiation, the refinement of a state may
2815 -- no longer be visible when a subprogram body contract
2816 -- is instantiated. Since the generic template is legal,
2817 -- do not perform this check in the instance to circumvent
2823 -- An abstract state with visible refinement cannot appear
2824 -- in pragma [Refined_]Global as its place must be taken by
2825 -- some of its constituents (SPARK RM 6.1.4(7)).
2827 elsif Has_Visible_Refinement (Item_Id) then
2829 ("cannot mention state & in global refinement",
2831 SPARK_Msg_N ("\use its constituents instead", Item);
2834 -- If the reference to the abstract state appears in an
2835 -- enclosing package body that will eventually refine the
2836 -- state, record the reference for future checks.
2839 Record_Possible_Body_Reference
2840 (State_Id => Item_Id,
2844 -- Constant related checks
2846 elsif Ekind (Item_Id) = E_Constant then
2848 -- Constant is a read-only item, therefore it cannot act as
2851 if Global_Mode in Name_In_Out | Name_Output then
2853 -- Constant of an access-to-variable type is a read-write
2854 -- item in procedures, generic procedures, protected
2855 -- entries and tasks.
2857 if Is_Access_Variable (Etype (Item_Id))
2858 and then (Ekind (Spec_Id) in E_Entry
2861 | E_Generic_Procedure
2863 or else Is_Single_Task_Object (Spec_Id)
2865 Is_Function_With_Side_Effects (Spec_Id))
2870 ("constant & cannot act as output", Item, Item_Id);
2875 -- Loop parameter related checks
2877 elsif Ekind (Item_Id) = E_Loop_Parameter then
2879 -- A loop parameter is a read-only item, therefore it cannot
2880 -- act as an output.
2882 if Global_Mode in Name_In_Out | Name_Output then
2884 ("loop parameter & cannot act as output",
2890 -- When the item renames an entire object, replace the item
2891 -- with a reference to the object.
2893 if Entity (Item) /= Item_Id then
2894 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2898 -- Some form of illegal construct masquerading as a name
2899 -- (SPARK RM 6.1.4(4)).
2903 ("global item must denote object, state or current instance "
2904 & "of concurrent type", Item);
2908 -- Verify that an output does not appear as an input in an
2909 -- enclosing subprogram.
2911 if Global_Mode in Name_In_Out | Name_Output then
2912 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2915 -- The same entity might be referenced through various way.
2916 -- Check the entity of the item rather than the item itself
2917 -- (SPARK RM 6.1.4(10)).
2919 if Contains (Seen, Item_Id) then
2920 SPARK_Msg_N ("duplicate global item", Item);
2922 -- Add the entity of the current item to the list of processed
2926 Append_New_Elmt (Item_Id, Seen);
2928 if Ekind (Item_Id) = E_Abstract_State then
2929 Append_New_Elmt (Item_Id, States_Seen);
2931 -- The variable may eventually become a constituent of a single
2932 -- protected/task type. Record the reference now and verify its
2933 -- legality when analyzing the contract of the variable
2936 elsif Ekind (Item_Id) = E_Variable then
2937 Record_Possible_Part_Of_Reference
2942 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
2943 and then Present (Encapsulating_State (Item_Id))
2945 Append_New_Elmt (Item_Id, Constits_Seen);
2948 end Analyze_Global_Item;
2950 --------------------------
2951 -- Check_Duplicate_Mode --
2952 --------------------------
2954 procedure Check_Duplicate_Mode
2956 Status : in out Boolean)
2960 SPARK_Msg_N ("duplicate global mode", Mode);
2964 end Check_Duplicate_Mode;
2966 -------------------------------------------------
2967 -- Check_Mode_Restriction_In_Enclosing_Context --
2968 -------------------------------------------------
2970 procedure Check_Mode_Restriction_In_Enclosing_Context
2972 Item_Id : Entity_Id)
2974 Context : Entity_Id;
2976 Inputs : Elist_Id := No_Elist;
2977 Outputs : Elist_Id := No_Elist;
2980 -- Traverse the scope stack looking for enclosing subprograms or
2981 -- tasks subject to pragma [Refined_]Global.
2983 Context := Scope (Subp_Id);
2984 while Present (Context) and then Context /= Standard_Standard loop
2986 -- For a single task type, retrieve the corresponding object to
2987 -- which pragma [Refined_]Global is attached.
2989 if Ekind (Context) = E_Task_Type
2990 and then Is_Single_Concurrent_Type (Context)
2992 Context := Anonymous_Object (Context);
2995 if Is_Subprogram_Or_Entry (Context)
2996 or else Ekind (Context) = E_Task_Type
2997 or else Is_Single_Task_Object (Context)
2999 Collect_Subprogram_Inputs_Outputs
3000 (Subp_Id => Context,
3001 Subp_Inputs => Inputs,
3002 Subp_Outputs => Outputs,
3003 Global_Seen => Dummy);
3005 -- The item is classified as In_Out or Output but appears as
3006 -- an Input or a formal parameter of mode IN in an enclosing
3007 -- subprogram or task unit (SPARK RM 6.1.4(13)).
3009 if Appears_In (Inputs, Item_Id)
3010 and then not Appears_In (Outputs, Item_Id)
3013 ("global item & cannot have mode In_Out or Output",
3016 if Is_Subprogram_Or_Entry (Context) then
3018 (Fix_Msg (Subp_Id, "\item already appears as input "
3019 & "of subprogram &"), Item, Context);
3022 (Fix_Msg (Subp_Id, "\item already appears as input "
3023 & "of task &"), Item, Context);
3026 -- Stop the traversal once an error has been detected
3032 Context := Scope (Context);
3034 end Check_Mode_Restriction_In_Enclosing_Context;
3036 ----------------------------------------
3037 -- Check_Mode_Restriction_In_Function --
3038 ----------------------------------------
3040 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
3042 if Ekind (Spec_Id) in E_Function | E_Generic_Function
3043 and then not Is_Function_With_Side_Effects (Spec_Id)
3045 Error_Msg_Code := GEC_Output_In_Function_Global_Or_Depends;
3047 ("global mode & is not applicable to function '[[]']", Mode);
3049 end Check_Mode_Restriction_In_Function;
3057 -- Start of processing for Analyze_Global_List
3060 if Nkind (List) = N_Null then
3061 Set_Analyzed (List);
3063 -- Single global item declaration
3065 elsif Nkind (List) in N_Expanded_Name
3067 | N_Selected_Component
3069 Analyze_Global_Item (List, Global_Mode);
3071 -- Simple global list or moded global list declaration
3073 elsif Nkind (List) = N_Aggregate then
3074 Set_Analyzed (List);
3076 -- The declaration of a simple global list appear as a collection
3079 if Present (Expressions (List)) then
3080 if Present (Component_Associations (List)) then
3082 ("cannot mix moded and non-moded global lists", List);
3085 Item := First (Expressions (List));
3086 while Present (Item) loop
3087 Analyze_Global_Item (Item, Global_Mode);
3091 -- The declaration of a moded global list appears as a collection
3092 -- of component associations where individual choices denote
3095 elsif Present (Component_Associations (List)) then
3096 if Present (Expressions (List)) then
3098 ("cannot mix moded and non-moded global lists", List);
3101 Assoc := First (Component_Associations (List));
3102 while Present (Assoc) loop
3103 Mode := First (Choices (Assoc));
3105 if Nkind (Mode) = N_Identifier then
3106 if Chars (Mode) = Name_In_Out then
3107 Check_Duplicate_Mode (Mode, In_Out_Seen);
3108 Check_Mode_Restriction_In_Function (Mode);
3110 elsif Chars (Mode) = Name_Input then
3111 Check_Duplicate_Mode (Mode, Input_Seen);
3113 elsif Chars (Mode) = Name_Output then
3114 Check_Duplicate_Mode (Mode, Output_Seen);
3115 Check_Mode_Restriction_In_Function (Mode);
3117 elsif Chars (Mode) = Name_Proof_In then
3118 Check_Duplicate_Mode (Mode, Proof_Seen);
3121 SPARK_Msg_N ("invalid mode selector", Mode);
3125 SPARK_Msg_N ("invalid mode selector", Mode);
3128 -- Items in a moded list appear as a collection of
3129 -- expressions. Reuse the existing machinery to analyze
3133 (List => Expression (Assoc),
3134 Global_Mode => Chars (Mode));
3142 raise Program_Error;
3145 -- Any other attempt to declare a global item is illegal. This is a
3146 -- syntax error, always report.
3149 Error_Msg_N ("malformed global list", List);
3151 end Analyze_Global_List;
3155 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
3157 Restore_Scope : Boolean := False;
3159 -- Start of processing for Analyze_Global_In_Decl_Part
3162 -- Do not analyze the pragma multiple times
3164 if Is_Analyzed_Pragma (N) then
3168 -- There is nothing to be done for a null global list
3170 if Nkind (Items) = N_Null then
3171 Set_Analyzed (Items);
3173 -- Analyze the various forms of global lists and items. Note that some
3174 -- of these may be malformed in which case the analysis emits error
3178 -- When pragma [Refined_]Global appears on a single concurrent type,
3179 -- it is relocated to the anonymous object.
3181 if Is_Single_Concurrent_Object (Spec_Id) then
3184 -- Ensure that the formal parameters are visible when processing an
3185 -- item. This falls out of the general rule of aspects pertaining to
3186 -- subprogram declarations.
3188 elsif not In_Open_Scopes (Spec_Id) then
3189 Restore_Scope := True;
3190 Push_Scope (Spec_Id);
3192 if Ekind (Spec_Id) = E_Task_Type then
3194 -- Task discriminants cannot appear in the [Refined_]Global
3195 -- contract, but must be present for the analysis so that we
3196 -- can reject them with an informative error message.
3198 if Has_Discriminants (Spec_Id) then
3199 Install_Discriminants (Spec_Id);
3202 elsif Is_Generic_Subprogram (Spec_Id) then
3203 Install_Generic_Formals (Spec_Id);
3206 Install_Formals (Spec_Id);
3210 Analyze_Global_List (Items);
3212 if Restore_Scope then
3217 -- Ensure that a state and a corresponding constituent do not appear
3218 -- together in pragma [Refined_]Global.
3220 Check_State_And_Constituent_Use
3221 (States => States_Seen,
3222 Constits => Constits_Seen,
3225 Set_Is_Analyzed_Pragma (N);
3226 end Analyze_Global_In_Decl_Part;
3228 ---------------------------------
3229 -- Analyze_If_Present_Internal --
3230 ---------------------------------
3232 procedure Analyze_If_Present_Internal
3240 pragma Assert (Is_List_Member (N));
3242 -- Inspect the declarations or statements following pragma N looking
3243 -- for another pragma whose Id matches the caller's request. If it is
3244 -- available, analyze it.
3252 while Present (Stmt) loop
3253 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
3254 Analyze_Pragma (Stmt);
3257 -- The first source declaration or statement immediately following
3258 -- N ends the region where a pragma may appear.
3260 elsif Comes_From_Source (Stmt) then
3266 end Analyze_If_Present_Internal;
3268 --------------------------------------------
3269 -- Analyze_Initial_Condition_In_Decl_Part --
3270 --------------------------------------------
3272 -- WARNING: This routine manages Ghost regions. Return statements must be
3273 -- replaced by gotos which jump to the end of the routine and restore the
3276 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
3277 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
3278 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3279 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3281 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3282 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3283 -- Save the Ghost-related attributes to restore on exit
3286 -- Do not analyze the pragma multiple times
3288 if Is_Analyzed_Pragma (N) then
3292 -- Set the Ghost mode in effect from the pragma. Due to the delayed
3293 -- analysis of the pragma, the Ghost mode at point of declaration and
3294 -- point of analysis may not necessarily be the same. Use the mode in
3295 -- effect at the point of declaration.
3299 -- The expression is preanalyzed because it has not been moved to its
3300 -- final place yet. A direct analysis may generate side effects and this
3301 -- is not desired at this point.
3303 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
3304 Set_Is_Analyzed_Pragma (N);
3306 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3307 end Analyze_Initial_Condition_In_Decl_Part;
3309 --------------------------------------
3310 -- Analyze_Initializes_In_Decl_Part --
3311 --------------------------------------
3313 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
3314 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
3315 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3317 Constits_Seen : Elist_Id := No_Elist;
3318 -- A list containing the entities of all constituents processed so far.
3319 -- It aids in detecting illegal usage of a state and a corresponding
3320 -- constituent in pragma Initializes.
3322 Items_Seen : Elist_Id := No_Elist;
3323 -- A list of all initialization items processed so far. This list is
3324 -- used to detect duplicate items.
3326 States_And_Objs : Elist_Id := No_Elist;
3327 -- A list of all abstract states and objects declared in the visible
3328 -- declarations of the related package. This list is used to detect the
3329 -- legality of initialization items.
3331 States_Seen : Elist_Id := No_Elist;
3332 -- A list containing the entities of all states processed so far. It
3333 -- helps in detecting illegal usage of a state and a corresponding
3334 -- constituent in pragma Initializes.
3336 procedure Analyze_Initialization_Item (Item : Node_Id);
3337 -- Verify the legality of a single initialization item
3339 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
3340 -- Verify the legality of a single initialization item followed by a
3341 -- list of input items.
3343 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
3344 -- Inspect the visible declarations of the related package and gather
3345 -- the entities of all abstract states and objects in States_And_Objs.
3347 ---------------------------------
3348 -- Analyze_Initialization_Item --
3349 ---------------------------------
3351 procedure Analyze_Initialization_Item (Item : Node_Id) is
3352 Item_Id : Entity_Id;
3356 Resolve_State (Item);
3358 if Is_Entity_Name (Item) then
3359 Item_Id := Entity_Of (Item);
3361 if Present (Item_Id)
3362 and then Ekind (Item_Id) in
3363 E_Abstract_State | E_Constant | E_Variable
3365 -- When the initialization item is undefined, it appears as
3366 -- Any_Id. Do not continue with the analysis of the item.
3368 if Item_Id = Any_Id then
3371 elsif Ekind (Item_Id) in E_Constant | E_Variable
3372 and then Present (Ultimate_Overlaid_Entity (Item_Id))
3375 ("overlaying object & cannot appear in Initializes",
3378 ("\use the overlaid object & instead",
3379 Item, Ultimate_Overlaid_Entity (Item_Id));
3381 -- The state or variable must be declared in the visible
3382 -- declarations of the package (SPARK RM 7.1.5(7)).
3384 elsif not Contains (States_And_Objs, Item_Id) then
3385 Error_Msg_Name_1 := Chars (Pack_Id);
3387 ("initialization item & must appear in the visible "
3388 & "declarations of package %", Item, Item_Id);
3390 -- Detect a duplicate use of the same initialization item
3391 -- (SPARK RM 7.1.5(5)).
3393 elsif Contains (Items_Seen, Item_Id) then
3394 SPARK_Msg_N ("duplicate initialization item", Item);
3396 -- The item is legal, add it to the list of processed states
3400 Append_New_Elmt (Item_Id, Items_Seen);
3402 if Ekind (Item_Id) = E_Abstract_State then
3403 Append_New_Elmt (Item_Id, States_Seen);
3406 if Present (Encapsulating_State (Item_Id)) then
3407 Append_New_Elmt (Item_Id, Constits_Seen);
3411 -- The item references something that is not a state or object
3412 -- (SPARK RM 7.1.5(3)).
3416 ("initialization item must denote object or state", Item);
3419 -- Some form of illegal construct masquerading as a name
3420 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3424 ("initialization item must denote object or state", Item);
3426 end Analyze_Initialization_Item;
3428 ---------------------------------------------
3429 -- Analyze_Initialization_Item_With_Inputs --
3430 ---------------------------------------------
3432 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
3433 Inputs_Seen : Elist_Id := No_Elist;
3434 -- A list of all inputs processed so far. This list is used to detect
3435 -- duplicate uses of an input.
3437 Non_Null_Seen : Boolean := False;
3438 Null_Seen : Boolean := False;
3439 -- Flags used to check the legality of an input list
3441 procedure Analyze_Input_Item (Input : Node_Id);
3442 -- Verify the legality of a single input item
3444 ------------------------
3445 -- Analyze_Input_Item --
3446 ------------------------
3448 procedure Analyze_Input_Item (Input : Node_Id) is
3449 Input_Id : Entity_Id;
3454 if Nkind (Input) = N_Null then
3457 ("multiple null initializations not allowed", Item);
3459 elsif Non_Null_Seen then
3461 ("cannot mix null and non-null initialization item", Item);
3469 Non_Null_Seen := True;
3473 ("cannot mix null and non-null initialization item", Item);
3477 Resolve_State (Input);
3479 if Is_Entity_Name (Input) then
3480 Input_Id := Entity_Of (Input);
3482 if Present (Input_Id)
3483 and then Ekind (Input_Id) in E_Abstract_State
3485 | E_Generic_In_Out_Parameter
3486 | E_Generic_In_Parameter
3488 | E_In_Out_Parameter
3494 -- The input cannot denote states or objects declared
3495 -- within the related package (SPARK RM 7.1.5(4)).
3497 if Within_Scope (Input_Id, Current_Scope) then
3499 -- Do not consider generic formal parameters or their
3500 -- respective mappings to generic formals. Even though
3501 -- the formals appear within the scope of the package,
3502 -- it is allowed for an initialization item to depend
3503 -- on an input item.
3505 if Is_Formal_Object (Input_Id) then
3508 elsif Ekind (Input_Id) in E_Constant | E_Variable
3509 and then Present (Corresponding_Generic_Association
3510 (Declaration_Node (Input_Id)))
3515 Error_Msg_Name_1 := Chars (Pack_Id);
3517 ("input item & cannot denote a visible object or "
3518 & "state of package %", Input, Input_Id);
3523 if Ekind (Input_Id) in E_Constant | E_Variable
3524 and then Present (Ultimate_Overlaid_Entity (Input_Id))
3527 ("overlaying object & cannot appear in Initializes",
3530 ("\use the overlaid object & instead",
3531 Input, Ultimate_Overlaid_Entity (Input_Id));
3535 -- Detect a duplicate use of the same input item
3536 -- (SPARK RM 7.1.5(5)).
3538 if Contains (Inputs_Seen, Input_Id) then
3539 SPARK_Msg_N ("duplicate input item", Input);
3543 -- At this point it is known that the input is legal. Add
3544 -- it to the list of processed inputs.
3546 Append_New_Elmt (Input_Id, Inputs_Seen);
3548 if Ekind (Input_Id) = E_Abstract_State then
3549 Append_New_Elmt (Input_Id, States_Seen);
3552 if Ekind (Input_Id) in E_Abstract_State
3555 and then Present (Encapsulating_State (Input_Id))
3557 Append_New_Elmt (Input_Id, Constits_Seen);
3560 -- The input references something that is not a state or an
3561 -- object (SPARK RM 7.1.5(3)).
3565 ("input item must denote object or state", Input);
3568 -- Some form of illegal construct masquerading as a name
3569 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3573 ("input item must denote object or state", Input);
3576 end Analyze_Input_Item;
3580 Inputs : constant Node_Id := Expression (Item);
3584 Name_Seen : Boolean := False;
3585 -- A flag used to detect multiple item names
3587 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3590 -- Inspect the name of an item with inputs
3592 Elmt := First (Choices (Item));
3593 while Present (Elmt) loop
3595 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3598 Analyze_Initialization_Item (Elmt);
3604 -- Multiple input items appear as an aggregate
3606 if Nkind (Inputs) = N_Aggregate then
3607 if Present (Expressions (Inputs)) then
3608 Input := First (Expressions (Inputs));
3609 while Present (Input) loop
3610 Analyze_Input_Item (Input);
3615 if Present (Component_Associations (Inputs)) then
3617 ("inputs must appear in named association form", Inputs);
3620 -- Single input item
3623 Analyze_Input_Item (Inputs);
3625 end Analyze_Initialization_Item_With_Inputs;
3627 --------------------------------
3628 -- Collect_States_And_Objects --
3629 --------------------------------
3631 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3632 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3633 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3635 State_Elmt : Elmt_Id;
3638 -- Collect the abstract states defined in the package (if any)
3640 if Has_Non_Null_Abstract_State (Pack_Id) then
3641 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3642 while Present (State_Elmt) loop
3643 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3644 Next_Elmt (State_Elmt);
3648 -- Collect all objects that appear in the visible declarations of the
3651 Decl := First (Visible_Declarations (Pack_Spec));
3652 while Present (Decl) loop
3653 if Comes_From_Source (Decl)
3654 and then Nkind (Decl) in N_Object_Declaration
3655 | N_Object_Renaming_Declaration
3657 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3659 elsif Nkind (Decl) = N_Package_Declaration then
3660 Collect_States_And_Objects (Decl);
3662 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3664 (Anonymous_Object (Defining_Entity (Decl)),
3670 end Collect_States_And_Objects;
3674 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3677 -- Start of processing for Analyze_Initializes_In_Decl_Part
3680 -- Do not analyze the pragma multiple times
3682 if Is_Analyzed_Pragma (N) then
3686 -- Nothing to do when the initialization list is empty
3688 if Nkind (Inits) = N_Null then
3692 -- Single and multiple initialization clauses appear as an aggregate. If
3693 -- this is not the case, then either the parser or the analysis of the
3694 -- pragma failed to produce an aggregate.
3696 pragma Assert (Nkind (Inits) = N_Aggregate);
3698 -- Initialize the various lists used during analysis
3700 Collect_States_And_Objects (Pack_Decl);
3702 if Present (Expressions (Inits)) then
3703 Init := First (Expressions (Inits));
3704 while Present (Init) loop
3705 Analyze_Initialization_Item (Init);
3710 if Present (Component_Associations (Inits)) then
3711 Init := First (Component_Associations (Inits));
3712 while Present (Init) loop
3713 Analyze_Initialization_Item_With_Inputs (Init);
3718 -- Ensure that a state and a corresponding constituent do not appear
3719 -- together in pragma Initializes.
3721 Check_State_And_Constituent_Use
3722 (States => States_Seen,
3723 Constits => Constits_Seen,
3726 Set_Is_Analyzed_Pragma (N);
3727 end Analyze_Initializes_In_Decl_Part;
3729 ---------------------
3730 -- Analyze_Part_Of --
3731 ---------------------
3733 procedure Analyze_Part_Of
3735 Item_Id : Entity_Id;
3737 Encap_Id : out Entity_Id;
3738 Legal : out Boolean)
3740 procedure Check_Part_Of_Abstract_State;
3741 pragma Inline (Check_Part_Of_Abstract_State);
3742 -- Verify the legality of indicator Part_Of when the encapsulator is an
3745 procedure Check_Part_Of_Concurrent_Type;
3746 pragma Inline (Check_Part_Of_Concurrent_Type);
3747 -- Verify the legality of indicator Part_Of when the encapsulator is a
3748 -- single concurrent type.
3750 ----------------------------------
3751 -- Check_Part_Of_Abstract_State --
3752 ----------------------------------
3754 procedure Check_Part_Of_Abstract_State is
3755 Pack_Id : Entity_Id;
3756 Placement : State_Space_Kind;
3757 Parent_Unit : Entity_Id;
3760 -- Determine where the object, package instantiation or state lives
3761 -- with respect to the enclosing packages or package bodies.
3763 Find_Placement_In_State_Space
3764 (Item_Id => Item_Id,
3765 Placement => Placement,
3766 Pack_Id => Pack_Id);
3768 -- The item appears in a non-package construct with a declarative
3769 -- part (subprogram, block, etc). As such, the item is not allowed
3770 -- to be a part of an encapsulating state because the item is not
3773 if Placement = Not_In_Package then
3775 ("indicator Part_Of cannot appear in this context "
3776 & "(SPARK RM 7.2.6(5))", Indic);
3778 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3780 ("\& is not part of the hidden state of package %",
3784 -- The item appears in the visible state space of some package. In
3785 -- general this scenario does not warrant Part_Of except when the
3786 -- package is a nongeneric private child unit and the encapsulating
3787 -- state is declared in a parent unit or a public descendant of that
3790 elsif Placement = Visible_State_Space then
3791 if Is_Child_Unit (Pack_Id)
3792 and then not Is_Generic_Unit (Pack_Id)
3793 and then Is_Private_Descendant (Pack_Id)
3795 -- A variable or state abstraction which is part of the visible
3796 -- state of a nongeneric private child unit or its public
3797 -- descendants must have its Part_Of indicator specified. The
3798 -- Part_Of indicator must denote a state declared by either the
3799 -- parent unit of the private unit or by a public descendant of
3800 -- that parent unit.
3802 -- Find the nearest private ancestor (which can be the current
3805 Parent_Unit := Pack_Id;
3806 while Present (Parent_Unit) loop
3807 exit when Is_Private_Library_Unit (Parent_Unit);
3808 Parent_Unit := Scope (Parent_Unit);
3811 Parent_Unit := Scope (Parent_Unit);
3813 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3815 ("indicator Part_Of must denote abstract state of & or of "
3816 & "its public descendant (SPARK RM 7.2.6(3))",
3817 Indic, Parent_Unit);
3820 elsif Scope (Encap_Id) = Parent_Unit
3822 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3823 and then not Is_Private_Descendant (Scope (Encap_Id)))
3829 ("indicator Part_Of must denote abstract state of & or of "
3830 & "its public descendant (SPARK RM 7.2.6(3))",
3831 Indic, Parent_Unit);
3835 -- Indicator Part_Of is not needed when the related package is
3836 -- not a nongeneric private child unit or a public descendant
3841 ("indicator Part_Of cannot appear in this context "
3842 & "(SPARK RM 7.2.6(5))", Indic);
3844 Error_Msg_Name_1 := Chars (Pack_Id);
3846 ("\& is declared in the visible part of package %",
3851 -- When the item appears in the private state space of a package, the
3852 -- encapsulating state must be declared in the same package.
3854 elsif Placement = Private_State_Space then
3856 -- In the case of the abstract state of a nongeneric private
3857 -- child package, it may be encapsulated in the state of a
3858 -- public descendant of its parent package.
3861 function Is_Public_Descendant
3862 (Child, Ancestor : Entity_Id)
3864 -- Return True if Child is a public descendant of Pack
3866 --------------------------
3867 -- Is_Public_Descendant --
3868 --------------------------
3870 function Is_Public_Descendant
3871 (Child, Ancestor : Entity_Id)
3874 P : Entity_Id := Child;
3876 while Is_Child_Unit (P)
3877 and then not Is_Private_Library_Unit (P)
3879 if Scope (P) = Ancestor then
3887 end Is_Public_Descendant;
3891 Immediate_Pack_Id : constant Entity_Id := Scope (Item_Id);
3893 Is_State_Of_Private_Child : constant Boolean :=
3894 Is_Child_Unit (Immediate_Pack_Id)
3895 and then not Is_Generic_Unit (Immediate_Pack_Id)
3896 and then Is_Private_Descendant (Immediate_Pack_Id);
3898 Is_OK_Through_Sibling : Boolean := False;
3901 if Ekind (Item_Id) = E_Abstract_State
3902 and then Is_State_Of_Private_Child
3903 and then Is_Public_Descendant (Scope (Encap_Id), Pack_Id)
3905 Is_OK_Through_Sibling := True;
3908 if Scope (Encap_Id) /= Pack_Id
3909 and then not Is_OK_Through_Sibling
3911 if Is_State_Of_Private_Child then
3913 ("indicator Part_Of must denote abstract state of & "
3914 & "or of its public descendant "
3915 & "(SPARK RM 7.2.6(3))", Indic, Pack_Id);
3918 ("indicator Part_Of must denote an abstract state of "
3919 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3922 Error_Msg_Name_1 := Chars (Pack_Id);
3924 ("\& is declared in the private part of package %",
3930 -- Items declared in the body state space of a package do not need
3931 -- Part_Of indicators as the refinement has already been seen.
3935 ("indicator Part_Of cannot appear in this context "
3936 & "(SPARK RM 7.2.6(5))", Indic);
3938 if Scope (Encap_Id) = Pack_Id then
3939 Error_Msg_Name_1 := Chars (Pack_Id);
3941 ("\& is declared in the body of package %", Indic, Item_Id);
3947 -- In the case of state in a (descendant of a private) child which
3948 -- is Part_Of the state of another package, the package defining the
3949 -- encapsulating abstract state should have a body, to ensure that it
3950 -- has a state refinement (SPARK RM 7.1.4(4)).
3952 if Enclosing_Comp_Unit_Node (Encap_Id) /=
3953 Enclosing_Comp_Unit_Node (Item_Id)
3954 and then not Unit_Requires_Body (Scope (Encap_Id))
3957 ("indicator Part_Of must denote abstract state of package "
3958 & "with a body (SPARK RM 7.1.4(4))", Indic);
3962 -- At this point it is known that the Part_Of indicator is legal
3965 end Check_Part_Of_Abstract_State;
3967 -----------------------------------
3968 -- Check_Part_Of_Concurrent_Type --
3969 -----------------------------------
3971 procedure Check_Part_Of_Concurrent_Type is
3972 function In_Proper_Order
3974 Second : Node_Id) return Boolean;
3975 pragma Inline (In_Proper_Order);
3976 -- Determine whether node First precedes node Second
3978 procedure Placement_Error;
3979 pragma Inline (Placement_Error);
3980 -- Emit an error concerning the illegal placement of the item with
3981 -- respect to the single concurrent type.
3983 ---------------------
3984 -- In_Proper_Order --
3985 ---------------------
3987 function In_Proper_Order
3989 Second : Node_Id) return Boolean
3994 if List_Containing (First) = List_Containing (Second) then
3996 while Present (N) loop
4006 end In_Proper_Order;
4008 ---------------------
4009 -- Placement_Error --
4010 ---------------------
4012 procedure Placement_Error is
4015 ("indicator Part_Of must denote a previously declared single "
4016 & "protected type or single task type", Encap);
4017 end Placement_Error;
4021 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
4022 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
4023 Encap_Context : constant Node_Id := Parent (Encap_Decl);
4025 Item_Context : Node_Id;
4026 Item_Decl : Node_Id;
4027 Prv_Decls : List_Id;
4028 Vis_Decls : List_Id;
4030 -- Start of processing for Check_Part_Of_Concurrent_Type
4033 -- Only abstract states and variables can act as constituents of an
4034 -- encapsulating single concurrent type.
4036 if Ekind (Item_Id) in E_Abstract_State | E_Variable then
4039 -- The constituent is a constant
4041 elsif Ekind (Item_Id) = E_Constant then
4042 Error_Msg_Name_1 := Chars (Encap_Id);
4044 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
4045 & "single protected type %"), Indic, Item_Id);
4048 -- The constituent is a package instantiation
4051 Error_Msg_Name_1 := Chars (Encap_Id);
4053 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
4054 & "constituent of single protected type %"), Indic, Item_Id);
4058 -- When the item denotes an abstract state of a nested package, use
4059 -- the declaration of the package to detect proper placement.
4064 -- with Abstract_State => (State with Part_Of => T)
4066 if Ekind (Item_Id) = E_Abstract_State then
4067 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
4069 Item_Decl := Declaration_Node (Item_Id);
4072 Item_Context := Parent (Item_Decl);
4074 -- The item and the single concurrent type must appear in the same
4075 -- declarative region, with the item following the declaration of
4076 -- the single concurrent type (SPARK RM 9(3)).
4078 if Item_Context = Encap_Context then
4079 if Nkind (Item_Context) in N_Package_Specification
4080 | N_Protected_Definition
4083 Prv_Decls := Private_Declarations (Item_Context);
4084 Vis_Decls := Visible_Declarations (Item_Context);
4086 -- The placement is OK when the single concurrent type appears
4087 -- within the visible declarations and the item in the private
4093 -- Constit : ... with Part_Of => PO;
4096 if List_Containing (Encap_Decl) = Vis_Decls
4097 and then List_Containing (Item_Decl) = Prv_Decls
4101 -- The placement is illegal when the item appears within the
4102 -- visible declarations and the single concurrent type is in
4103 -- the private declarations.
4106 -- Constit : ... with Part_Of => PO;
4111 elsif List_Containing (Item_Decl) = Vis_Decls
4112 and then List_Containing (Encap_Decl) = Prv_Decls
4117 -- Otherwise both the item and the single concurrent type are
4118 -- in the same list. Ensure that the declaration of the single
4119 -- concurrent type precedes that of the item.
4121 elsif not In_Proper_Order
4122 (First => Encap_Decl,
4123 Second => Item_Decl)
4129 -- Otherwise both the item and the single concurrent type are
4130 -- in the same list. Ensure that the declaration of the single
4131 -- concurrent type precedes that of the item.
4133 elsif not In_Proper_Order
4134 (First => Encap_Decl,
4135 Second => Item_Decl)
4141 -- Otherwise the item and the single concurrent type reside within
4142 -- unrelated regions.
4145 Error_Msg_Name_1 := Chars (Encap_Id);
4147 (Fix_Msg (Conc_Typ, "constituent & must be declared "
4148 & "immediately within the same region as single protected "
4149 & "type %"), Indic, Item_Id);
4153 -- At this point it is known that the Part_Of indicator is legal
4156 end Check_Part_Of_Concurrent_Type;
4158 -- Start of processing for Analyze_Part_Of
4161 -- Assume that the indicator is illegal
4167 N_Expanded_Name | N_Identifier | N_Selected_Component
4170 Resolve_State (Encap);
4172 Encap_Id := Entity (Encap);
4174 -- The encapsulator is an abstract state
4176 if Ekind (Encap_Id) = E_Abstract_State then
4179 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
4181 elsif Is_Single_Concurrent_Object (Encap_Id) then
4184 -- Otherwise the encapsulator is not a legal choice
4188 ("indicator Part_Of must denote abstract state, single "
4189 & "protected type or single task type", Encap);
4193 -- This is a syntax error, always report
4197 ("indicator Part_Of must denote abstract state, single protected "
4198 & "type or single task type", Encap);
4202 -- Catch a case where indicator Part_Of denotes the abstract view of a
4203 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
4205 if From_Limited_With (Encap_Id)
4206 and then Present (Non_Limited_View (Encap_Id))
4207 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
4209 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
4210 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
4214 -- The encapsulator is an abstract state
4216 if Ekind (Encap_Id) = E_Abstract_State then
4217 Check_Part_Of_Abstract_State;
4219 -- The encapsulator is a single concurrent type
4222 Check_Part_Of_Concurrent_Type;
4224 end Analyze_Part_Of;
4226 ----------------------------------
4227 -- Analyze_Part_Of_In_Decl_Part --
4228 ----------------------------------
4230 procedure Analyze_Part_Of_In_Decl_Part
4232 Freeze_Id : Entity_Id := Empty)
4234 Encap : constant Node_Id :=
4235 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
4236 Errors : constant Nat := Serious_Errors_Detected;
4237 Var_Decl : constant Node_Id := Find_Related_Context (N);
4238 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
4239 Constits : Elist_Id;
4240 Encap_Id : Entity_Id;
4244 -- Detect any discrepancies between the placement of the variable with
4245 -- respect to general state space and the encapsulating state or single
4252 Encap_Id => Encap_Id,
4255 -- The Part_Of indicator turns the variable into a constituent of the
4256 -- encapsulating state or single concurrent type.
4259 pragma Assert (Present (Encap_Id));
4260 Constits := Part_Of_Constituents (Encap_Id);
4262 if No (Constits) then
4263 Constits := New_Elmt_List;
4264 Set_Part_Of_Constituents (Encap_Id, Constits);
4267 Append_Elmt (Var_Id, Constits);
4268 Set_Encapsulating_State (Var_Id, Encap_Id);
4270 -- A Part_Of constituent partially refines an abstract state. This
4271 -- property does not apply to protected or task units.
4273 if Ekind (Encap_Id) = E_Abstract_State then
4274 Set_Has_Partial_Visible_Refinement (Encap_Id);
4278 -- Emit a clarification message when the encapsulator is undefined,
4279 -- possibly due to contract freezing.
4281 if Errors /= Serious_Errors_Detected
4282 and then Present (Freeze_Id)
4283 and then Has_Undefined_Reference (Encap)
4285 Contract_Freeze_Error (Var_Id, Freeze_Id);
4287 end Analyze_Part_Of_In_Decl_Part;
4289 --------------------
4290 -- Analyze_Pragma --
4291 --------------------
4293 procedure Analyze_Pragma (N : Node_Id) is
4294 Loc : constant Source_Ptr := Sloc (N);
4296 Pname : Name_Id := Pragma_Name (N);
4297 -- Name of the source pragma, or name of the corresponding aspect for
4298 -- pragmas which originate in a source aspect. In the latter case, the
4299 -- name may be different from the pragma name.
4301 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
4303 Pragma_Exit : exception;
4304 -- This exception is used to exit pragma processing completely. It
4305 -- is used when an error is detected, and no further processing is
4306 -- required. It is also used if an earlier error has left the tree in
4307 -- a state where the pragma should not be processed.
4310 -- Number of pragma argument associations
4317 -- First five pragma arguments (pragma argument association nodes, or
4318 -- Empty if the corresponding argument does not exist).
4320 type Name_List is array (Natural range <>) of Name_Id;
4321 type Args_List is array (Natural range <>) of Node_Id;
4322 -- Types used for arguments to Check_Arg_Order and Gather_Associations
4324 -----------------------
4325 -- Local Subprograms --
4326 -----------------------
4328 procedure Ada_2005_Pragma;
4329 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
4330 -- Ada 95 mode, these are implementation defined pragmas, so should be
4331 -- caught by the No_Implementation_Pragmas restriction.
4333 procedure Ada_2012_Pragma;
4334 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
4335 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
4336 -- should be caught by the No_Implementation_Pragmas restriction.
4338 procedure Analyze_Depends_Global
4339 (Spec_Id : out Entity_Id;
4340 Subp_Decl : out Node_Id;
4341 Legal : out Boolean);
4342 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
4343 -- legality of the placement and related context of the pragma. Spec_Id
4344 -- is the entity of the related subprogram. Subp_Decl is the declaration
4345 -- of the related subprogram. Sets flag Legal when the pragma is legal.
4347 procedure Analyze_If_Present (Id : Pragma_Id);
4348 -- Inspect the remainder of the list containing pragma N and look for
4349 -- a pragma that matches Id. If found, analyze the pragma.
4351 procedure Analyze_Pre_Post_Condition;
4352 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
4354 procedure Analyze_Refined_Depends_Global_Post
4355 (Spec_Id : out Entity_Id;
4356 Body_Id : out Entity_Id;
4357 Legal : out Boolean);
4358 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
4359 -- Refined_Global and Refined_Post. Verify the legality of the placement
4360 -- and related context of the pragma. Spec_Id is the entity of the
4361 -- related subprogram. Body_Id is the entity of the subprogram body.
4362 -- Flag Legal is set when the pragma is legal.
4364 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
4365 -- Perform full analysis of pragma Unmodified and the write aspect of
4366 -- pragma Unused. Flag Is_Unused should be set when verifying the
4367 -- semantics of pragma Unused.
4369 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
4370 -- Perform full analysis of pragma Unreferenced and the read aspect of
4371 -- pragma Unused. Flag Is_Unused should be set when verifying the
4372 -- semantics of pragma Unused.
4374 procedure Check_Ada_83_Warning;
4375 -- Issues a warning message for the current pragma if operating in Ada
4376 -- 83 mode (used for language pragmas that are not a standard part of
4377 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
4380 procedure Check_Arg_Count (Required : Nat);
4381 -- Check argument count for pragma is equal to given parameter. If not,
4382 -- then issue an error message and raise Pragma_Exit.
4384 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
4385 -- Arg which can either be a pragma argument association, in which case
4386 -- the check is applied to the expression of the association or an
4387 -- expression directly.
4389 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
4390 -- Check that an argument has the right form for an EXTERNAL_NAME
4391 -- parameter of an extended import/export pragma. The rule is that the
4392 -- name must be an identifier or string literal (in Ada 83 mode) or a
4393 -- static string expression (in Ada 95 mode).
4395 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
4396 -- Check the specified argument Arg to make sure that it is an
4397 -- identifier. If not give error and raise Pragma_Exit.
4399 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
4400 -- Check the specified argument Arg to make sure that it is an integer
4401 -- literal. If not give error and raise Pragma_Exit.
4403 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
4404 -- Check the specified argument Arg to make sure that it has the proper
4405 -- syntactic form for a local name and meets the semantic requirements
4406 -- for a local name. The local name is analyzed as part of the
4407 -- processing for this call. In addition, the local name is required
4408 -- to represent an entity at the library level.
4410 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
4411 -- Check the specified argument Arg to make sure that it has the proper
4412 -- syntactic form for a local name and meets the semantic requirements
4413 -- for a local name. The local name is analyzed as part of the
4414 -- processing for this call.
4416 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
4417 -- Check the specified argument Arg to make sure that it is a valid
4418 -- locking policy name. If not give error and raise Pragma_Exit.
4420 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
4421 -- Check the specified argument Arg to make sure that it is a valid
4422 -- elaboration policy name. If not give error and raise Pragma_Exit.
4424 procedure Check_Arg_Is_One_Of
4427 procedure Check_Arg_Is_One_Of
4429 N1, N2, N3 : Name_Id);
4430 procedure Check_Arg_Is_One_Of
4432 N1, N2, N3, N4 : Name_Id);
4433 procedure Check_Arg_Is_One_Of
4435 N1, N2, N3, N4, N5 : Name_Id);
4436 -- Check the specified argument Arg to make sure that it is an
4437 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
4438 -- present). If not then give error and raise Pragma_Exit.
4440 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
4441 -- Check the specified argument Arg to make sure that it is a valid
4442 -- queuing policy name. If not give error and raise Pragma_Exit.
4444 procedure Check_Arg_Is_OK_Static_Expression
4446 Typ : Entity_Id := Empty);
4447 -- Check the specified argument Arg to make sure that it is a static
4448 -- expression of the given type (i.e. it will be analyzed and resolved
4449 -- using this type, which can be any valid argument to Resolve, e.g.
4450 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4451 -- Typ is left Empty, then any static expression is allowed. Includes
4452 -- checking that the argument does not raise Constraint_Error.
4454 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
4455 -- Check the specified argument Arg to make sure that it is a valid task
4456 -- dispatching policy name. If not give error and raise Pragma_Exit.
4458 procedure Check_Arg_Order (Names : Name_List);
4459 -- Checks for an instance of two arguments with identifiers for the
4460 -- current pragma which are not in the sequence indicated by Names,
4461 -- and if so, generates a fatal message about bad order of arguments.
4463 procedure Check_At_Least_N_Arguments (N : Nat);
4464 -- Check there are at least N arguments present
4466 procedure Check_At_Most_N_Arguments (N : Nat);
4467 -- Check there are no more than N arguments present
4469 procedure Check_Component
4472 In_Variant_Part : Boolean := False);
4473 -- Examine an Unchecked_Union component for correct use of per-object
4474 -- constrained subtypes, and for restrictions on finalizable components.
4475 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
4476 -- should be set when Comp comes from a record variant.
4478 procedure Check_Duplicate_Pragma (E : Entity_Id);
4479 -- Check if a rep item of the same name as the current pragma is already
4480 -- chained as a rep pragma to the given entity. If so give a message
4481 -- about the duplicate, and then raise Pragma_Exit so does not return.
4482 -- Note that if E is a type, then this routine avoids flagging a pragma
4483 -- which applies to a parent type from which E is derived.
4485 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
4486 -- Nam is an N_String_Literal node containing the external name set by
4487 -- an Import or Export pragma (or extended Import or Export pragma).
4488 -- This procedure checks for possible duplications if this is the export
4489 -- case, and if found, issues an appropriate error message.
4491 procedure Check_Expr_Is_OK_Static_Expression
4493 Typ : Entity_Id := Empty);
4494 -- Check the specified expression Expr to make sure that it is a static
4495 -- expression of the given type (i.e. it will be analyzed and resolved
4496 -- using this type, which can be any valid argument to Resolve, e.g.
4497 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4498 -- Typ is left Empty, then any static expression is allowed. Includes
4499 -- checking that the expression does not raise Constraint_Error.
4501 procedure Check_First_Subtype (Arg : Node_Id);
4502 -- Checks that Arg, whose expression is an entity name, references a
4505 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
4506 -- Checks that the given argument has an identifier, and if so, requires
4507 -- it to match the given identifier name. If there is no identifier, or
4508 -- a non-matching identifier, then an error message is given and
4509 -- Pragma_Exit is raised.
4511 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
4512 -- Checks that the given argument has an identifier, and if so, requires
4513 -- it to match one of the given identifier names. If there is no
4514 -- identifier, or a non-matching identifier, then an error message is
4515 -- given and Pragma_Exit is raised.
4517 procedure Check_In_Main_Program;
4518 -- Common checks for pragmas that appear within a main program
4519 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4521 procedure Check_Interrupt_Or_Attach_Handler;
4522 -- Common processing for first argument of pragma Interrupt_Handler or
4523 -- pragma Attach_Handler.
4525 procedure Check_Loop_Pragma_Placement;
4526 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4527 -- appear immediately within a construct restricted to loops, and that
4528 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4530 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
4531 -- Check that pragma appears in a declarative part, or in a package
4532 -- specification, i.e. that it does not occur in a statement sequence
4535 procedure Check_No_Identifier (Arg : Node_Id);
4536 -- Checks that the given argument does not have an identifier. If
4537 -- an identifier is present, then an error message is issued, and
4538 -- Pragma_Exit is raised.
4540 procedure Check_No_Identifiers;
4541 -- Checks that none of the arguments to the pragma has an identifier.
4542 -- If any argument has an identifier, then an error message is issued,
4543 -- and Pragma_Exit is raised.
4545 procedure Check_No_Link_Name;
4546 -- Checks that no link name is specified
4548 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4549 -- Checks if the given argument has an identifier, and if so, requires
4550 -- it to match the given identifier name. If there is a non-matching
4551 -- identifier, then an error message is given and Pragma_Exit is raised.
4553 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4554 -- Checks if the given argument has an identifier, and if so, requires
4555 -- it to match the given identifier name. If there is a non-matching
4556 -- identifier, then an error message is given and Pragma_Exit is raised.
4557 -- In this version of the procedure, the identifier name is given as
4558 -- a string with lower case letters.
4560 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4561 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4562 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4563 -- Extensions_Visible, Side_Effects and Volatile_Function. Ensure
4564 -- that expression Expr is an OK static boolean expression. Emit an
4565 -- error if this is not the case.
4567 procedure Check_Static_Constraint (Constr : Node_Id);
4568 -- Constr is a constraint from an N_Subtype_Indication node from a
4569 -- component constraint in an Unchecked_Union type, a range, or a
4570 -- discriminant association. This routine checks that the constraint
4571 -- is static as required by the restrictions for Unchecked_Union.
4573 procedure Check_Valid_Configuration_Pragma;
4574 -- Legality checks for placement of a configuration pragma
4576 procedure Check_Valid_Library_Unit_Pragma;
4577 -- Legality checks for library unit pragmas. A special case arises for
4578 -- pragmas in generic instances that come from copies of the original
4579 -- library unit pragmas in the generic templates. In the case of other
4580 -- than library level instantiations these can appear in contexts which
4581 -- would normally be invalid (they only apply to the original template
4582 -- and to library level instantiations), and they are simply ignored,
4583 -- which is implemented by rewriting them as null statements and
4584 -- optionally raising Pragma_Exit to terminate analysis. An exception
4585 -- is not always raised to avoid exception propagation during the
4586 -- bootstrap, so all callers should check whether N has been rewritten.
4588 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4589 -- Check an Unchecked_Union variant for lack of nested variants and
4590 -- presence of at least one component. UU_Typ is the related Unchecked_
4593 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4594 -- Subsidiary routine to the processing of pragmas Abstract_State,
4595 -- Contract_Cases, Depends, Exceptional_Cases, Global, Initializes,
4596 -- Refined_Depends, Refined_Global, Refined_State and
4597 -- Subprogram_Variant. Transform argument Arg into an aggregate if not
4598 -- one already. N_Null is never transformed. Arg may denote an aspect
4599 -- specification or a pragma argument association.
4601 procedure Error_Pragma (Msg : String);
4602 pragma No_Return (Error_Pragma);
4603 -- Outputs error message for current pragma. The message contains a %
4604 -- that will be replaced with the pragma name, and the flag is placed
4605 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4606 -- calls Fix_Error (see spec of that procedure for details).
4608 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4609 pragma No_Return (Error_Pragma_Arg);
4610 -- Outputs error message for current pragma. The message may contain
4611 -- a % that will be replaced with the pragma name. The parameter Arg
4612 -- may either be a pragma argument association, in which case the flag
4613 -- is placed on the expression of this association, or an expression,
4614 -- in which case the flag is placed directly on the expression. The
4615 -- message is placed using Error_Msg_N, so the message may also contain
4616 -- an & insertion character which will reference the given Arg value.
4617 -- After placing the message, Pragma_Exit is raised. Note: this routine
4618 -- calls Fix_Error (see spec of that procedure for details).
4620 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4621 pragma No_Return (Error_Pragma_Arg);
4622 -- Similar to above form of Error_Pragma_Arg except that two messages
4623 -- are provided, the second is a continuation comment starting with \.
4625 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4626 pragma No_Return (Error_Pragma_Arg_Ident);
4627 -- Outputs error message for current pragma. The message may contain a %
4628 -- that will be replaced with the pragma name. The parameter Arg must be
4629 -- a pragma argument association with a non-empty identifier (i.e. its
4630 -- Chars field must be set), and the error message is placed on the
4631 -- identifier. The message is placed using Error_Msg_N so the message
4632 -- may also contain an & insertion character which will reference
4633 -- the identifier. After placing the message, Pragma_Exit is raised.
4634 -- Note: this routine calls Fix_Error (see spec of that procedure for
4637 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4638 pragma No_Return (Error_Pragma_Ref);
4639 -- Outputs error message for current pragma. The message may contain
4640 -- a % that will be replaced with the pragma name. The parameter Ref
4641 -- must be an entity whose name can be referenced by & and sloc by #.
4642 -- After placing the message, Pragma_Exit is raised. Note: this routine
4643 -- calls Fix_Error (see spec of that procedure for details).
4645 function Find_Lib_Unit_Name return Entity_Id;
4646 -- Used for a library unit pragma to find the entity to which the
4647 -- library unit pragma applies, returns the entity found.
4649 procedure Find_Program_Unit_Name (Id : Node_Id);
4650 -- If the pragma is a compilation unit pragma, the id must denote the
4651 -- compilation unit in the same compilation, and the pragma must appear
4652 -- in the list of preceding or trailing pragmas. If it is a program
4653 -- unit pragma that is not a compilation unit pragma, then the
4654 -- identifier must be visible.
4656 function Find_Unique_Parameterless_Procedure
4658 Arg : Node_Id) return Entity_Id;
4659 -- Used for a procedure pragma to find the unique parameterless
4660 -- procedure identified by Name, returns it if it exists, otherwise
4661 -- errors out and uses Arg as the pragma argument for the message.
4663 function Fix_Error (Msg : String) return String;
4664 -- This is called prior to issuing an error message. Msg is the normal
4665 -- error message issued in the pragma case. This routine checks for the
4666 -- case of a pragma coming from an aspect in the source, and returns a
4667 -- message suitable for the aspect case as follows:
4669 -- Each substring "pragma" is replaced by "aspect"
4671 -- If "argument of" is at the start of the error message text, it is
4672 -- replaced by "entity for".
4674 -- If "argument" is at the start of the error message text, it is
4675 -- replaced by "entity".
4677 -- So for example, "argument of pragma X must be discrete type"
4678 -- returns "entity for aspect X must be a discrete type".
4680 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4681 -- be different from the pragma name). If the current pragma results
4682 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4683 -- original pragma name.
4685 procedure Gather_Associations
4687 Args : out Args_List);
4688 -- This procedure is used to gather the arguments for a pragma that
4689 -- permits arbitrary ordering of parameters using the normal rules
4690 -- for named and positional parameters. The Names argument is a list
4691 -- of Name_Id values that corresponds to the allowed pragma argument
4692 -- association identifiers in order. The result returned in Args is
4693 -- a list of corresponding expressions that are the pragma arguments.
4694 -- Note that this is a list of expressions, not of pragma argument
4695 -- associations (Gather_Associations has completely checked all the
4696 -- optional identifiers when it returns). An entry in Args is Empty
4697 -- on return if the corresponding argument is not present.
4699 procedure GNAT_Pragma;
4700 -- Called for all GNAT defined pragmas to check the relevant restriction
4701 -- (No_Implementation_Pragmas).
4703 function Is_Before_First_Decl
4704 (Pragma_Node : Node_Id;
4705 Decls : List_Id) return Boolean;
4706 -- Return True if Pragma_Node is before the first declarative item in
4707 -- Decls where Decls is the list of declarative items.
4709 function Is_Configuration_Pragma return Boolean;
4710 -- Determines if the placement of the current pragma is appropriate
4711 -- for a configuration pragma.
4713 function Is_In_Context_Clause return Boolean;
4714 -- Returns True if pragma appears within the context clause of a unit,
4715 -- and False for any other placement (does not generate any messages).
4717 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4718 -- Analyzes the argument, and determines if it is a static string
4719 -- expression, returns True if so, False if non-static or not String.
4720 -- A special case is that a string literal returns True in Ada 83 mode
4721 -- (which has no such thing as static string expressions). Note that
4722 -- the call analyzes its argument, so this cannot be used for the case
4723 -- where an identifier might not be declared.
4725 procedure Pragma_Misplaced;
4726 pragma No_Return (Pragma_Misplaced);
4727 -- Issue fatal error message for misplaced pragma
4729 procedure Process_Atomic_Independent_Shared_Volatile;
4730 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4731 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4732 -- and treated as being identical in effect to pragma Atomic.
4734 procedure Process_Compile_Time_Warning_Or_Error;
4735 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4737 procedure Process_Convention
4738 (C : out Convention_Id;
4739 Ent : out Entity_Id);
4740 -- Common processing for Convention, Interface, Import and Export.
4741 -- Checks first two arguments of pragma, and sets the appropriate
4742 -- convention value in the specified entity or entities. On return
4743 -- C is the convention, Ent is the referenced entity.
4745 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4746 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4747 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4749 procedure Process_Extended_Import_Export_Object_Pragma
4750 (Arg_Internal : Node_Id;
4751 Arg_External : Node_Id;
4752 Arg_Size : Node_Id);
4753 -- Common processing for the pragmas Import/Export_Object. The three
4754 -- arguments correspond to the three named parameters of the pragmas. An
4755 -- argument is empty if the corresponding parameter is not present in
4758 procedure Process_Extended_Import_Export_Internal_Arg
4759 (Arg_Internal : Node_Id := Empty);
4760 -- Common processing for all extended Import and Export pragmas. The
4761 -- argument is the pragma parameter for the Internal argument. If
4762 -- Arg_Internal is empty or inappropriate, an error message is posted.
4763 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4764 -- set to identify the referenced entity.
4766 procedure Process_Extended_Import_Export_Subprogram_Pragma
4767 (Arg_Internal : Node_Id;
4768 Arg_External : Node_Id;
4769 Arg_Parameter_Types : Node_Id;
4770 Arg_Result_Type : Node_Id := Empty;
4771 Arg_Mechanism : Node_Id;
4772 Arg_Result_Mechanism : Node_Id := Empty);
4773 -- Common processing for all extended Import and Export pragmas applying
4774 -- to subprograms. The caller omits any arguments that do not apply to
4775 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4776 -- only in the Import_Function and Export_Function cases). The argument
4777 -- names correspond to the allowed pragma association identifiers.
4779 procedure Process_Generic_List;
4780 -- Common processing for Share_Generic and Inline_Generic
4782 procedure Process_Import_Or_Interface;
4783 -- Common processing for Import or Interface
4785 procedure Process_Import_Predefined_Type;
4786 -- Processing for completing a type with pragma Import. This is used
4787 -- to declare types that match predefined C types, especially for cases
4788 -- without corresponding Ada predefined type.
4790 type Inline_Status is (Suppressed, Disabled, Enabled);
4791 -- Inline status of a subprogram, indicated as follows:
4792 -- Suppressed: inlining is suppressed for the subprogram
4793 -- Disabled: no inlining is requested for the subprogram
4794 -- Enabled: inlining is requested/required for the subprogram
4796 procedure Process_Inline (Status : Inline_Status);
4797 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4798 -- indicates the inline status specified by the pragma.
4800 procedure Process_Interface_Name
4801 (Subprogram_Def : Entity_Id;
4805 -- Given the last two arguments of pragma Import, pragma Export, or
4806 -- pragma Interface_Name, performs validity checks and sets the
4807 -- Interface_Name field of the given subprogram entity to the
4808 -- appropriate external or link name, depending on the arguments given.
4809 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4810 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4811 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4812 -- nor Link_Arg is present, the interface name is set to the default
4813 -- from the subprogram name. In addition, the pragma itself is passed
4814 -- to analyze any expressions in the case the pragma came from an aspect
4817 procedure Process_Interrupt_Or_Attach_Handler;
4818 -- Common processing for Interrupt and Attach_Handler pragmas
4820 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4821 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4822 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4823 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4824 -- is not set in the Restrictions case.
4826 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4827 -- Common processing for Suppress and Unsuppress. The boolean parameter
4828 -- Suppress_Case is True for the Suppress case, and False for the
4831 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4832 -- Subsidiary to the analysis of pragmas Independent[_Components].
4833 -- Record such a pragma N applied to entity E for future checks.
4835 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4836 -- This procedure sets the Is_Exported flag for the given entity,
4837 -- checking that the entity was not previously imported. Arg is
4838 -- the argument that specified the entity. A check is also made
4839 -- for exporting inappropriate entities.
4841 procedure Set_Extended_Import_Export_External_Name
4842 (Internal_Ent : Entity_Id;
4843 Arg_External : Node_Id);
4844 -- Common processing for all extended import export pragmas. The first
4845 -- argument, Internal_Ent, is the internal entity, which has already
4846 -- been checked for validity by the caller. Arg_External is from the
4847 -- Import or Export pragma, and may be null if no External parameter
4848 -- was present. If Arg_External is present and is a non-null string
4849 -- (a null string is treated as the default), then the Interface_Name
4850 -- field of Internal_Ent is set appropriately.
4852 procedure Set_Imported (E : Entity_Id);
4853 -- This procedure sets the Is_Imported flag for the given entity,
4854 -- checking that it is not previously exported or imported.
4856 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4857 -- Mech is a parameter passing mechanism (see Import_Function syntax
4858 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4859 -- has the right form, and if not issues an error message. If the
4860 -- argument has the right form then the Mechanism field of Ent is
4861 -- set appropriately.
4863 procedure Set_Rational_Profile;
4864 -- Activate the set of configuration pragmas and permissions that make
4865 -- up the Rational profile.
4867 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4868 -- Activate the set of configuration pragmas and restrictions that make
4869 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4870 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4871 -- pragma node, which is used for error messages on any constructs
4872 -- violating the profile.
4874 ---------------------
4875 -- Ada_2005_Pragma --
4876 ---------------------
4878 procedure Ada_2005_Pragma is
4880 if Ada_Version <= Ada_95 then
4881 Check_Restriction (No_Implementation_Pragmas, N);
4883 end Ada_2005_Pragma;
4885 ---------------------
4886 -- Ada_2012_Pragma --
4887 ---------------------
4889 procedure Ada_2012_Pragma is
4891 if Ada_Version <= Ada_2005 then
4892 Check_Restriction (No_Implementation_Pragmas, N);
4894 end Ada_2012_Pragma;
4896 ----------------------------
4897 -- Analyze_Depends_Global --
4898 ----------------------------
4900 procedure Analyze_Depends_Global
4901 (Spec_Id : out Entity_Id;
4902 Subp_Decl : out Node_Id;
4903 Legal : out Boolean)
4906 -- Assume that the pragma is illegal
4913 Check_Arg_Count (1);
4915 -- Ensure the proper placement of the pragma. Depends/Global must be
4916 -- associated with a subprogram declaration or a body that acts as a
4919 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4923 if Nkind (Subp_Decl) = N_Entry_Declaration then
4926 -- Generic subprogram
4928 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4931 -- Object declaration of a single concurrent type
4933 elsif Nkind (Subp_Decl) = N_Object_Declaration
4934 and then Is_Single_Concurrent_Object
4935 (Unique_Defining_Entity (Subp_Decl))
4941 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4944 -- Abstract subprogram declaration
4946 elsif Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4949 -- Subprogram body acts as spec
4951 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4952 and then No (Corresponding_Spec (Subp_Decl))
4956 -- Subprogram body stub acts as spec
4958 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4959 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4963 -- Subprogram declaration
4965 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4967 -- Pragmas Global and Depends are forbidden on null procedures
4968 -- (SPARK RM 6.1.2(2)).
4970 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4971 and then Null_Present (Specification (Subp_Decl))
4973 Error_Msg_N (Fix_Error
4974 ("pragma % cannot apply to null procedure"), N);
4980 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4987 -- If we get here, then the pragma is legal
4990 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4992 -- When the related context is an entry, the entry must belong to a
4993 -- protected unit (SPARK RM 6.1.4(6)).
4995 if Is_Entry_Declaration (Spec_Id)
4996 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
5000 -- When the related context is an anonymous object created for a
5001 -- simple concurrent type, the type must be a task
5002 -- (SPARK RM 6.1.4(6)).
5004 elsif Is_Single_Concurrent_Object (Spec_Id)
5005 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
5010 -- A pragma that applies to a Ghost entity becomes Ghost for the
5011 -- purposes of legality checks and removal of ignored Ghost code.
5013 Mark_Ghost_Pragma (N, Spec_Id);
5014 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
5015 end Analyze_Depends_Global;
5017 ------------------------
5018 -- Analyze_If_Present --
5019 ------------------------
5021 procedure Analyze_If_Present (Id : Pragma_Id) is
5023 Analyze_If_Present_Internal (N, Id, Included => False);
5024 end Analyze_If_Present;
5026 --------------------------------
5027 -- Analyze_Pre_Post_Condition --
5028 --------------------------------
5030 procedure Analyze_Pre_Post_Condition is
5031 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
5032 Subp_Decl : Node_Id;
5033 Subp_Id : Entity_Id;
5035 Duplicates_OK : Boolean := False;
5036 -- Flag set when a pre/postcondition allows multiple pragmas of the
5039 In_Body_OK : Boolean := False;
5040 -- Flag set when a pre/postcondition is allowed to appear on a body
5041 -- even though the subprogram may have a spec.
5043 Is_Pre_Post : Boolean := False;
5044 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
5047 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
5048 -- Implement rules in AI12-0131: an overriding operation can have
5049 -- a class-wide precondition only if one of its ancestors has an
5050 -- explicit class-wide precondition.
5052 -----------------------------
5053 -- Inherits_Class_Wide_Pre --
5054 -----------------------------
5056 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
5057 Typ : constant Entity_Id := Find_Dispatching_Type (E);
5060 Prev : Entity_Id := Overridden_Operation (E);
5063 -- Check ancestors on the overriding operation to examine the
5064 -- preconditions that may apply to them.
5066 while Present (Prev) loop
5067 Cont := Contract (Prev);
5068 if Present (Cont) then
5069 Prag := Pre_Post_Conditions (Cont);
5070 while Present (Prag) loop
5071 if Pragma_Name (Prag) = Name_Precondition
5072 and then Class_Present (Prag)
5077 Prag := Next_Pragma (Prag);
5081 -- For a type derived from a generic formal type, the operation
5082 -- inheriting the condition is a renaming, not an overriding of
5083 -- the operation of the formal. Ditto for an inherited
5084 -- operation which has no explicit contracts.
5086 if Is_Generic_Type (Find_Dispatching_Type (Prev))
5087 or else not Comes_From_Source (Prev)
5089 Prev := Alias (Prev);
5091 Prev := Overridden_Operation (Prev);
5095 -- If the controlling type of the subprogram has progenitors, an
5096 -- interface operation implemented by the current operation may
5097 -- have a class-wide precondition.
5099 if Has_Interfaces (Typ) then
5104 Prim_Elmt : Elmt_Id;
5105 Prim_List : Elist_Id;
5108 Collect_Interfaces (Typ, Ints);
5109 Elmt := First_Elmt (Ints);
5111 -- Iterate over the primitive operations of each interface
5113 while Present (Elmt) loop
5114 Prim_List := Direct_Primitive_Operations (Node (Elmt));
5115 Prim_Elmt := First_Elmt (Prim_List);
5116 while Present (Prim_Elmt) loop
5117 Prim := Node (Prim_Elmt);
5118 if Chars (Prim) = Chars (E)
5119 and then Present (Contract (Prim))
5120 and then Class_Present
5121 (Pre_Post_Conditions (Contract (Prim)))
5126 Next_Elmt (Prim_Elmt);
5135 end Inherits_Class_Wide_Pre;
5137 -- Start of processing for Analyze_Pre_Post_Condition
5140 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
5141 -- offer uniformity among the various kinds of pre/postconditions by
5142 -- rewriting the pragma identifier. This allows the retrieval of the
5143 -- original pragma name by routine Original_Aspect_Pragma_Name.
5145 if Comes_From_Source (N) then
5146 if Pname in Name_Pre | Name_Pre_Class then
5147 Is_Pre_Post := True;
5148 Set_Class_Present (N, Pname = Name_Pre_Class);
5149 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
5151 elsif Pname in Name_Post | Name_Post_Class then
5152 Is_Pre_Post := True;
5153 Set_Class_Present (N, Pname = Name_Post_Class);
5154 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
5158 -- Determine the semantics with respect to duplicates and placement
5159 -- in a body. Pragmas Precondition and Postcondition were introduced
5160 -- before aspects and are not subject to the same aspect-like rules.
5162 if Pname in Name_Precondition | Name_Postcondition then
5163 Duplicates_OK := True;
5169 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
5170 -- argument without an identifier.
5173 Check_Arg_Count (1);
5174 Check_No_Identifiers;
5176 -- Pragmas Precondition and Postcondition have complex argument
5180 Check_At_Least_N_Arguments (1);
5181 Check_At_Most_N_Arguments (2);
5182 Check_Optional_Identifier (Arg1, Name_Check);
5184 if Present (Arg2) then
5185 Check_Optional_Identifier (Arg2, Name_Message);
5186 Preanalyze_Spec_Expression
5187 (Get_Pragma_Arg (Arg2), Standard_String);
5191 -- For a pragma PPC in the extended main source unit, record enabled
5193 -- ??? nothing checks that the pragma is in the main source unit
5195 if Is_Checked (N) and then not Split_PPC (N) then
5196 Set_SCO_Pragma_Enabled (Loc);
5199 -- Ensure the proper placement of the pragma
5202 Find_Related_Declaration_Or_Body
5203 (N, Do_Checks => not Duplicates_OK);
5205 -- When a pre/postcondition pragma applies to an abstract subprogram,
5206 -- its original form must be an aspect with 'Class.
5208 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
5209 if not From_Aspect_Specification (N) then
5211 ("pragma % cannot be applied to abstract subprogram");
5213 elsif not Class_Present (N) then
5215 ("aspect % requires ''Class for abstract subprogram");
5218 -- Entry declaration
5220 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
5223 -- Generic subprogram declaration
5225 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
5230 elsif Nkind (Subp_Decl) = N_Subprogram_Body
5231 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
5235 -- Subprogram body stub
5237 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
5238 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
5242 -- Subprogram declaration
5244 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
5246 -- AI05-0230: When a pre/postcondition pragma applies to a null
5247 -- procedure, its original form must be an aspect with 'Class.
5249 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
5250 and then Null_Present (Specification (Subp_Decl))
5251 and then From_Aspect_Specification (N)
5252 and then not Class_Present (N)
5254 Error_Pragma ("aspect % requires ''Class for null procedure");
5257 -- Implement the legality checks mandated by AI12-0131:
5258 -- Pre'Class shall not be specified for an overriding primitive
5259 -- subprogram of a tagged type T unless the Pre'Class aspect is
5260 -- specified for the corresponding primitive subprogram of some
5264 E : constant Entity_Id := Defining_Entity (Subp_Decl);
5267 if Class_Present (N)
5268 and then Pragma_Name (N) = Name_Precondition
5269 and then Present (Overridden_Operation (E))
5270 and then not Inherits_Class_Wide_Pre (E)
5273 ("illegal class-wide precondition on overriding operation",
5274 Corresponding_Aspect (N));
5278 -- A renaming declaration may inherit a generated pragma, its
5279 -- placement comes from expansion, not from source.
5281 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
5282 and then not Comes_From_Source (N)
5286 -- For Ada 2022, pre/postconditions can appear on formal subprograms
5288 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
5289 and then Ada_Version >= Ada_2022
5293 -- An access-to-subprogram type can have pre/postconditions, which
5294 -- are both analyzed when attached to the type and copied to the
5295 -- generated subprogram wrapper and analyzed there.
5297 elsif Nkind (Subp_Decl) = N_Full_Type_Declaration
5298 and then Nkind (Type_Definition (Subp_Decl)) in
5299 N_Access_To_Subprogram_Definition
5301 if Ada_Version < Ada_2022 then
5302 Error_Msg_Ada_2022_Feature
5303 ("pre/postcondition on access-to-subprogram", Loc);
5307 -- Otherwise the placement of the pragma is illegal
5313 Subp_Id := Defining_Entity (Subp_Decl);
5315 -- A pragma that applies to a Ghost entity becomes Ghost for the
5316 -- purposes of legality checks and removal of ignored Ghost code.
5318 Mark_Ghost_Pragma (N, Subp_Id);
5320 -- Chain the pragma on the contract for further processing by
5321 -- Analyze_Pre_Post_Condition_In_Decl_Part.
5323 if Ekind (Subp_Id) in Access_Subprogram_Kind then
5324 Add_Contract_Item (N, Directly_Designated_Type (Subp_Id));
5326 Add_Contract_Item (N, Subp_Id);
5329 -- Fully analyze the pragma when it appears inside an entry or
5330 -- subprogram body because it cannot benefit from forward references.
5332 if Nkind (Subp_Decl) in N_Entry_Body
5334 | N_Subprogram_Body_Stub
5336 -- The legality checks of pragmas Precondition and Postcondition
5337 -- are affected by the SPARK mode in effect and the volatility of
5338 -- the context. Analyze all pragmas in a specific order.
5340 Analyze_If_Present (Pragma_SPARK_Mode);
5341 Analyze_If_Present (Pragma_Volatile_Function);
5342 Analyze_Pre_Post_Condition_In_Decl_Part (N);
5344 end Analyze_Pre_Post_Condition;
5346 -----------------------------------------
5347 -- Analyze_Refined_Depends_Global_Post --
5348 -----------------------------------------
5350 procedure Analyze_Refined_Depends_Global_Post
5351 (Spec_Id : out Entity_Id;
5352 Body_Id : out Entity_Id;
5353 Legal : out Boolean)
5355 Body_Decl : Node_Id;
5356 Spec_Decl : Node_Id;
5359 -- Assume that the pragma is illegal
5366 Check_Arg_Count (1);
5367 Check_No_Identifiers;
5369 -- Verify the placement of the pragma and check for duplicates. The
5370 -- pragma must apply to a subprogram body [stub].
5372 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
5374 if Nkind (Body_Decl) not in
5375 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
5376 N_Task_Body | N_Task_Body_Stub
5381 Body_Id := Defining_Entity (Body_Decl);
5382 Spec_Id := Unique_Defining_Entity (Body_Decl);
5384 -- The pragma must apply to the second declaration of a subprogram.
5385 -- In other words, the body [stub] cannot acts as a spec.
5387 if No (Spec_Id) then
5388 Error_Pragma ("pragma % cannot apply to a stand alone body");
5390 -- Catch the case where the subprogram body is a subunit and acts as
5391 -- the third declaration of the subprogram.
5393 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
5394 Error_Pragma ("pragma % cannot apply to a subunit");
5397 -- A refined pragma can only apply to the body [stub] of a subprogram
5398 -- declared in the visible part of a package. Retrieve the context of
5399 -- the subprogram declaration.
5401 Spec_Decl := Unit_Declaration_Node (Spec_Id);
5403 -- When dealing with protected entries or protected subprograms, use
5404 -- the enclosing protected type as the proper context.
5406 if Ekind (Spec_Id) in E_Entry
5410 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
5412 Spec_Decl := Declaration_Node (Scope (Spec_Id));
5415 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
5417 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
5418 & "subprogram declared in a package specification"));
5421 -- If we get here, then the pragma is legal
5425 -- A pragma that applies to a Ghost entity becomes Ghost for the
5426 -- purposes of legality checks and removal of ignored Ghost code.
5428 Mark_Ghost_Pragma (N, Spec_Id);
5430 if Pname in Name_Refined_Depends | Name_Refined_Global then
5431 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
5433 end Analyze_Refined_Depends_Global_Post;
5435 ----------------------------------
5436 -- Analyze_Unmodified_Or_Unused --
5437 ----------------------------------
5439 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
5444 Ghost_Error_Posted : Boolean := False;
5445 -- Flag set when an error concerning the illegal mix of Ghost and
5446 -- non-Ghost variables is emitted.
5448 Ghost_Id : Entity_Id := Empty;
5449 -- The entity of the first Ghost variable encountered while
5450 -- processing the arguments of the pragma.
5454 Check_At_Least_N_Arguments (1);
5456 -- Loop through arguments
5459 while Present (Arg) loop
5460 Check_No_Identifier (Arg);
5462 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5463 -- in fact generate reference, so that the entity will have a
5464 -- reference, which will inhibit any warnings about it not
5465 -- being referenced, and also properly show up in the ali file
5466 -- as a reference. But this reference is recorded before the
5467 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5468 -- generated for this reference.
5470 Check_Arg_Is_Local_Name (Arg);
5471 Arg_Expr := Get_Pragma_Arg (Arg);
5473 if Is_Entity_Name (Arg_Expr) then
5474 Arg_Id := Entity (Arg_Expr);
5476 -- Skip processing the argument if already flagged
5478 if Is_Assignable (Arg_Id)
5479 and then not Has_Pragma_Unmodified (Arg_Id)
5480 and then not Has_Pragma_Unused (Arg_Id)
5482 Set_Has_Pragma_Unmodified (Arg_Id);
5485 Set_Has_Pragma_Unused (Arg_Id);
5488 -- A pragma that applies to a Ghost entity becomes Ghost for
5489 -- the purposes of legality checks and removal of ignored
5492 Mark_Ghost_Pragma (N, Arg_Id);
5494 -- Capture the entity of the first Ghost variable being
5495 -- processed for error detection purposes.
5497 if Is_Ghost_Entity (Arg_Id) then
5498 if No (Ghost_Id) then
5502 -- Otherwise the variable is non-Ghost. It is illegal to mix
5503 -- references to Ghost and non-Ghost entities
5506 elsif Present (Ghost_Id)
5507 and then not Ghost_Error_Posted
5509 Ghost_Error_Posted := True;
5511 Error_Msg_Name_1 := Pname;
5513 ("pragma % cannot mention ghost and non-ghost "
5516 Error_Msg_Sloc := Sloc (Ghost_Id);
5517 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5519 Error_Msg_Sloc := Sloc (Arg_Id);
5520 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5523 -- Warn if already flagged as Unused or Unmodified
5525 elsif Has_Pragma_Unmodified (Arg_Id) then
5526 if Has_Pragma_Unused (Arg_Id) then
5528 (Fix_Error ("??pragma Unused already given for &!"),
5532 (Fix_Error ("??pragma Unmodified already given for &!"),
5536 -- Otherwise the pragma referenced an illegal entity
5540 ("pragma% can only be applied to a variable", Arg_Expr);
5546 end Analyze_Unmodified_Or_Unused;
5548 ------------------------------------
5549 -- Analyze_Unreferenced_Or_Unused --
5550 ------------------------------------
5552 procedure Analyze_Unreferenced_Or_Unused
5553 (Is_Unused : Boolean := False)
5560 Ghost_Error_Posted : Boolean := False;
5561 -- Flag set when an error concerning the illegal mix of Ghost and
5562 -- non-Ghost names is emitted.
5564 Ghost_Id : Entity_Id := Empty;
5565 -- The entity of the first Ghost name encountered while processing
5566 -- the arguments of the pragma.
5570 Check_At_Least_N_Arguments (1);
5572 -- Check case of appearing within context clause
5574 if not Is_Unused and then Is_In_Context_Clause then
5576 -- The arguments must all be units mentioned in a with clause in
5577 -- the same context clause. Note that Par.Prag already checked
5578 -- that the arguments are either identifiers or selected
5582 while Present (Arg) loop
5583 Citem := First (List_Containing (N));
5584 while Citem /= N loop
5585 Arg_Expr := Get_Pragma_Arg (Arg);
5587 if Nkind (Citem) = N_With_Clause
5588 and then Same_Name (Name (Citem), Arg_Expr)
5590 Set_Has_Pragma_Unreferenced
5593 (Library_Unit (Citem))));
5594 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5603 ("argument of pragma% is not withed unit", Arg);
5609 -- Case of not in list of context items
5613 while Present (Arg) loop
5614 Check_No_Identifier (Arg);
5616 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5617 -- in fact generate reference, so that the entity will have a
5618 -- reference, which will inhibit any warnings about it not
5619 -- being referenced, and also properly show up in the ali file
5620 -- as a reference. But this reference is recorded before the
5621 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5622 -- generated for this reference.
5624 Check_Arg_Is_Local_Name (Arg);
5625 Arg_Expr := Get_Pragma_Arg (Arg);
5627 if Is_Entity_Name (Arg_Expr) then
5628 Arg_Id := Entity (Arg_Expr);
5630 -- Warn if already flagged as Unused or Unreferenced and
5631 -- skip processing the argument.
5633 if Has_Pragma_Unreferenced (Arg_Id) then
5634 if Has_Pragma_Unused (Arg_Id) then
5636 (Fix_Error ("??pragma Unused already given for &!"),
5641 ("??pragma Unreferenced already given for &!"),
5645 -- Apply Unreferenced to the entity
5648 -- If the entity is overloaded, the pragma applies to the
5649 -- most recent overloading, as documented. In this case,
5650 -- name resolution does not generate a reference, so it
5651 -- must be done here explicitly.
5653 if Is_Overloaded (Arg_Expr) then
5654 Generate_Reference (Arg_Id, N);
5657 Set_Has_Pragma_Unreferenced (Arg_Id);
5660 Set_Has_Pragma_Unused (Arg_Id);
5663 -- A pragma that applies to a Ghost entity becomes Ghost
5664 -- for the purposes of legality checks and removal of
5665 -- ignored Ghost code.
5667 Mark_Ghost_Pragma (N, Arg_Id);
5669 -- Capture the entity of the first Ghost name being
5670 -- processed for error detection purposes.
5672 if Is_Ghost_Entity (Arg_Id) then
5673 if No (Ghost_Id) then
5677 -- Otherwise the name is non-Ghost. It is illegal to mix
5678 -- references to Ghost and non-Ghost entities
5681 elsif Present (Ghost_Id)
5682 and then not Ghost_Error_Posted
5684 Ghost_Error_Posted := True;
5686 Error_Msg_Name_1 := Pname;
5688 ("pragma % cannot mention ghost and non-ghost "
5691 Error_Msg_Sloc := Sloc (Ghost_Id);
5693 ("\& # declared as ghost", N, Ghost_Id);
5695 Error_Msg_Sloc := Sloc (Arg_Id);
5697 ("\& # declared as non-ghost", N, Arg_Id);
5705 end Analyze_Unreferenced_Or_Unused;
5707 --------------------------
5708 -- Check_Ada_83_Warning --
5709 --------------------------
5711 procedure Check_Ada_83_Warning is
5713 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5714 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5716 end Check_Ada_83_Warning;
5718 ---------------------
5719 -- Check_Arg_Count --
5720 ---------------------
5722 procedure Check_Arg_Count (Required : Nat) is
5724 if Arg_Count /= Required then
5725 Error_Pragma ("wrong number of arguments for pragma%");
5727 end Check_Arg_Count;
5729 --------------------------------
5730 -- Check_Arg_Is_External_Name --
5731 --------------------------------
5733 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5734 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5737 if Nkind (Argx) = N_Identifier then
5741 Analyze_And_Resolve (Argx, Standard_String);
5743 if Is_OK_Static_Expression (Argx) then
5746 elsif Etype (Argx) = Any_Type then
5749 -- An interesting special case, if we have a string literal and
5750 -- we are in Ada 83 mode, then we allow it even though it will
5751 -- not be flagged as static. This allows expected Ada 83 mode
5752 -- use of external names which are string literals, even though
5753 -- technically these are not static in Ada 83.
5755 elsif Ada_Version = Ada_83
5756 and then Nkind (Argx) = N_String_Literal
5760 -- Here we have a real error (non-static expression)
5763 Error_Msg_Name_1 := Pname;
5764 Flag_Non_Static_Expr
5765 (Fix_Error ("argument for pragma% must be a identifier or "
5766 & "static string expression!"), Argx);
5771 end Check_Arg_Is_External_Name;
5773 -----------------------------
5774 -- Check_Arg_Is_Identifier --
5775 -----------------------------
5777 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5778 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5780 if Nkind (Argx) /= N_Identifier then
5781 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5783 end Check_Arg_Is_Identifier;
5785 ----------------------------------
5786 -- Check_Arg_Is_Integer_Literal --
5787 ----------------------------------
5789 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5790 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5792 if Nkind (Argx) /= N_Integer_Literal then
5794 ("argument for pragma% must be integer literal", Argx);
5796 end Check_Arg_Is_Integer_Literal;
5798 -------------------------------------------
5799 -- Check_Arg_Is_Library_Level_Local_Name --
5800 -------------------------------------------
5804 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5805 -- | library_unit_NAME
5807 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5809 Check_Arg_Is_Local_Name (Arg);
5811 -- If it came from an aspect, we want to give the error just as if it
5812 -- came from source.
5814 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5815 and then (Comes_From_Source (N)
5816 or else Present (Corresponding_Aspect (Parent (Arg))))
5819 ("argument for pragma% must be library level entity", Arg);
5821 end Check_Arg_Is_Library_Level_Local_Name;
5823 -----------------------------
5824 -- Check_Arg_Is_Local_Name --
5825 -----------------------------
5829 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5830 -- | library_unit_NAME
5832 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5833 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5836 -- If this pragma came from an aspect specification, we don't want to
5837 -- check for this error, because that would cause spurious errors, in
5838 -- case a type is frozen in a scope more nested than the type. The
5839 -- aspect itself of course can't be anywhere but on the declaration
5842 if Nkind (Arg) = N_Pragma_Argument_Association then
5843 if From_Aspect_Specification (Parent (Arg)) then
5847 -- Arg is the Expression of an N_Pragma_Argument_Association
5850 if From_Aspect_Specification (Parent (Parent (Arg))) then
5857 if Nkind (Argx) not in N_Direct_Name
5858 and then (Nkind (Argx) /= N_Attribute_Reference
5859 or else Present (Expressions (Argx))
5860 or else Nkind (Prefix (Argx)) /= N_Identifier)
5861 and then (not Is_Entity_Name (Argx)
5862 or else not Is_Compilation_Unit (Entity (Argx)))
5864 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5867 -- No further check required if not an entity name
5869 if not Is_Entity_Name (Argx) then
5875 Ent : constant Entity_Id := Entity (Argx);
5876 Scop : constant Entity_Id := Scope (Ent);
5879 -- Case of a pragma applied to a compilation unit: pragma must
5880 -- occur immediately after the program unit in the compilation.
5882 if Is_Compilation_Unit (Ent) then
5884 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5887 -- Case of pragma placed immediately after spec
5889 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5892 -- Case of pragma placed immediately after body
5894 elsif Nkind (Decl) = N_Subprogram_Declaration
5895 and then Present (Corresponding_Body (Decl))
5899 (Parent (Unit_Declaration_Node
5900 (Corresponding_Body (Decl))));
5902 -- All other cases are illegal
5909 -- Special restricted placement rule from 10.2.1(11.8/2)
5911 elsif Is_Generic_Formal (Ent)
5912 and then Prag_Id = Pragma_Preelaborable_Initialization
5914 OK := List_Containing (N) =
5915 Generic_Formal_Declarations
5916 (Unit_Declaration_Node (Scop));
5918 -- If this is an aspect applied to a subprogram body, the
5919 -- pragma is inserted in its declarative part.
5921 elsif From_Aspect_Specification (N)
5922 and then Ent = Current_Scope
5924 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5928 -- If the aspect is a predicate (possibly others ???) and the
5929 -- context is a record type, this is a discriminant expression
5930 -- within a type declaration, that freezes the predicated
5933 elsif From_Aspect_Specification (N)
5934 and then Prag_Id = Pragma_Predicate
5935 and then Ekind (Current_Scope) = E_Record_Type
5936 and then Scop = Scope (Current_Scope)
5940 -- Special case for postconditions wrappers
5942 elsif Ekind (Scop) in Subprogram_Kind
5943 and then Present (Wrapped_Statements (Scop))
5944 and then Wrapped_Statements (Scop) = Current_Scope
5948 -- Default case, just check that the pragma occurs in the scope
5949 -- of the entity denoted by the name.
5952 OK := Current_Scope = Scop;
5957 ("pragma% argument must be in same declarative part", Arg);
5961 end Check_Arg_Is_Local_Name;
5963 ---------------------------------
5964 -- Check_Arg_Is_Locking_Policy --
5965 ---------------------------------
5967 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5968 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5971 Check_Arg_Is_Identifier (Argx);
5973 if not Is_Locking_Policy_Name (Chars (Argx)) then
5974 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5976 end Check_Arg_Is_Locking_Policy;
5978 -----------------------------------------------
5979 -- Check_Arg_Is_Partition_Elaboration_Policy --
5980 -----------------------------------------------
5982 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5983 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5986 Check_Arg_Is_Identifier (Argx);
5988 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5990 ("& is not a valid partition elaboration policy name", Argx);
5992 end Check_Arg_Is_Partition_Elaboration_Policy;
5994 -------------------------
5995 -- Check_Arg_Is_One_Of --
5996 -------------------------
5998 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5999 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6002 Check_Arg_Is_Identifier (Argx);
6004 if Chars (Argx) not in N1 | N2 then
6005 Error_Msg_Name_2 := N1;
6006 Error_Msg_Name_3 := N2;
6007 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
6009 end Check_Arg_Is_One_Of;
6011 procedure Check_Arg_Is_One_Of
6013 N1, N2, N3 : Name_Id)
6015 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6018 Check_Arg_Is_Identifier (Argx);
6020 if Chars (Argx) not in N1 | N2 | N3 then
6021 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
6023 end Check_Arg_Is_One_Of;
6025 procedure Check_Arg_Is_One_Of
6027 N1, N2, N3, N4 : Name_Id)
6029 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6032 Check_Arg_Is_Identifier (Argx);
6034 if Chars (Argx) not in N1 | N2 | N3 | N4 then
6035 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
6037 end Check_Arg_Is_One_Of;
6039 procedure Check_Arg_Is_One_Of
6041 N1, N2, N3, N4, N5 : Name_Id)
6043 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6046 Check_Arg_Is_Identifier (Argx);
6048 if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
6049 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
6051 end Check_Arg_Is_One_Of;
6053 ---------------------------------
6054 -- Check_Arg_Is_Queuing_Policy --
6055 ---------------------------------
6057 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
6058 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6061 Check_Arg_Is_Identifier (Argx);
6063 if not Is_Queuing_Policy_Name (Chars (Argx)) then
6064 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
6066 end Check_Arg_Is_Queuing_Policy;
6068 ---------------------------------------
6069 -- Check_Arg_Is_OK_Static_Expression --
6070 ---------------------------------------
6072 procedure Check_Arg_Is_OK_Static_Expression
6074 Typ : Entity_Id := Empty)
6077 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
6078 end Check_Arg_Is_OK_Static_Expression;
6080 ------------------------------------------
6081 -- Check_Arg_Is_Task_Dispatching_Policy --
6082 ------------------------------------------
6084 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
6085 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6088 Check_Arg_Is_Identifier (Argx);
6090 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
6092 ("& is not an allowed task dispatching policy name", Argx);
6094 end Check_Arg_Is_Task_Dispatching_Policy;
6096 ---------------------
6097 -- Check_Arg_Order --
6098 ---------------------
6100 procedure Check_Arg_Order (Names : Name_List) is
6103 Highest_So_Far : Natural := 0;
6104 -- Highest index in Names seen do far
6108 for J in 1 .. Arg_Count loop
6109 if Chars (Arg) /= No_Name then
6110 for K in Names'Range loop
6111 if Chars (Arg) = Names (K) then
6112 if K < Highest_So_Far then
6113 Error_Msg_Name_1 := Pname;
6115 ("parameters out of order for pragma%", Arg);
6116 Error_Msg_Name_1 := Names (K);
6117 Error_Msg_Name_2 := Names (Highest_So_Far);
6118 Error_Msg_N ("\% must appear before %", Arg);
6122 Highest_So_Far := K;
6130 end Check_Arg_Order;
6132 --------------------------------
6133 -- Check_At_Least_N_Arguments --
6134 --------------------------------
6136 procedure Check_At_Least_N_Arguments (N : Nat) is
6138 if Arg_Count < N then
6139 Error_Pragma ("too few arguments for pragma%");
6141 end Check_At_Least_N_Arguments;
6143 -------------------------------
6144 -- Check_At_Most_N_Arguments --
6145 -------------------------------
6147 procedure Check_At_Most_N_Arguments (N : Nat) is
6150 if Arg_Count > N then
6152 for J in 1 .. N loop
6154 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
6157 end Check_At_Most_N_Arguments;
6159 ---------------------
6160 -- Check_Component --
6161 ---------------------
6163 procedure Check_Component
6166 In_Variant_Part : Boolean := False)
6168 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
6169 Sindic : constant Node_Id :=
6170 Subtype_Indication (Component_Definition (Comp));
6171 Typ : constant Entity_Id := Etype (Comp_Id);
6174 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
6175 -- object constraint, then the component type shall be an Unchecked_
6178 if Nkind (Sindic) = N_Subtype_Indication
6179 and then Has_Per_Object_Constraint (Comp_Id)
6180 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
6183 ("component subtype subject to per-object constraint "
6184 & "must be an Unchecked_Union", Comp);
6186 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
6187 -- the body of a generic unit, or within the body of any of its
6188 -- descendant library units, no part of the type of a component
6189 -- declared in a variant_part of the unchecked union type shall be of
6190 -- a formal private type or formal private extension declared within
6191 -- the formal part of the generic unit.
6193 elsif Ada_Version >= Ada_2012
6194 and then In_Generic_Body (UU_Typ)
6195 and then In_Variant_Part
6196 and then Is_Private_Type (Typ)
6197 and then Is_Generic_Type (Typ)
6200 ("component of unchecked union cannot be of generic type", Comp);
6202 elsif Needs_Finalization (Typ) then
6204 ("component of unchecked union cannot be controlled", Comp);
6206 elsif Has_Task (Typ) then
6208 ("component of unchecked union cannot have tasks", Comp);
6210 end Check_Component;
6212 ----------------------------
6213 -- Check_Duplicate_Pragma --
6214 ----------------------------
6216 procedure Check_Duplicate_Pragma (E : Entity_Id) is
6217 Id : Entity_Id := E;
6221 -- Nothing to do if this pragma comes from an aspect specification,
6222 -- since we could not be duplicating a pragma, and we dealt with the
6223 -- case of duplicated aspects in Analyze_Aspect_Specifications.
6225 if From_Aspect_Specification (N) then
6229 -- Otherwise current pragma may duplicate previous pragma or a
6230 -- previously given aspect specification or attribute definition
6231 -- clause for the same pragma.
6233 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
6237 -- If the entity is a type, then we have to make sure that the
6238 -- ostensible duplicate is not for a parent type from which this
6242 if Nkind (P) = N_Pragma then
6244 Args : constant List_Id :=
6245 Pragma_Argument_Associations (P);
6248 and then Is_Entity_Name (Expression (First (Args)))
6249 and then Is_Type (Entity (Expression (First (Args))))
6250 and then Entity (Expression (First (Args))) /= E
6256 elsif Nkind (P) = N_Aspect_Specification
6257 and then Is_Type (Entity (P))
6258 and then Entity (P) /= E
6264 -- Here we have a definite duplicate
6266 Error_Msg_Name_1 := Pragma_Name (N);
6267 Error_Msg_Sloc := Sloc (P);
6269 -- For a single protected or a single task object, the error is
6270 -- issued on the original entity.
6272 if Ekind (Id) in E_Task_Type | E_Protected_Type then
6273 Id := Defining_Identifier (Original_Node (Parent (Id)));
6276 if Nkind (P) = N_Aspect_Specification
6277 or else From_Aspect_Specification (P)
6279 Error_Msg_NE ("aspect% for & previously given#", N, Id);
6281 -- If -gnatwr is set, warn in case of a duplicate pragma
6282 -- [No_]Inline which is suspicious but not an error, generate
6283 -- an error for other pragmas.
6285 if Pragma_Name (N) in Name_Inline | Name_No_Inline then
6286 if Warn_On_Redundant_Constructs then
6288 ("?r?pragma% for & duplicates pragma#", N, Id);
6291 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
6297 end Check_Duplicate_Pragma;
6299 ----------------------------------
6300 -- Check_Duplicated_Export_Name --
6301 ----------------------------------
6303 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
6304 String_Val : constant String_Id := Strval (Nam);
6307 -- We are only interested in the export case, and in the case of
6308 -- generics, it is the instance, not the template, that is the
6309 -- problem (the template will generate a warning in any case).
6311 if not Inside_A_Generic
6312 and then (Prag_Id = Pragma_Export
6314 Prag_Id = Pragma_Export_Procedure
6316 Prag_Id = Pragma_Export_Valued_Procedure
6318 Prag_Id = Pragma_Export_Function)
6320 for J in Externals.First .. Externals.Last loop
6321 if String_Equal (String_Val, Strval (Externals.Table (J))) then
6322 Error_Msg_Sloc := Sloc (Externals.Table (J));
6323 Error_Msg_N ("external name duplicates name given#", Nam);
6328 Externals.Append (Nam);
6330 end Check_Duplicated_Export_Name;
6332 ----------------------------------------
6333 -- Check_Expr_Is_OK_Static_Expression --
6334 ----------------------------------------
6336 procedure Check_Expr_Is_OK_Static_Expression
6338 Typ : Entity_Id := Empty)
6341 if Present (Typ) then
6342 Analyze_And_Resolve (Expr, Typ);
6344 Analyze_And_Resolve (Expr);
6347 -- An expression cannot be considered static if its resolution failed
6348 -- or if it's erroneous. Stop the analysis of the related pragma.
6350 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
6353 elsif Is_OK_Static_Expression (Expr) then
6356 -- An interesting special case, if we have a string literal and we
6357 -- are in Ada 83 mode, then we allow it even though it will not be
6358 -- flagged as static. This allows the use of Ada 95 pragmas like
6359 -- Import in Ada 83 mode. They will of course be flagged with
6360 -- warnings as usual, but will not cause errors.
6362 elsif Ada_Version = Ada_83
6363 and then Nkind (Expr) = N_String_Literal
6367 -- Finally, we have a real error
6370 Error_Msg_Name_1 := Pname;
6371 Flag_Non_Static_Expr
6372 (Fix_Error ("argument for pragma% must be a static expression!"),
6376 end Check_Expr_Is_OK_Static_Expression;
6378 -------------------------
6379 -- Check_First_Subtype --
6380 -------------------------
6382 procedure Check_First_Subtype (Arg : Node_Id) is
6383 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6384 Ent : constant Entity_Id := Entity (Argx);
6387 if Is_First_Subtype (Ent) then
6390 elsif Is_Type (Ent) then
6392 ("pragma% cannot apply to subtype", Argx);
6394 elsif Is_Object (Ent) then
6396 ("pragma% cannot apply to object, requires a type", Argx);
6400 ("pragma% cannot apply to&, requires a type", Argx);
6402 end Check_First_Subtype;
6404 ----------------------
6405 -- Check_Identifier --
6406 ----------------------
6408 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
6411 and then Nkind (Arg) = N_Pragma_Argument_Association
6413 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
6414 Error_Msg_Name_1 := Pname;
6415 Error_Msg_Name_2 := Id;
6416 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6420 end Check_Identifier;
6422 --------------------------------
6423 -- Check_Identifier_Is_One_Of --
6424 --------------------------------
6426 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
6429 and then Nkind (Arg) = N_Pragma_Argument_Association
6431 if Chars (Arg) = No_Name then
6432 Error_Msg_Name_1 := Pname;
6433 Error_Msg_N ("pragma% argument expects an identifier", Arg);
6436 elsif Chars (Arg) /= N1
6437 and then Chars (Arg) /= N2
6439 Error_Msg_Name_1 := Pname;
6440 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
6444 end Check_Identifier_Is_One_Of;
6446 ---------------------------
6447 -- Check_In_Main_Program --
6448 ---------------------------
6450 procedure Check_In_Main_Program is
6451 P : constant Node_Id := Parent (N);
6454 -- Must be in subprogram body
6456 if Nkind (P) /= N_Subprogram_Body then
6457 Error_Pragma ("% pragma allowed only in subprogram");
6459 -- Otherwise warn if obviously not main program
6461 elsif Present (Parameter_Specifications (Specification (P)))
6462 or else not Is_Compilation_Unit (Defining_Entity (P))
6464 Error_Msg_Name_1 := Pname;
6466 ("??pragma% is only effective in main program", N);
6468 end Check_In_Main_Program;
6470 ---------------------------------------
6471 -- Check_Interrupt_Or_Attach_Handler --
6472 ---------------------------------------
6474 procedure Check_Interrupt_Or_Attach_Handler is
6475 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
6476 Handler_Proc, Proc_Scope : Entity_Id;
6481 if Prag_Id = Pragma_Interrupt_Handler then
6482 Check_Restriction (No_Dynamic_Attachment, N);
6485 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6486 Proc_Scope := Scope (Handler_Proc);
6488 if Ekind (Proc_Scope) /= E_Protected_Type then
6490 ("argument of pragma% must be protected procedure", Arg1);
6493 -- For pragma case (as opposed to access case), check placement.
6494 -- We don't need to do that for aspects, because we have the
6495 -- check that they aspect applies an appropriate procedure.
6497 if not From_Aspect_Specification (N)
6498 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6500 Error_Pragma ("pragma% must be in protected definition");
6503 if not Is_Library_Level_Entity (Proc_Scope) then
6505 ("argument for pragma% must be library level entity", Arg1);
6508 -- AI05-0033: A pragma cannot appear within a generic body, because
6509 -- instance can be in a nested scope. The check that protected type
6510 -- is itself a library-level declaration is done elsewhere.
6512 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6513 -- handle code prior to AI-0033. Analysis tools typically are not
6514 -- interested in this pragma in any case, so no need to worry too
6515 -- much about its placement.
6517 if Inside_A_Generic then
6518 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6519 and then In_Package_Body (Scope (Current_Scope))
6520 and then not Relaxed_RM_Semantics
6522 Error_Pragma ("pragma% cannot be used inside a generic");
6525 end Check_Interrupt_Or_Attach_Handler;
6527 ---------------------------------
6528 -- Check_Loop_Pragma_Placement --
6529 ---------------------------------
6531 procedure Check_Loop_Pragma_Placement is
6532 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6533 -- Verify whether the current pragma is properly grouped with other
6534 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6535 -- related loop where the pragma appears.
6537 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6538 -- Determine whether an arbitrary statement Stmt denotes pragma
6539 -- Loop_Invariant or Loop_Variant.
6541 procedure Placement_Error (Constr : Node_Id);
6542 pragma No_Return (Placement_Error);
6543 -- Node Constr denotes the last loop restricted construct before we
6544 -- encountered an illegal relation between enclosing constructs. Emit
6545 -- an error depending on what Constr was.
6547 --------------------------------
6548 -- Check_Loop_Pragma_Grouping --
6549 --------------------------------
6551 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6552 function Check_Grouping (L : List_Id) return Boolean;
6553 -- Find the first group of pragmas in list L and if successful,
6554 -- ensure that the current pragma is part of that group. The
6555 -- routine returns True once such a check is performed to
6556 -- stop the analysis.
6558 procedure Grouping_Error (Prag : Node_Id);
6559 pragma No_Return (Grouping_Error);
6560 -- Emit an error concerning the current pragma indicating that it
6561 -- should be placed after pragma Prag.
6563 --------------------
6564 -- Check_Grouping --
6565 --------------------
6567 function Check_Grouping (L : List_Id) return Boolean is
6570 Prag : Node_Id := Empty; -- init to avoid warning
6573 -- Inspect the list of declarations or statements looking for
6574 -- the first grouping of pragmas:
6577 -- pragma Loop_Invariant ...;
6578 -- pragma Loop_Variant ...;
6580 -- pragma Loop_Variant ...; -- current pragma
6582 -- If the current pragma is not in the grouping, then it must
6583 -- either appear in a different declarative or statement list
6584 -- or the construct at (1) is separating the pragma from the
6588 while Present (Stmt) loop
6590 -- First pragma of the first topmost grouping has been found
6592 if Is_Loop_Pragma (Stmt) then
6594 -- The group and the current pragma are not in the same
6595 -- declarative or statement list.
6597 if not In_Same_List (Stmt, N) then
6598 Grouping_Error (Stmt);
6600 -- Try to reach the current pragma from the first pragma
6601 -- of the grouping while skipping other members:
6603 -- pragma Loop_Invariant ...; -- first pragma
6604 -- pragma Loop_Variant ...; -- member
6606 -- pragma Loop_Variant ...; -- current pragma
6609 while Present (Stmt) loop
6610 -- The current pragma is either the first pragma
6611 -- of the group or is a member of the group.
6612 -- Stop the search as the placement is legal.
6617 -- Skip group members, but keep track of the
6618 -- last pragma in the group.
6620 elsif Is_Loop_Pragma (Stmt) then
6623 -- Skip Annotate pragmas, typically used to justify
6624 -- unproved loop pragmas in GNATprove.
6626 elsif Nkind (Stmt) = N_Pragma
6627 and then Pragma_Name (Stmt) = Name_Annotate
6631 -- Skip declarations and statements generated by
6632 -- the compiler during expansion. Note that some
6633 -- source statements (e.g. pragma Assert) may have
6634 -- been transformed so that they do not appear as
6635 -- coming from source anymore, so we instead look
6636 -- at their Original_Node.
6638 elsif not Comes_From_Source (Original_Node (Stmt))
6642 -- A non-pragma is separating the group from the
6643 -- current pragma, the placement is illegal.
6646 Grouping_Error (Prag);
6652 -- If the traversal did not reach the current pragma,
6653 -- then the list must be malformed.
6655 raise Program_Error;
6658 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6659 -- inside a loop or a block housed inside a loop. Inspect
6660 -- the declarations and statements of the block as they may
6661 -- contain the first grouping. This case follows the one for
6662 -- loop pragmas, as block statements which originate in a
6663 -- loop pragma (and so Is_Loop_Pragma will return True on
6664 -- that block statement) should be treated in the previous
6667 elsif Nkind (Stmt) = N_Block_Statement then
6668 HSS := Handled_Statement_Sequence (Stmt);
6670 if Check_Grouping (Declarations (Stmt)) then
6674 if Present (HSS) then
6675 if Check_Grouping (Statements (HSS)) then
6687 --------------------
6688 -- Grouping_Error --
6689 --------------------
6691 procedure Grouping_Error (Prag : Node_Id) is
6693 Error_Msg_Sloc := Sloc (Prag);
6694 Error_Pragma ("pragma% must appear next to pragma#");
6699 -- Start of processing for Check_Loop_Pragma_Grouping
6702 -- Inspect the statements of the loop or nested blocks housed
6703 -- within to determine whether the current pragma is part of the
6704 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6706 Ignore := Check_Grouping (Statements (Loop_Stmt));
6707 end Check_Loop_Pragma_Grouping;
6709 --------------------
6710 -- Is_Loop_Pragma --
6711 --------------------
6713 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6714 Original_Stmt : constant Node_Id := Original_Node (Stmt);
6717 -- Inspect the original node as Loop_Invariant and Loop_Variant
6718 -- pragmas are rewritten to null when assertions are disabled.
6720 return Nkind (Original_Stmt) = N_Pragma
6721 and then Pragma_Name_Unmapped (Original_Stmt)
6722 in Name_Loop_Invariant | Name_Loop_Variant;
6725 ---------------------
6726 -- Placement_Error --
6727 ---------------------
6729 procedure Placement_Error (Constr : Node_Id) is
6730 LA : constant String := " with Loop_Entry";
6733 if Prag_Id = Pragma_Assert then
6734 Error_Msg_String (1 .. LA'Length) := LA;
6735 Error_Msg_Strlen := LA'Length;
6737 Error_Msg_Strlen := 0;
6740 if Nkind (Constr) = N_Pragma then
6742 ("pragma %~ must appear immediately within the statements "
6746 ("block containing pragma %~ must appear immediately within "
6747 & "the statements of a loop", Constr);
6749 end Placement_Error;
6751 -- Local declarations
6756 -- Start of processing for Check_Loop_Pragma_Placement
6759 -- Check that pragma appears immediately within a loop statement,
6760 -- ignoring intervening block statements.
6764 while Present (Stmt) loop
6766 -- The pragma or previous block must appear immediately within the
6767 -- current block's declarative or statement part.
6769 if Nkind (Stmt) = N_Block_Statement then
6770 if (No (Declarations (Stmt))
6771 or else List_Containing (Prev) /= Declarations (Stmt))
6773 List_Containing (Prev) /=
6774 Statements (Handled_Statement_Sequence (Stmt))
6776 Placement_Error (Prev);
6778 -- Keep inspecting the parents because we are now within a
6779 -- chain of nested blocks.
6783 Stmt := Parent (Stmt);
6786 -- The pragma or previous block must appear immediately within the
6787 -- statements of the loop.
6789 elsif Nkind (Stmt) = N_Loop_Statement then
6790 if List_Containing (Prev) /= Statements (Stmt) then
6791 Placement_Error (Prev);
6794 -- Stop the traversal because we reached the innermost loop
6795 -- regardless of whether we encountered an error or not.
6799 -- Ignore a handled statement sequence. Note that this node may
6800 -- be related to a subprogram body in which case we will emit an
6801 -- error on the next iteration of the search.
6803 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6804 Stmt := Parent (Stmt);
6806 -- Any other statement breaks the chain from the pragma to the
6810 Placement_Error (Prev);
6814 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6815 -- grouped together with other such pragmas.
6817 if Is_Loop_Pragma (N) then
6819 -- The previous check should have located the related loop
6821 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6822 Check_Loop_Pragma_Grouping (Stmt);
6824 end Check_Loop_Pragma_Placement;
6826 -------------------------------------------
6827 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6828 -------------------------------------------
6830 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6839 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6842 elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
6845 -- Note: the following tests seem a little peculiar, because
6846 -- they test for bodies, but if we were in the statement part
6847 -- of the body, we would already have hit the handled statement
6848 -- sequence, so the only way we get here is by being in the
6849 -- declarative part of the body.
6852 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6860 Error_Pragma ("pragma% is not in declarative part or package spec");
6861 end Check_Is_In_Decl_Part_Or_Package_Spec;
6863 -------------------------
6864 -- Check_No_Identifier --
6865 -------------------------
6867 procedure Check_No_Identifier (Arg : Node_Id) is
6869 if Nkind (Arg) = N_Pragma_Argument_Association
6870 and then Chars (Arg) /= No_Name
6872 Error_Pragma_Arg_Ident
6873 ("pragma% does not permit identifier& here", Arg);
6875 end Check_No_Identifier;
6877 --------------------------
6878 -- Check_No_Identifiers --
6879 --------------------------
6881 procedure Check_No_Identifiers is
6885 for J in 1 .. Arg_Count loop
6886 Check_No_Identifier (Arg_Node);
6889 end Check_No_Identifiers;
6891 ------------------------
6892 -- Check_No_Link_Name --
6893 ------------------------
6895 procedure Check_No_Link_Name is
6897 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6901 if Present (Arg4) then
6903 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6905 end Check_No_Link_Name;
6907 -------------------------------
6908 -- Check_Optional_Identifier --
6909 -------------------------------
6911 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6914 and then Nkind (Arg) = N_Pragma_Argument_Association
6915 and then Chars (Arg) /= No_Name
6917 if Chars (Arg) /= Id then
6918 Error_Msg_Name_1 := Pname;
6919 Error_Msg_Name_2 := Id;
6920 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6924 end Check_Optional_Identifier;
6926 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6928 Check_Optional_Identifier (Arg, Name_Find (Id));
6929 end Check_Optional_Identifier;
6931 -------------------------------------
6932 -- Check_Static_Boolean_Expression --
6933 -------------------------------------
6935 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6937 if Present (Expr) then
6938 Analyze_And_Resolve (Expr, Standard_Boolean);
6940 if not Is_OK_Static_Expression (Expr) then
6942 ("expression of pragma % must be static", Expr);
6945 end Check_Static_Boolean_Expression;
6947 -----------------------------
6948 -- Check_Static_Constraint --
6949 -----------------------------
6951 procedure Check_Static_Constraint (Constr : Node_Id) is
6953 procedure Require_Static (E : Node_Id);
6954 -- Require given expression to be static expression
6956 --------------------
6957 -- Require_Static --
6958 --------------------
6960 procedure Require_Static (E : Node_Id) is
6962 if not Is_OK_Static_Expression (E) then
6963 Flag_Non_Static_Expr
6964 ("non-static constraint not allowed in Unchecked_Union!", E);
6969 -- Start of processing for Check_Static_Constraint
6972 case Nkind (Constr) is
6973 when N_Discriminant_Association =>
6974 Require_Static (Expression (Constr));
6977 Require_Static (Low_Bound (Constr));
6978 Require_Static (High_Bound (Constr));
6980 when N_Attribute_Reference =>
6981 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6982 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6984 when N_Range_Constraint =>
6985 Check_Static_Constraint (Range_Expression (Constr));
6987 when N_Index_Or_Discriminant_Constraint =>
6991 IDC := First (Constraints (Constr));
6992 while Present (IDC) loop
6993 Check_Static_Constraint (IDC);
7001 end Check_Static_Constraint;
7003 --------------------------------------
7004 -- Check_Valid_Configuration_Pragma --
7005 --------------------------------------
7007 -- A configuration pragma must appear in the context clause of a
7008 -- compilation unit, and only other pragmas may precede it. Note that
7009 -- the test also allows use in a configuration pragma file.
7011 procedure Check_Valid_Configuration_Pragma is
7013 if not Is_Configuration_Pragma then
7014 Error_Pragma ("incorrect placement for configuration pragma%");
7016 end Check_Valid_Configuration_Pragma;
7018 -------------------------------------
7019 -- Check_Valid_Library_Unit_Pragma --
7020 -------------------------------------
7022 procedure Check_Valid_Library_Unit_Pragma is
7024 Parent_Node : Node_Id;
7025 Unit_Name : Entity_Id;
7026 Unit_Kind : Node_Kind;
7027 Unit_Node : Node_Id;
7028 Sindex : Source_File_Index;
7031 if not Is_List_Member (N) then
7035 Plist := List_Containing (N);
7036 Parent_Node := Parent (Plist);
7038 if Parent_Node = Empty then
7041 -- Case of pragma appearing after a compilation unit. In this case
7042 -- it must have an argument with the corresponding name and must
7043 -- be part of the following pragmas of its parent.
7045 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
7046 if Plist /= Pragmas_After (Parent_Node) then
7048 ("pragma% misplaced, must be inside or after the "
7049 & "compilation unit");
7051 elsif Arg_Count = 0 then
7053 ("argument required if outside compilation unit");
7056 Check_No_Identifiers;
7057 Check_Arg_Count (1);
7058 Unit_Node := Unit (Parent (Parent_Node));
7059 Unit_Kind := Nkind (Unit_Node);
7061 Analyze (Get_Pragma_Arg (Arg1));
7063 if Unit_Kind = N_Generic_Subprogram_Declaration
7064 or else Unit_Kind = N_Subprogram_Declaration
7066 Unit_Name := Defining_Entity (Unit_Node);
7068 elsif Unit_Kind in N_Generic_Instantiation then
7069 Unit_Name := Defining_Entity (Unit_Node);
7072 Unit_Name := Cunit_Entity (Current_Sem_Unit);
7075 if Chars (Unit_Name) /=
7076 Chars (Entity (Get_Pragma_Arg (Arg1)))
7079 ("pragma% argument is not current unit name", Arg1);
7082 if Ekind (Unit_Name) = E_Package
7083 and then Present (Renamed_Entity (Unit_Name))
7085 Error_Pragma ("pragma% not allowed for renamed package");
7089 -- Pragma appears other than after a compilation unit
7092 -- Here we check for the generic instantiation case and also
7093 -- for the case of processing a generic formal package. We
7094 -- detect these cases by noting that the Sloc on the node
7095 -- does not belong to the current compilation unit.
7097 Sindex := Source_Index (Current_Sem_Unit);
7099 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
7100 -- We do not want to raise an exception here since this code
7101 -- is part of the bootstrap path where we cannot rely on
7102 -- exception propagation working.
7103 -- Instead the caller should check for N being rewritten as
7104 -- a null statement.
7105 -- This code triggers when compiling a-except.adb.
7107 Rewrite (N, Make_Null_Statement (Loc));
7109 -- If before first declaration, the pragma applies to the
7110 -- enclosing unit, and the name if present must be this name.
7112 elsif Is_Before_First_Decl (N, Plist) then
7113 Unit_Node := Unit_Declaration_Node (Current_Scope);
7114 Unit_Kind := Nkind (Unit_Node);
7116 if Unit_Node = Standard_Package_Node then
7118 ("pragma% misplaced, must be inside or after the "
7119 & "compilation unit");
7121 elsif Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
7123 ("pragma% misplaced, must be on library unit");
7125 elsif Unit_Kind = N_Subprogram_Body
7126 and then not Acts_As_Spec (Unit_Node)
7129 ("pragma% misplaced, must be on the subprogram spec");
7131 elsif Nkind (Parent_Node) = N_Package_Body then
7133 ("pragma% misplaced, must be on the package spec");
7135 elsif Nkind (Parent_Node) = N_Package_Specification
7136 and then Plist = Private_Declarations (Parent_Node)
7139 ("pragma% misplaced, must be in the public part");
7141 elsif Nkind (Parent_Node) in N_Generic_Declaration
7142 and then Plist = Generic_Formal_Declarations (Parent_Node)
7145 ("pragma% misplaced, must not be in formal part");
7147 elsif Arg_Count > 0 then
7148 Analyze (Get_Pragma_Arg (Arg1));
7150 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
7152 ("name in pragma% must be enclosing unit", Arg1);
7155 -- It is legal to have no argument in this context
7161 -- Error if not before first declaration. This is because a
7162 -- library unit pragma argument must be the name of a library
7163 -- unit (RM 10.1.5(7)), but the only names permitted in this
7164 -- context are (RM 10.1.5(6)) names of subprogram declarations,
7165 -- generic subprogram declarations or generic instantiations.
7169 ("pragma% misplaced, must be before first declaration");
7173 end Check_Valid_Library_Unit_Pragma;
7179 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
7180 Clist : constant Node_Id := Component_List (Variant);
7184 Comp := First_Non_Pragma (Component_Items (Clist));
7185 while Present (Comp) loop
7186 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
7187 Next_Non_Pragma (Comp);
7191 ---------------------------
7192 -- Ensure_Aggregate_Form --
7193 ---------------------------
7195 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
7196 CFSD : constant Boolean := Get_Comes_From_Source_Default;
7197 Expr : constant Node_Id := Expression (Arg);
7198 Loc : constant Source_Ptr := Sloc (Expr);
7199 Comps : List_Id := No_List;
7200 Exprs : List_Id := No_List;
7201 Nam : Name_Id := No_Name;
7202 Nam_Loc : Source_Ptr;
7205 -- The pragma argument is in positional form:
7207 -- pragma Depends (Nam => ...)
7211 -- Note that the Sloc of the Chars field is the Sloc of the pragma
7212 -- argument association.
7214 if Nkind (Arg) = N_Pragma_Argument_Association then
7216 Nam_Loc := Sloc (Arg);
7218 -- Remove the pragma argument name as this will be captured in the
7221 Set_Chars (Arg, No_Name);
7224 -- The argument is already in aggregate form, but the presence of a
7225 -- name causes this to be interpreted as named association which in
7226 -- turn must be converted into an aggregate.
7228 -- pragma Global (In_Out => (A, B, C))
7232 -- pragma Global ((In_Out => (A, B, C)))
7234 -- aggregate aggregate
7236 if Nkind (Expr) = N_Aggregate then
7237 if Nam = No_Name then
7241 -- Do not transform a null argument into an aggregate as N_Null has
7242 -- special meaning in formal verification pragmas.
7244 elsif Nkind (Expr) = N_Null then
7248 -- Everything comes from source if the original comes from source
7250 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
7252 -- Positional argument is transformed into an aggregate with an
7253 -- Expressions list.
7255 if Nam = No_Name then
7256 Exprs := New_List (Relocate_Node (Expr));
7258 -- An associative argument is transformed into an aggregate with
7259 -- Component_Associations.
7263 Make_Component_Association (Loc,
7264 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
7265 Expression => Relocate_Node (Expr)));
7268 Set_Expression (Arg,
7269 Make_Aggregate (Loc,
7270 Component_Associations => Comps,
7271 Expressions => Exprs));
7273 -- Restore Comes_From_Source default
7275 Set_Comes_From_Source_Default (CFSD);
7276 end Ensure_Aggregate_Form;
7282 procedure Error_Pragma (Msg : String) is
7284 Error_Msg_Name_1 := Pname;
7285 Error_Msg_N (Fix_Error (Msg), N);
7289 ----------------------
7290 -- Error_Pragma_Arg --
7291 ----------------------
7293 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
7295 Error_Msg_Name_1 := Pname;
7296 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
7298 end Error_Pragma_Arg;
7300 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
7302 Error_Msg_Name_1 := Pname;
7303 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
7304 Error_Pragma_Arg (Msg2, Arg);
7305 end Error_Pragma_Arg;
7307 ----------------------------
7308 -- Error_Pragma_Arg_Ident --
7309 ----------------------------
7311 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
7313 Error_Msg_Name_1 := Pname;
7314 Error_Msg_N (Fix_Error (Msg), Arg);
7316 end Error_Pragma_Arg_Ident;
7318 ----------------------
7319 -- Error_Pragma_Ref --
7320 ----------------------
7322 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
7324 Error_Msg_Name_1 := Pname;
7325 Error_Msg_Sloc := Sloc (Ref);
7326 Error_Msg_NE (Fix_Error (Msg), N, Ref);
7328 end Error_Pragma_Ref;
7330 ------------------------
7331 -- Find_Lib_Unit_Name --
7332 ------------------------
7334 function Find_Lib_Unit_Name return Entity_Id is
7336 -- Return inner compilation unit entity, for case of nested
7337 -- categorization pragmas. This happens in generic unit.
7339 if Nkind (Parent (N)) = N_Package_Specification
7340 and then Defining_Entity (Parent (N)) /= Current_Scope
7342 return Defining_Entity (Parent (N));
7344 return Current_Scope;
7346 end Find_Lib_Unit_Name;
7348 ----------------------------
7349 -- Find_Program_Unit_Name --
7350 ----------------------------
7352 procedure Find_Program_Unit_Name (Id : Node_Id) is
7353 Unit_Name : Entity_Id;
7354 Unit_Kind : Node_Kind;
7355 P : constant Node_Id := Parent (N);
7358 if Nkind (P) = N_Compilation_Unit then
7359 Unit_Kind := Nkind (Unit (P));
7361 if Unit_Kind in N_Subprogram_Declaration
7362 | N_Package_Declaration
7363 | N_Generic_Declaration
7365 Unit_Name := Defining_Entity (Unit (P));
7367 if Chars (Id) = Chars (Unit_Name) then
7368 Set_Entity (Id, Unit_Name);
7369 Set_Etype (Id, Etype (Unit_Name));
7371 Set_Etype (Id, Any_Type);
7373 ("cannot find program unit referenced by pragma%");
7377 Set_Etype (Id, Any_Type);
7378 Error_Pragma ("pragma% inapplicable to this unit");
7384 end Find_Program_Unit_Name;
7386 -----------------------------------------
7387 -- Find_Unique_Parameterless_Procedure --
7388 -----------------------------------------
7390 function Find_Unique_Parameterless_Procedure
7392 Arg : Node_Id) return Entity_Id
7394 Proc : Entity_Id := Empty;
7397 -- Perform sanity checks on Name
7399 if not Is_Entity_Name (Name) then
7401 ("argument of pragma% must be entity name", Arg);
7403 elsif not Is_Overloaded (Name) then
7404 Proc := Entity (Name);
7406 if Ekind (Proc) /= E_Procedure
7407 or else Present (First_Formal (Proc))
7410 ("argument of pragma% must be parameterless procedure", Arg);
7413 -- Otherwise, search through interpretations looking for one which
7414 -- has no parameters.
7418 Found : Boolean := False;
7420 Index : Interp_Index;
7423 Get_First_Interp (Name, Index, It);
7424 while Present (It.Nam) loop
7427 if Ekind (Proc) = E_Procedure
7428 and then No (First_Formal (Proc))
7430 -- We found an interpretation, note it and continue
7431 -- looking looking to verify it is unique.
7435 Set_Entity (Name, Proc);
7436 Set_Is_Overloaded (Name, False);
7438 -- Two procedures with the same name, log an error
7439 -- since the name is ambiguous.
7443 ("ambiguous handler name for pragma%", Arg);
7447 Get_Next_Interp (Index, It);
7451 -- Issue an error if we haven't found a suitable match for
7455 ("argument of pragma% must be parameterless procedure",
7459 Proc := Entity (Name);
7465 end Find_Unique_Parameterless_Procedure;
7471 function Fix_Error (Msg : String) return String is
7472 Res : String (Msg'Range) := Msg;
7473 Res_Last : Natural := Msg'Last;
7477 -- If we have a rewriting of another pragma, go to that pragma
7479 if Is_Rewrite_Substitution (N)
7480 and then Nkind (Original_Node (N)) = N_Pragma
7482 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
7485 -- Case where pragma comes from an aspect specification
7487 if From_Aspect_Specification (N) then
7489 -- Change appearance of "pragma" in message to "aspect"
7492 while J <= Res_Last - 5 loop
7493 if Res (J .. J + 5) = "pragma" then
7494 Res (J .. J + 5) := "aspect";
7502 -- Change "argument of" at start of message to "entity for"
7505 and then Res (Res'First .. Res'First + 10) = "argument of"
7507 Res (Res'First .. Res'First + 9) := "entity for";
7508 Res (Res'First + 10 .. Res_Last - 1) :=
7509 Res (Res'First + 11 .. Res_Last);
7510 Res_Last := Res_Last - 1;
7513 -- Change "argument" at start of message to "entity"
7516 and then Res (Res'First .. Res'First + 7) = "argument"
7518 Res (Res'First .. Res'First + 5) := "entity";
7519 Res (Res'First + 6 .. Res_Last - 2) :=
7520 Res (Res'First + 8 .. Res_Last);
7521 Res_Last := Res_Last - 2;
7524 -- Get name from corresponding aspect
7526 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7529 -- Return possibly modified message
7531 return Res (Res'First .. Res_Last);
7534 -------------------------
7535 -- Gather_Associations --
7536 -------------------------
7538 procedure Gather_Associations
7540 Args : out Args_List)
7545 -- Initialize all parameters to Empty
7547 for J in Args'Range loop
7551 -- That's all we have to do if there are no argument associations
7553 if No (Pragma_Argument_Associations (N)) then
7557 -- Otherwise first deal with any positional parameters present
7559 Arg := First (Pragma_Argument_Associations (N));
7560 for Index in Args'Range loop
7561 exit when No (Arg) or else Chars (Arg) /= No_Name;
7562 Args (Index) := Get_Pragma_Arg (Arg);
7566 -- Positional parameters all processed, if any left, then we
7567 -- have too many positional parameters.
7569 if Present (Arg) and then Chars (Arg) = No_Name then
7571 ("too many positional associations for pragma%", Arg);
7574 -- Process named parameters if any are present
7576 while Present (Arg) loop
7577 if Chars (Arg) = No_Name then
7579 ("positional association cannot follow named association",
7583 for Index in Names'Range loop
7584 if Names (Index) = Chars (Arg) then
7585 if Present (Args (Index)) then
7587 ("duplicate argument association for pragma%", Arg);
7589 Args (Index) := Get_Pragma_Arg (Arg);
7594 if Index = Names'Last then
7595 Error_Msg_Name_1 := Pname;
7596 Error_Msg_N ("pragma% does not allow & argument", Arg);
7598 -- Check for possible misspelling
7600 for Index1 in Names'Range loop
7601 if Is_Bad_Spelling_Of
7602 (Chars (Arg), Names (Index1))
7604 Error_Msg_Name_1 := Names (Index1);
7605 Error_Msg_N -- CODEFIX
7606 ("\possible misspelling of%", Arg);
7618 end Gather_Associations;
7624 procedure GNAT_Pragma is
7626 -- We need to check the No_Implementation_Pragmas restriction for
7627 -- the case of a pragma from source. Note that the case of aspects
7628 -- generating corresponding pragmas marks these pragmas as not being
7629 -- from source, so this test also catches that case.
7631 if Comes_From_Source (N) then
7632 Check_Restriction (No_Implementation_Pragmas, N);
7636 --------------------------
7637 -- Is_Before_First_Decl --
7638 --------------------------
7640 function Is_Before_First_Decl
7641 (Pragma_Node : Node_Id;
7642 Decls : List_Id) return Boolean
7644 Item : Node_Id := First (Decls);
7647 -- Only other pragmas can come before this pragma, but they might
7648 -- have been rewritten so check the original node.
7651 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7654 elsif Item = Pragma_Node then
7660 end Is_Before_First_Decl;
7662 -----------------------------
7663 -- Is_Configuration_Pragma --
7664 -----------------------------
7666 -- A configuration pragma must appear in the context clause of a
7667 -- compilation unit, and only other pragmas may precede it. Note that
7668 -- the test below also permits use in a configuration pragma file.
7670 function Is_Configuration_Pragma return Boolean is
7672 Par : constant Node_Id := Parent (N);
7676 -- Don't evaluate List_Containing (N) if Parent (N) could be
7677 -- an N_Aspect_Specification node.
7679 if not Is_List_Member (N) then
7683 Lis := List_Containing (N);
7685 -- If no parent, then we are in the configuration pragma file,
7686 -- so the placement is definitely appropriate.
7691 -- Otherwise we must be in the context clause of a compilation unit
7692 -- and the only thing allowed before us in the context list is more
7693 -- configuration pragmas.
7695 elsif Nkind (Par) = N_Compilation_Unit
7696 and then Context_Items (Par) = Lis
7703 elsif Nkind (Prg) /= N_Pragma then
7713 end Is_Configuration_Pragma;
7715 --------------------------
7716 -- Is_In_Context_Clause --
7717 --------------------------
7719 function Is_In_Context_Clause return Boolean is
7721 Parent_Node : Node_Id;
7724 if Is_List_Member (N) then
7725 Plist := List_Containing (N);
7726 Parent_Node := Parent (Plist);
7728 return Present (Parent_Node)
7729 and then Nkind (Parent_Node) = N_Compilation_Unit
7730 and then Context_Items (Parent_Node) = Plist;
7734 end Is_In_Context_Clause;
7736 ---------------------------------
7737 -- Is_Static_String_Expression --
7738 ---------------------------------
7740 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7741 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7742 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7745 Analyze_And_Resolve (Argx);
7747 -- Special case Ada 83, where the expression will never be static,
7748 -- but we will return true if we had a string literal to start with.
7750 if Ada_Version = Ada_83 then
7753 -- Normal case, true only if we end up with a string literal that
7754 -- is marked as being the result of evaluating a static expression.
7757 return Is_OK_Static_Expression (Argx)
7758 and then Nkind (Argx) = N_String_Literal;
7761 end Is_Static_String_Expression;
7763 ----------------------
7764 -- Pragma_Misplaced --
7765 ----------------------
7767 procedure Pragma_Misplaced is
7769 Error_Pragma ("incorrect placement of pragma%");
7770 end Pragma_Misplaced;
7772 ------------------------------------------------
7773 -- Process_Atomic_Independent_Shared_Volatile --
7774 ------------------------------------------------
7776 procedure Process_Atomic_Independent_Shared_Volatile is
7777 procedure Check_Full_Access_Only (Ent : Entity_Id);
7778 -- Apply legality checks to type or object Ent subject to the
7779 -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)).
7781 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7782 -- Appropriately set flags on the given entity, either an array or
7783 -- record component, or an object declaration) according to the
7786 procedure Mark_Type (Ent : Entity_Id);
7787 -- Appropriately set flags on the given entity, a type
7789 procedure Set_Atomic_VFA (Ent : Entity_Id);
7790 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7791 -- no explicit alignment was given, set alignment to unknown, since
7792 -- back end knows what the alignment requirements are for atomic and
7793 -- full access arrays. Note: this is necessary for derived types.
7795 -------------------------
7796 -- Check_Full_Access_Only --
7797 -------------------------
7799 procedure Check_Full_Access_Only (Ent : Entity_Id) is
7802 Full_Access_Subcomponent : exception;
7803 -- Exception raised if a full access subcomponent is found
7805 Generic_Type_Subcomponent : exception;
7806 -- Exception raised if a subcomponent with generic type is found
7808 procedure Check_Subcomponents (Typ : Entity_Id);
7809 -- Apply checks to subcomponents recursively
7811 -------------------------
7812 -- Check_Subcomponents --
7813 -------------------------
7815 procedure Check_Subcomponents (Typ : Entity_Id) is
7819 if Is_Array_Type (Typ) then
7820 Comp := Component_Type (Typ);
7822 if Has_Atomic_Components (Typ)
7823 or else Is_Full_Access (Comp)
7825 raise Full_Access_Subcomponent;
7827 elsif Is_Generic_Type (Comp) then
7828 raise Generic_Type_Subcomponent;
7831 -- Recurse on the component type
7833 Check_Subcomponents (Comp);
7835 elsif Is_Record_Type (Typ) then
7836 Comp := First_Component_Or_Discriminant (Typ);
7837 while Present (Comp) loop
7839 if Is_Full_Access (Comp)
7840 or else Is_Full_Access (Etype (Comp))
7842 raise Full_Access_Subcomponent;
7844 elsif Is_Generic_Type (Etype (Comp)) then
7845 raise Generic_Type_Subcomponent;
7848 -- Recurse on the component type
7850 Check_Subcomponents (Etype (Comp));
7852 Next_Component_Or_Discriminant (Comp);
7855 end Check_Subcomponents;
7857 -- Start of processing for Check_Full_Access_Only
7860 -- Fetch the type in case we are dealing with an object or
7863 if Is_Type (Ent) then
7866 pragma Assert (Is_Object (Ent)
7868 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7873 if not Is_Volatile (Ent) and then not Is_Volatile (Typ) then
7875 ("cannot have Full_Access_Only without Volatile/Atomic "
7879 -- Check all the subcomponents of the type recursively, if any
7881 Check_Subcomponents (Typ);
7884 when Full_Access_Subcomponent =>
7886 ("cannot have Full_Access_Only with full access subcomponent "
7889 when Generic_Type_Subcomponent =>
7891 ("cannot have Full_Access_Only with subcomponent of generic "
7892 & "type (RM C.6(8.2))");
7894 end Check_Full_Access_Only;
7896 ------------------------------
7897 -- Mark_Component_Or_Object --
7898 ------------------------------
7900 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7902 if Prag_Id = Pragma_Atomic
7903 or else Prag_Id = Pragma_Shared
7904 or else Prag_Id = Pragma_Volatile_Full_Access
7906 if Prag_Id = Pragma_Volatile_Full_Access then
7907 Set_Is_Volatile_Full_Access (Ent);
7909 Set_Is_Atomic (Ent);
7912 -- If the object declaration has an explicit initialization, a
7913 -- temporary may have to be created to hold the expression, to
7914 -- ensure that access to the object remains atomic.
7916 if Nkind (Parent (Ent)) = N_Object_Declaration
7917 and then Present (Expression (Parent (Ent)))
7919 Set_Has_Delayed_Freeze (Ent);
7923 -- Atomic/Shared/Volatile_Full_Access imply Independent
7925 if Prag_Id /= Pragma_Volatile then
7926 Set_Is_Independent (Ent);
7928 if Prag_Id = Pragma_Independent then
7929 Record_Independence_Check (N, Ent);
7933 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7935 if Prag_Id /= Pragma_Independent then
7936 Set_Is_Volatile (Ent);
7937 Set_Treat_As_Volatile (Ent);
7939 end Mark_Component_Or_Object;
7945 procedure Mark_Type (Ent : Entity_Id) is
7947 -- Attribute belongs on the base type. If the view of the type is
7948 -- currently private, it also belongs on the underlying type.
7950 -- In Ada 2022, the pragma can apply to a formal type, for which
7951 -- there may be no underlying type.
7953 if Prag_Id = Pragma_Atomic
7954 or else Prag_Id = Pragma_Shared
7955 or else Prag_Id = Pragma_Volatile_Full_Access
7957 Set_Atomic_VFA (Ent);
7958 Set_Atomic_VFA (Base_Type (Ent));
7960 if not Is_Generic_Type (Ent) then
7961 Set_Atomic_VFA (Underlying_Type (Ent));
7965 -- Atomic/Shared/Volatile_Full_Access imply Independent
7967 if Prag_Id /= Pragma_Volatile then
7968 Set_Is_Independent (Ent);
7969 Set_Is_Independent (Base_Type (Ent));
7971 if not Is_Generic_Type (Ent) then
7972 Set_Is_Independent (Underlying_Type (Ent));
7974 if Prag_Id = Pragma_Independent then
7975 Record_Independence_Check (N, Base_Type (Ent));
7980 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7982 if Prag_Id /= Pragma_Independent then
7983 Set_Is_Volatile (Ent);
7984 Set_Is_Volatile (Base_Type (Ent));
7986 if not Is_Generic_Type (Ent) then
7987 Set_Is_Volatile (Underlying_Type (Ent));
7988 Set_Treat_As_Volatile (Underlying_Type (Ent));
7991 Set_Treat_As_Volatile (Ent);
7994 -- Apply Volatile to the composite type's individual components,
7997 if Prag_Id = Pragma_Volatile
7998 and then Is_Record_Type (Etype (Ent))
8003 Comp := First_Component (Ent);
8004 while Present (Comp) loop
8005 Mark_Component_Or_Object (Comp);
8007 Next_Component (Comp);
8013 --------------------
8014 -- Set_Atomic_VFA --
8015 --------------------
8017 procedure Set_Atomic_VFA (Ent : Entity_Id) is
8019 if Prag_Id = Pragma_Volatile_Full_Access then
8020 Set_Is_Volatile_Full_Access (Ent);
8022 Set_Is_Atomic (Ent);
8025 if not Has_Alignment_Clause (Ent) then
8026 Reinit_Alignment (Ent);
8036 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
8039 Check_Ada_83_Warning;
8040 Check_No_Identifiers;
8041 Check_Arg_Count (1);
8042 Check_Arg_Is_Local_Name (Arg1);
8043 E_Arg := Get_Pragma_Arg (Arg1);
8045 if Etype (E_Arg) = Any_Type then
8049 E := Entity (E_Arg);
8050 Decl := Declaration_Node (E);
8052 -- A pragma that applies to a Ghost entity becomes Ghost for the
8053 -- purposes of legality checks and removal of ignored Ghost code.
8055 Mark_Ghost_Pragma (N, E);
8057 -- Check duplicate before we chain ourselves
8059 Check_Duplicate_Pragma (E);
8061 -- Check the constraints of Full_Access_Only in Ada 2022. Note that
8062 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
8063 -- aspect subsumes the Volatile aspect and 2) nesting is supported
8064 -- for this aspect and the outermost enclosing VFA object prevails.
8066 -- Note also that we used to forbid specifying both Atomic and VFA on
8067 -- the same type or object, but the restriction has been lifted in
8068 -- light of the semantics of Full_Access_Only and Atomic in Ada 2022.
8070 if Prag_Id = Pragma_Volatile_Full_Access
8071 and then From_Aspect_Specification (N)
8073 Get_Aspect_Id (Corresponding_Aspect (N)) = Aspect_Full_Access_Only
8075 Check_Full_Access_Only (E);
8078 -- Deal with the case where the pragma/attribute is applied to a type
8081 if Rep_Item_Too_Early (E, N)
8082 or else Rep_Item_Too_Late (E, N)
8086 Check_First_Subtype (Arg1);
8091 -- Deal with the case where the pragma/attribute applies to a
8092 -- component or object declaration.
8094 elsif Nkind (Decl) = N_Object_Declaration
8095 or else (Nkind (Decl) = N_Component_Declaration
8096 and then Original_Record_Component (E) = E)
8098 if Rep_Item_Too_Late (E, N) then
8102 Mark_Component_Or_Object (E);
8104 -- In other cases give an error
8107 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
8109 end Process_Atomic_Independent_Shared_Volatile;
8111 -------------------------------------------
8112 -- Process_Compile_Time_Warning_Or_Error --
8113 -------------------------------------------
8115 procedure Process_Compile_Time_Warning_Or_Error is
8116 P : Node_Id := Parent (N);
8117 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
8120 Check_Arg_Count (2);
8121 Check_No_Identifiers;
8122 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
8123 Analyze_And_Resolve (Arg1x, Standard_Boolean);
8125 -- In GNATprove mode, pragma Compile_Time_Error is translated as
8126 -- a Check pragma in GNATprove mode, handled as an assumption in
8127 -- GNATprove. This is correct as the compiler will issue an error
8128 -- if the condition cannot be statically evaluated to False.
8129 -- Compile_Time_Warning are ignored, as the analyzer may not have the
8130 -- same information as the compiler (in particular regarding size of
8131 -- objects decided in gigi) so it makes no sense to issue a warning
8134 if GNATprove_Mode then
8135 if Prag_Id = Pragma_Compile_Time_Error then
8139 -- Implement Compile_Time_Error by generating
8140 -- a corresponding Check pragma:
8142 -- pragma Check (name, condition);
8144 -- where name is the identifier matching the pragma name. So
8145 -- rewrite pragma in this manner and analyze the result.
8147 New_Args := New_List
8148 (Make_Pragma_Argument_Association
8150 Expression => Make_Identifier (Loc, Pname)),
8151 Make_Pragma_Argument_Association
8153 Expression => Arg1x));
8155 -- Rewrite as Check pragma
8159 Chars => Name_Check,
8160 Pragma_Argument_Associations => New_Args));
8166 Rewrite (N, Make_Null_Statement (Loc));
8172 -- If the condition is known at compile time (now), validate it now.
8173 -- Otherwise, register the expression for validation after the back
8174 -- end has been called, because it might be known at compile time
8175 -- then. For example, if the expression is "Record_Type'Size /= 32"
8176 -- it might be known after the back end has determined the size of
8177 -- Record_Type. We do not defer validation if we're inside a generic
8178 -- unit, because we will have more information in the instances, and
8179 -- this ultimately applies to the main unit itself, because it is not
8180 -- compiled by the back end when it is generic.
8182 if Compile_Time_Known_Value (Arg1x) then
8183 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
8186 while Present (P) and then Nkind (P) not in N_Generic_Declaration
8188 if (Nkind (P) = N_Subprogram_Body and then not Acts_As_Spec (P))
8189 or else Nkind (P) = N_Package_Body
8191 P := Parent (Corresponding_Spec (P));
8200 Nkind (Unit (Cunit (Main_Unit))) not in N_Generic_Declaration
8202 Defer_Compile_Time_Warning_Error_To_BE (N);
8205 end Process_Compile_Time_Warning_Or_Error;
8207 ------------------------
8208 -- Process_Convention --
8209 ------------------------
8211 procedure Process_Convention
8212 (C : out Convention_Id;
8213 Ent : out Entity_Id)
8217 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
8218 -- Called if we have more than one Export/Import/Convention pragma.
8219 -- This is generally illegal, but we have a special case of allowing
8220 -- Import and Interface to coexist if they specify the convention in
8221 -- a consistent manner. We are allowed to do this, since Interface is
8222 -- an implementation defined pragma, and we choose to do it since we
8223 -- know Rational allows this combination. S is the entity id of the
8224 -- subprogram in question. This procedure also sets the special flag
8225 -- Import_Interface_Present in both pragmas in the case where we do
8226 -- have matching Import and Interface pragmas.
8228 procedure Set_Convention_From_Pragma (E : Entity_Id);
8229 -- Set convention in entity E, and also flag that the entity has a
8230 -- convention pragma. If entity is for a private or incomplete type,
8231 -- also set convention and flag on underlying type. This procedure
8232 -- also deals with the special case of C_Pass_By_Copy convention,
8233 -- and error checks for inappropriate convention specification.
8235 -------------------------------
8236 -- Diagnose_Multiple_Pragmas --
8237 -------------------------------
8239 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
8240 Pdec : constant Node_Id := Declaration_Node (S);
8244 function Same_Convention (Decl : Node_Id) return Boolean;
8245 -- Decl is a pragma node. This function returns True if this
8246 -- pragma has a first argument that is an identifier with a
8247 -- Chars field corresponding to the Convention_Id C.
8249 function Same_Name (Decl : Node_Id) return Boolean;
8250 -- Decl is a pragma node. This function returns True if this
8251 -- pragma has a second argument that is an identifier with a
8252 -- Chars field that matches the Chars of the current subprogram.
8254 ---------------------
8255 -- Same_Convention --
8256 ---------------------
8258 function Same_Convention (Decl : Node_Id) return Boolean is
8259 Arg1 : constant Node_Id :=
8260 First (Pragma_Argument_Associations (Decl));
8263 if Present (Arg1) then
8265 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
8267 if Nkind (Arg) = N_Identifier
8268 and then Is_Convention_Name (Chars (Arg))
8269 and then Get_Convention_Id (Chars (Arg)) = C
8277 end Same_Convention;
8283 function Same_Name (Decl : Node_Id) return Boolean is
8284 Arg1 : constant Node_Id :=
8285 First (Pragma_Argument_Associations (Decl));
8293 Arg2 := Next (Arg1);
8300 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
8302 if Nkind (Arg) = N_Identifier
8303 and then Chars (Arg) = Chars (S)
8312 -- Start of processing for Diagnose_Multiple_Pragmas
8317 -- Definitely give message if we have Convention/Export here
8319 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
8322 -- If we have an Import or Export, scan back from pragma to
8323 -- find any previous pragma applying to the same procedure.
8324 -- The scan will be terminated by the start of the list, or
8325 -- hitting the subprogram declaration. This won't allow one
8326 -- pragma to appear in the public part and one in the private
8327 -- part, but that seems very unlikely in practice.
8331 while Present (Decl) and then Decl /= Pdec loop
8333 -- Look for pragma with same name as us
8335 if Nkind (Decl) = N_Pragma
8336 and then Same_Name (Decl)
8338 -- Give error if same as our pragma or Export/Convention
8340 if Pragma_Name_Unmapped (Decl)
8343 | Pragma_Name_Unmapped (N)
8347 -- Case of Import/Interface or the other way round
8349 elsif Pragma_Name_Unmapped (Decl)
8350 in Name_Interface | Name_Import
8352 -- Here we know that we have Import and Interface. It
8353 -- doesn't matter which way round they are. See if
8354 -- they specify the same convention. If so, all OK,
8355 -- and set special flags to stop other messages
8357 if Same_Convention (Decl) then
8358 Set_Import_Interface_Present (N);
8359 Set_Import_Interface_Present (Decl);
8362 -- If different conventions, special message
8365 Error_Msg_Sloc := Sloc (Decl);
8367 ("convention differs from that given#", Arg1);
8376 -- Give message if needed if we fall through those tests
8377 -- except on Relaxed_RM_Semantics where we let go: either this
8378 -- is a case accepted/ignored by other Ada compilers (e.g.
8379 -- a mix of Convention and Import), or another error will be
8380 -- generated later (e.g. using both Import and Export).
8382 if Err and not Relaxed_RM_Semantics then
8384 ("at most one Convention/Export/Import pragma is allowed",
8387 end Diagnose_Multiple_Pragmas;
8389 --------------------------------
8390 -- Set_Convention_From_Pragma --
8391 --------------------------------
8393 procedure Set_Convention_From_Pragma (E : Entity_Id) is
8395 -- Ada 2005 (AI-430): Check invalid attempt to change convention
8396 -- for an overridden dispatching operation. Technically this is
8397 -- an amendment and should only be done in Ada 2005 mode. However,
8398 -- this is clearly a mistake, since the problem that is addressed
8399 -- by this AI is that there is a clear gap in the RM.
8401 if Is_Dispatching_Operation (E)
8402 and then Present (Overridden_Operation (E))
8403 and then C /= Convention (Overridden_Operation (E))
8406 ("cannot change convention for overridden dispatching "
8407 & "operation", Arg1);
8409 -- Special check for convention Stdcall: a dispatching call is not
8410 -- allowed. A dispatching subprogram cannot be used to interface
8411 -- to the Win32 API, so this check actually does not impose any
8412 -- effective restriction.
8414 elsif Is_Dispatching_Operation (E)
8415 and then C = Convention_Stdcall
8417 -- Note: make this unconditional so that if there is more
8418 -- than one call to which the pragma applies, we get a
8419 -- message for each call. Also don't use Error_Pragma,
8420 -- so that we get multiple messages.
8422 Error_Msg_Sloc := Sloc (E);
8424 ("dispatching subprogram# cannot use Stdcall convention!",
8425 Get_Pragma_Arg (Arg1));
8428 -- Set the convention
8430 Set_Convention (E, C);
8431 Set_Has_Convention_Pragma (E);
8433 -- For the case of a record base type, also set the convention of
8434 -- any anonymous access types declared in the record which do not
8435 -- currently have a specified convention.
8436 -- Similarly for an array base type and anonymous access types
8439 if Is_Base_Type (E) then
8440 if Is_Record_Type (E) then
8445 Comp := First_Component (E);
8446 while Present (Comp) loop
8447 if Present (Etype (Comp))
8449 Ekind (Etype (Comp)) in
8450 E_Anonymous_Access_Type |
8451 E_Anonymous_Access_Subprogram_Type
8452 and then not Has_Convention_Pragma (Comp)
8454 Set_Convention (Comp, C);
8457 Next_Component (Comp);
8461 elsif Is_Array_Type (E)
8462 and then Ekind (Component_Type (E)) in
8463 E_Anonymous_Access_Type |
8464 E_Anonymous_Access_Subprogram_Type
8466 Set_Convention (Designated_Type (Component_Type (E)), C);
8470 -- Deal with incomplete/private type case, where underlying type
8471 -- is available, so set convention of that underlying type.
8473 if Is_Incomplete_Or_Private_Type (E)
8474 and then Present (Underlying_Type (E))
8476 Set_Convention (Underlying_Type (E), C);
8477 Set_Has_Convention_Pragma (Underlying_Type (E), True);
8480 -- A class-wide type should inherit the convention of the specific
8481 -- root type (although this isn't specified clearly by the RM).
8483 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
8484 Set_Convention (Class_Wide_Type (E), C);
8487 -- If the entity is a record type, then check for special case of
8488 -- C_Pass_By_Copy, which is treated the same as C except that the
8489 -- special record flag is set. This convention is only permitted
8490 -- on record types (see AI95-00131).
8492 if Cname = Name_C_Pass_By_Copy then
8493 if Is_Record_Type (E) then
8494 Set_C_Pass_By_Copy (Base_Type (E));
8495 elsif Is_Incomplete_Or_Private_Type (E)
8496 and then Is_Record_Type (Underlying_Type (E))
8498 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
8501 ("C_Pass_By_Copy convention allowed only for record type",
8506 -- If the entity is a derived boolean type, check for the special
8507 -- case of convention C, C++, or Fortran, where we consider any
8508 -- nonzero value to represent true.
8510 if Is_Discrete_Type (E)
8511 and then Root_Type (Etype (E)) = Standard_Boolean
8517 C = Convention_Fortran)
8519 Set_Nonzero_Is_True (Base_Type (E));
8521 end Set_Convention_From_Pragma;
8525 Comp_Unit : Unit_Number_Type;
8531 -- Start of processing for Process_Convention
8534 Check_At_Least_N_Arguments (2);
8535 Check_Optional_Identifier (Arg1, Name_Convention);
8536 Check_Arg_Is_Identifier (Arg1);
8537 Cname := Chars (Get_Pragma_Arg (Arg1));
8539 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8540 -- tested again below to set the critical flag).
8542 if Cname = Name_C_Pass_By_Copy then
8545 -- Otherwise we must have something in the standard convention list
8547 elsif Is_Convention_Name (Cname) then
8548 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8550 -- Otherwise warn on unrecognized convention
8553 if Warn_On_Export_Import then
8555 ("??unrecognized convention name, C assumed",
8556 Get_Pragma_Arg (Arg1));
8562 Check_Optional_Identifier (Arg2, Name_Entity);
8563 Check_Arg_Is_Local_Name (Arg2);
8565 Id := Get_Pragma_Arg (Arg2);
8568 if not Is_Entity_Name (Id) then
8569 Error_Pragma_Arg ("entity name required", Arg2);
8574 -- Set entity to return
8578 -- Ada_Pass_By_Copy special checking
8580 if C = Convention_Ada_Pass_By_Copy then
8581 if not Is_First_Subtype (E) then
8583 ("convention `Ada_Pass_By_Copy` only allowed for types",
8587 if Is_By_Reference_Type (E) then
8589 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8593 -- Ada_Pass_By_Reference special checking
8595 elsif C = Convention_Ada_Pass_By_Reference then
8596 if not Is_First_Subtype (E) then
8598 ("convention `Ada_Pass_By_Reference` only allowed for types",
8602 if Is_By_Copy_Type (E) then
8604 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8609 -- Go to renamed subprogram if present, since convention applies to
8610 -- the actual renamed entity, not to the renaming entity. If the
8611 -- subprogram is inherited, go to parent subprogram.
8613 if Is_Subprogram (E)
8614 and then Present (Alias (E))
8616 if Nkind (Parent (Declaration_Node (E))) =
8617 N_Subprogram_Renaming_Declaration
8619 if Scope (E) /= Scope (Alias (E)) then
8621 ("cannot apply pragma% to non-local entity&#", E);
8626 elsif Nkind (Parent (E)) in
8627 N_Full_Type_Declaration | N_Private_Extension_Declaration
8628 and then Scope (E) = Scope (Alias (E))
8632 -- Return the parent subprogram the entity was inherited from
8638 -- Check that we are not applying this to a specless body. Relax this
8639 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8641 if Is_Subprogram (E)
8642 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8643 and then not Relaxed_RM_Semantics
8646 ("pragma% requires separate spec and must come before body");
8649 -- Check that we are not applying this to a named constant
8651 if Is_Named_Number (E) then
8652 Error_Msg_Name_1 := Pname;
8654 ("cannot apply pragma% to named constant!",
8655 Get_Pragma_Arg (Arg2));
8657 ("\supply appropriate type for&!", Arg2);
8660 if Ekind (E) = E_Enumeration_Literal then
8661 Error_Pragma ("enumeration literal not allowed for pragma%");
8664 -- Check for rep item appearing too early or too late
8666 if Etype (E) = Any_Type
8667 or else Rep_Item_Too_Early (E, N)
8671 elsif Present (Underlying_Type (E)) then
8672 E := Underlying_Type (E);
8675 if Rep_Item_Too_Late (E, N) then
8679 if Has_Convention_Pragma (E) then
8680 Diagnose_Multiple_Pragmas (E);
8682 elsif Convention (E) = Convention_Protected
8683 or else Ekind (Scope (E)) = E_Protected_Type
8686 ("a protected operation cannot be given a different convention",
8690 -- For Intrinsic, a subprogram is required
8692 if C = Convention_Intrinsic
8693 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8695 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8697 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8698 if From_Aspect_Specification (N) then
8700 ("entity for aspect% must be a subprogram", Arg2);
8703 ("second argument of pragma% must be a subprogram", Arg2);
8707 -- Special checks for C_Variadic_n
8709 elsif C in Convention_C_Variadic then
8711 -- Several allowed cases
8713 if Is_Subprogram_Or_Generic_Subprogram (E) then
8716 -- An access to subprogram is also allowed
8718 elsif Is_Access_Type (E)
8719 and then Ekind (Designated_Type (E)) = E_Subprogram_Type
8721 Subp := Designated_Type (E);
8723 -- Allow internal call to set convention of subprogram type
8725 elsif Ekind (E) = E_Subprogram_Type then
8730 ("argument of pragma% must be subprogram or access type",
8734 -- ISO C requires a named parameter before the ellipsis, so a
8735 -- variadic C function taking 0 fixed parameter cannot exist.
8737 if C = Convention_C_Variadic_0 then
8740 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8741 Get_Pragma_Arg (Arg2));
8743 -- Now check the number of parameters of the subprogram and give
8744 -- an error if it is lower than n.
8746 elsif Present (Subp) then
8748 Minimum : constant Nat :=
8749 Convention_Id'Pos (C) -
8750 Convention_Id'Pos (Convention_C_Variadic_0);
8757 Formal := First_Formal (Subp);
8758 while Present (Formal) loop
8760 Next_Formal (Formal);
8763 if Count < Minimum then
8764 Error_Msg_Uint_1 := UI_From_Int (Minimum);
8766 ("argument of pragma% must have at least"
8767 & "^ parameters", Arg2);
8772 -- Special checks for Stdcall
8774 elsif C = Convention_Stdcall then
8776 -- Several allowed cases
8778 if Is_Subprogram_Or_Generic_Subprogram (E)
8782 or else Ekind (E) = E_Variable
8784 -- A component as well. The entity does not have its Ekind
8785 -- set until the enclosing record declaration is fully
8788 or else Nkind (Parent (E)) = N_Component_Declaration
8790 -- An access to subprogram is also allowed
8794 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8796 -- Allow internal call to set convention of subprogram type
8798 or else Ekind (E) = E_Subprogram_Type
8804 ("argument of pragma% must be subprogram or access type",
8809 Set_Convention_From_Pragma (E);
8811 -- Deal with non-subprogram cases
8813 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8816 -- The pragma must apply to a first subtype, but it can also
8817 -- apply to a generic type in a generic formal part, in which
8818 -- case it will also appear in the corresponding instance.
8820 if Is_Generic_Type (E) or else In_Instance then
8823 Check_First_Subtype (Arg2);
8826 Set_Convention_From_Pragma (Base_Type (E));
8828 -- For access subprograms, we must set the convention on the
8829 -- internally generated directly designated type as well.
8831 if Ekind (E) = E_Access_Subprogram_Type then
8832 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8836 -- For the subprogram case, set proper convention for all homonyms
8837 -- in same scope and the same declarative part, i.e. the same
8838 -- compilation unit.
8841 -- Treat a pragma Import as an implicit body, and pragma import
8842 -- as implicit reference (for navigation in GNAT Studio).
8844 if Prag_Id = Pragma_Import then
8845 Generate_Reference (E, Id, 'b');
8847 -- For exported entities we restrict the generation of references
8848 -- to entities exported to foreign languages since entities
8849 -- exported to Ada do not provide further information to
8850 -- GNAT Studio and add undesired references to the output of the
8853 elsif Prag_Id = Pragma_Export
8854 and then Convention (E) /= Convention_Ada
8856 Generate_Reference (E, Id, 'i');
8859 -- If the pragma comes from an aspect, it only applies to the
8860 -- given entity, not its homonyms.
8862 if From_Aspect_Specification (N) then
8863 if C = Convention_Intrinsic
8864 and then Nkind (Ent) = N_Defining_Operator_Symbol
8866 if Is_Fixed_Point_Type (Etype (Ent))
8867 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8868 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8871 ("no intrinsic operator available for this fixed-point "
8874 ("\use expression functions with the desired "
8875 & "conversions made explicit", N);
8882 -- Otherwise Loop through the homonyms of the pragma argument's
8883 -- entity, an apply convention to those in the current scope.
8885 Comp_Unit := Get_Source_Unit (E);
8890 exit when No (E1) or else Scope (E1) /= Current_Scope;
8892 -- Ignore entry for which convention is already set
8894 if Has_Convention_Pragma (E1) then
8898 if Is_Subprogram (E1)
8899 and then Nkind (Parent (Declaration_Node (E1))) =
8901 and then not Relaxed_RM_Semantics
8903 Set_Has_Completion (E); -- to prevent cascaded error
8905 ("pragma% requires separate spec and must come before "
8909 -- Do not set the pragma on inherited operations or on formal
8912 if Comes_From_Source (E1)
8913 and then Comp_Unit = Get_Source_Unit (E1)
8914 and then not Is_Formal_Subprogram (E1)
8915 and then Nkind (Original_Node (Parent (E1))) /=
8916 N_Full_Type_Declaration
8918 if Present (Alias (E1))
8919 and then Scope (E1) /= Scope (Alias (E1))
8922 ("cannot apply pragma% to non-local entity& declared#",
8926 Set_Convention_From_Pragma (E1);
8928 if Prag_Id = Pragma_Import then
8929 Generate_Reference (E1, Id, 'b');
8937 end Process_Convention;
8939 ----------------------------------------
8940 -- Process_Disable_Enable_Atomic_Sync --
8941 ----------------------------------------
8943 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8945 Check_No_Identifiers;
8946 Check_At_Most_N_Arguments (1);
8948 -- Modeled internally as
8949 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8954 Pragma_Argument_Associations => New_List (
8955 Make_Pragma_Argument_Association (Loc,
8957 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8959 if Present (Arg1) then
8960 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8964 end Process_Disable_Enable_Atomic_Sync;
8966 -------------------------------------------------
8967 -- Process_Extended_Import_Export_Internal_Arg --
8968 -------------------------------------------------
8970 procedure Process_Extended_Import_Export_Internal_Arg
8971 (Arg_Internal : Node_Id := Empty)
8974 if No (Arg_Internal) then
8975 Error_Pragma ("Internal parameter required for pragma%");
8978 if Nkind (Arg_Internal) = N_Identifier then
8981 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8982 and then (Prag_Id = Pragma_Import_Function
8984 Prag_Id = Pragma_Export_Function)
8990 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8993 Check_Arg_Is_Local_Name (Arg_Internal);
8994 end Process_Extended_Import_Export_Internal_Arg;
8996 --------------------------------------------------
8997 -- Process_Extended_Import_Export_Object_Pragma --
8998 --------------------------------------------------
9000 procedure Process_Extended_Import_Export_Object_Pragma
9001 (Arg_Internal : Node_Id;
9002 Arg_External : Node_Id;
9008 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
9009 Def_Id := Entity (Arg_Internal);
9011 if Ekind (Def_Id) not in E_Constant | E_Variable then
9013 ("pragma% must designate an object", Arg_Internal);
9016 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
9018 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
9021 ("previous Common/Psect_Object applies, pragma % not permitted",
9025 if Rep_Item_Too_Late (Def_Id, N) then
9029 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
9031 if Present (Arg_Size) then
9032 Check_Arg_Is_External_Name (Arg_Size);
9035 -- Export_Object case
9037 if Prag_Id = Pragma_Export_Object then
9038 if not Is_Library_Level_Entity (Def_Id) then
9040 ("argument for pragma% must be library level entity",
9044 if Ekind (Current_Scope) = E_Generic_Package then
9045 Error_Pragma ("pragma& cannot appear in a generic unit");
9048 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
9050 ("exported object must have compile time known size",
9054 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
9055 Error_Msg_N ("??duplicate Export_Object pragma", N);
9057 Set_Exported (Def_Id, Arg_Internal);
9060 -- Import_Object case
9063 if Is_Concurrent_Type (Etype (Def_Id)) then
9065 ("cannot use pragma% for task/protected object",
9069 if Ekind (Def_Id) = E_Constant then
9071 ("cannot import a constant", Arg_Internal);
9074 if Warn_On_Export_Import
9075 and then Has_Discriminants (Etype (Def_Id))
9078 ("imported value must be initialized??", Arg_Internal);
9081 if Warn_On_Export_Import
9082 and then Is_Access_Type (Etype (Def_Id))
9085 ("cannot import object of an access type??", Arg_Internal);
9088 if Warn_On_Export_Import
9089 and then Is_Imported (Def_Id)
9091 Error_Msg_N ("??duplicate Import_Object pragma", N);
9093 -- Check for explicit initialization present. Note that an
9094 -- initialization generated by the code generator, e.g. for an
9095 -- access type, does not count here.
9097 elsif Present (Expression (Parent (Def_Id)))
9100 (Original_Node (Expression (Parent (Def_Id))))
9102 Error_Msg_Sloc := Sloc (Def_Id);
9104 ("imported entities cannot be initialized (RM B.1(24))",
9105 "\no initialization allowed for & declared#", Arg1);
9107 Set_Imported (Def_Id);
9108 Note_Possible_Modification (Arg_Internal, Sure => False);
9111 end Process_Extended_Import_Export_Object_Pragma;
9113 ------------------------------------------------------
9114 -- Process_Extended_Import_Export_Subprogram_Pragma --
9115 ------------------------------------------------------
9117 procedure Process_Extended_Import_Export_Subprogram_Pragma
9118 (Arg_Internal : Node_Id;
9119 Arg_External : Node_Id;
9120 Arg_Parameter_Types : Node_Id;
9121 Arg_Result_Type : Node_Id := Empty;
9122 Arg_Mechanism : Node_Id;
9123 Arg_Result_Mechanism : Node_Id := Empty)
9129 Ambiguous : Boolean;
9132 function Same_Base_Type
9134 Formal : Entity_Id) return Boolean;
9135 -- Determines if Ptype references the type of Formal. Note that only
9136 -- the base types need to match according to the spec. Ptype here is
9137 -- the argument from the pragma, which is either a type name, or an
9138 -- access attribute.
9140 --------------------
9141 -- Same_Base_Type --
9142 --------------------
9144 function Same_Base_Type
9146 Formal : Entity_Id) return Boolean
9148 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
9152 -- Case where pragma argument is typ'Access
9154 if Nkind (Ptype) = N_Attribute_Reference
9155 and then Attribute_Name (Ptype) = Name_Access
9157 Pref := Prefix (Ptype);
9160 if not Is_Entity_Name (Pref)
9161 or else Entity (Pref) = Any_Type
9166 -- We have a match if the corresponding argument is of an
9167 -- anonymous access type, and its designated type matches the
9168 -- type of the prefix of the access attribute
9170 return Ekind (Ftyp) = E_Anonymous_Access_Type
9171 and then Base_Type (Entity (Pref)) =
9172 Base_Type (Etype (Designated_Type (Ftyp)));
9174 -- Case where pragma argument is a type name
9179 if not Is_Entity_Name (Ptype)
9180 or else Entity (Ptype) = Any_Type
9185 -- We have a match if the corresponding argument is of the type
9186 -- given in the pragma (comparing base types)
9188 return Base_Type (Entity (Ptype)) = Ftyp;
9192 -- Start of processing for
9193 -- Process_Extended_Import_Export_Subprogram_Pragma
9196 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
9200 -- Loop through homonyms (overloadings) of the entity
9202 Hom_Id := Entity (Arg_Internal);
9203 while Present (Hom_Id) loop
9204 Def_Id := Get_Base_Subprogram (Hom_Id);
9206 -- We need a subprogram in the current scope
9208 if not Is_Subprogram (Def_Id)
9209 or else Scope (Def_Id) /= Current_Scope
9216 -- Pragma cannot apply to subprogram body
9218 if Is_Subprogram (Def_Id)
9219 and then Nkind (Parent (Declaration_Node (Def_Id))) =
9223 ("pragma% requires separate spec and must come before "
9227 -- Test result type if given, note that the result type
9228 -- parameter can only be present for the function cases.
9230 if Present (Arg_Result_Type)
9231 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
9235 elsif Etype (Def_Id) /= Standard_Void_Type
9237 Pname in Name_Export_Procedure | Name_Import_Procedure
9241 -- Test parameter types if given. Note that this parameter has
9242 -- not been analyzed (and must not be, since it is semantic
9243 -- nonsense), so we get it as the parser left it.
9245 elsif Present (Arg_Parameter_Types) then
9246 Check_Matching_Types : declare
9251 Formal := First_Formal (Def_Id);
9253 if Nkind (Arg_Parameter_Types) = N_Null then
9254 if Present (Formal) then
9258 -- A list of one type, e.g. (List) is parsed as a
9259 -- parenthesized expression.
9261 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
9262 and then Paren_Count (Arg_Parameter_Types) = 1
9265 or else Present (Next_Formal (Formal))
9270 Same_Base_Type (Arg_Parameter_Types, Formal);
9273 -- A list of more than one type is parsed as a aggregate
9275 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
9276 and then Paren_Count (Arg_Parameter_Types) = 0
9278 Ptype := First (Expressions (Arg_Parameter_Types));
9279 while Present (Ptype) or else Present (Formal) loop
9282 or else not Same_Base_Type (Ptype, Formal)
9287 Next_Formal (Formal);
9292 -- Anything else is of the wrong form
9296 ("wrong form for Parameter_Types parameter",
9297 Arg_Parameter_Types);
9299 end Check_Matching_Types;
9302 -- Match is now False if the entry we found did not match
9303 -- either a supplied Parameter_Types or Result_Types argument
9309 -- Ambiguous case, the flag Ambiguous shows if we already
9310 -- detected this and output the initial messages.
9313 if not Ambiguous then
9315 Error_Msg_Name_1 := Pname;
9317 ("pragma% does not uniquely identify subprogram!",
9319 Error_Msg_Sloc := Sloc (Ent);
9320 Error_Msg_N ("matching subprogram #!", N);
9324 Error_Msg_Sloc := Sloc (Def_Id);
9325 Error_Msg_N ("matching subprogram #!", N);
9330 Hom_Id := Homonym (Hom_Id);
9333 -- See if we found an entry
9336 if not Ambiguous then
9337 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
9339 ("pragma% cannot be given for generic subprogram");
9342 ("pragma% does not identify local subprogram");
9349 -- Import pragmas must be for imported entities
9351 if Prag_Id = Pragma_Import_Function
9353 Prag_Id = Pragma_Import_Procedure
9355 Prag_Id = Pragma_Import_Valued_Procedure
9357 if not Is_Imported (Ent) then
9359 ("pragma Import or Interface must precede pragma%");
9362 -- Here we have the Export case which can set the entity as exported
9364 -- But does not do so if the specified external name is null, since
9365 -- that is taken as a signal in DEC Ada 83 (with which we want to be
9366 -- compatible) to request no external name.
9368 elsif Nkind (Arg_External) = N_String_Literal
9369 and then String_Length (Strval (Arg_External)) = 0
9373 -- In all other cases, set entity as exported
9376 Set_Exported (Ent, Arg_Internal);
9379 -- Special processing for Valued_Procedure cases
9381 if Prag_Id = Pragma_Import_Valued_Procedure
9383 Prag_Id = Pragma_Export_Valued_Procedure
9385 Formal := First_Formal (Ent);
9388 Error_Pragma ("at least one parameter required for pragma%");
9390 elsif Ekind (Formal) /= E_Out_Parameter then
9391 Error_Pragma ("first parameter must have mode OUT for pragma%");
9394 Set_Is_Valued_Procedure (Ent);
9398 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
9400 -- Process Result_Mechanism argument if present. We have already
9401 -- checked that this is only allowed for the function case.
9403 if Present (Arg_Result_Mechanism) then
9404 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
9407 -- Process Mechanism parameter if present. Note that this parameter
9408 -- is not analyzed, and must not be analyzed since it is semantic
9409 -- nonsense, so we get it in exactly as the parser left it.
9411 if Present (Arg_Mechanism) then
9419 -- A single mechanism association without a formal parameter
9420 -- name is parsed as a parenthesized expression. All other
9421 -- cases are parsed as aggregates, so we rewrite the single
9422 -- parameter case as an aggregate for consistency.
9424 if Nkind (Arg_Mechanism) /= N_Aggregate
9425 and then Paren_Count (Arg_Mechanism) = 1
9427 Rewrite (Arg_Mechanism,
9428 Make_Aggregate (Sloc (Arg_Mechanism),
9429 Expressions => New_List (
9430 Relocate_Node (Arg_Mechanism))));
9433 -- Case of only mechanism name given, applies to all formals
9435 if Nkind (Arg_Mechanism) /= N_Aggregate then
9436 Formal := First_Formal (Ent);
9437 while Present (Formal) loop
9438 Set_Mechanism_Value (Formal, Arg_Mechanism);
9439 Next_Formal (Formal);
9442 -- Case of list of mechanism associations given
9445 if Null_Record_Present (Arg_Mechanism) then
9447 ("inappropriate form for Mechanism parameter",
9451 -- Deal with positional ones first
9453 Formal := First_Formal (Ent);
9455 if Present (Expressions (Arg_Mechanism)) then
9456 Mname := First (Expressions (Arg_Mechanism));
9457 while Present (Mname) loop
9460 ("too many mechanism associations", Mname);
9463 Set_Mechanism_Value (Formal, Mname);
9464 Next_Formal (Formal);
9469 -- Deal with named entries
9471 if Present (Component_Associations (Arg_Mechanism)) then
9472 Massoc := First (Component_Associations (Arg_Mechanism));
9473 while Present (Massoc) loop
9474 Choice := First (Choices (Massoc));
9476 if Nkind (Choice) /= N_Identifier
9477 or else Present (Next (Choice))
9480 ("incorrect form for mechanism association",
9484 Formal := First_Formal (Ent);
9488 ("parameter name & not present", Choice);
9491 if Chars (Choice) = Chars (Formal) then
9493 (Formal, Expression (Massoc));
9495 -- Set entity on identifier for proper tree
9498 Set_Entity (Choice, Formal);
9503 Next_Formal (Formal);
9512 end Process_Extended_Import_Export_Subprogram_Pragma;
9514 --------------------------
9515 -- Process_Generic_List --
9516 --------------------------
9518 procedure Process_Generic_List is
9523 Check_No_Identifiers;
9524 Check_At_Least_N_Arguments (1);
9526 -- Check all arguments are names of generic units or instances
9529 while Present (Arg) loop
9530 Exp := Get_Pragma_Arg (Arg);
9533 if not Is_Entity_Name (Exp)
9535 (not Is_Generic_Instance (Entity (Exp))
9537 not Is_Generic_Unit (Entity (Exp)))
9540 ("pragma% argument must be name of generic unit/instance",
9546 end Process_Generic_List;
9548 ------------------------------------
9549 -- Process_Import_Predefined_Type --
9550 ------------------------------------
9552 procedure Process_Import_Predefined_Type is
9553 Loc : constant Source_Ptr := Sloc (N);
9555 Ftyp : Node_Id := Empty;
9561 Nam := String_To_Name (Strval (Expression (Arg3)));
9563 Elmt := First_Elmt (Predefined_Float_Types);
9564 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9568 Ftyp := Node (Elmt);
9570 if Present (Ftyp) then
9572 -- Don't build a derived type declaration, because predefined C
9573 -- types have no declaration anywhere, so cannot really be named.
9574 -- Instead build a full type declaration, starting with an
9575 -- appropriate type definition is built
9577 if Is_Floating_Point_Type (Ftyp) then
9578 Def := Make_Floating_Point_Definition (Loc,
9579 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9580 Make_Real_Range_Specification (Loc,
9581 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9582 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9584 -- Should never have a predefined type we cannot handle
9587 raise Program_Error;
9590 -- Build and insert a Full_Type_Declaration, which will be
9591 -- analyzed as soon as this list entry has been analyzed.
9593 Decl := Make_Full_Type_Declaration (Loc,
9594 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9595 Type_Definition => Def);
9597 Insert_After (N, Decl);
9598 Mark_Rewrite_Insertion (Decl);
9601 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9603 end Process_Import_Predefined_Type;
9605 ---------------------------------
9606 -- Process_Import_Or_Interface --
9607 ---------------------------------
9609 procedure Process_Import_Or_Interface is
9615 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9616 -- pragma Import (Entity, "external name");
9618 if Relaxed_RM_Semantics
9619 and then Arg_Count = 2
9620 and then Prag_Id = Pragma_Import
9621 and then Nkind (Expression (Arg2)) = N_String_Literal
9624 Def_Id := Get_Pragma_Arg (Arg1);
9627 if not Is_Entity_Name (Def_Id) then
9628 Error_Pragma_Arg ("entity name required", Arg1);
9631 Def_Id := Entity (Def_Id);
9632 Kill_Size_Check_Code (Def_Id);
9633 if Ekind (Def_Id) /= E_Constant then
9634 Note_Possible_Modification
9635 (Get_Pragma_Arg (Arg1), Sure => False);
9639 Process_Convention (C, Def_Id);
9641 -- A pragma that applies to a Ghost entity becomes Ghost for the
9642 -- purposes of legality checks and removal of ignored Ghost code.
9644 Mark_Ghost_Pragma (N, Def_Id);
9645 Kill_Size_Check_Code (Def_Id);
9646 if Ekind (Def_Id) /= E_Constant then
9647 Note_Possible_Modification
9648 (Get_Pragma_Arg (Arg2), Sure => False);
9652 -- Various error checks
9654 if Ekind (Def_Id) in E_Variable | E_Constant then
9656 -- We do not permit Import to apply to a renaming declaration
9658 if Present (Renamed_Object (Def_Id)) then
9660 ("pragma% not allowed for object renaming", Arg2);
9662 -- User initialization is not allowed for imported object, but
9663 -- the object declaration may contain a default initialization,
9664 -- that will be discarded. Note that an explicit initialization
9665 -- only counts if it comes from source, otherwise it is simply
9666 -- the code generator making an implicit initialization explicit.
9668 elsif Present (Expression (Parent (Def_Id)))
9669 and then Comes_From_Source
9670 (Original_Node (Expression (Parent (Def_Id))))
9672 -- Set imported flag to prevent cascaded errors
9674 Set_Is_Imported (Def_Id);
9676 Error_Msg_Sloc := Sloc (Def_Id);
9678 ("no initialization allowed for declaration of& #",
9679 "\imported entities cannot be initialized (RM B.1(24))",
9683 -- If the pragma comes from an aspect specification the
9684 -- Is_Imported flag has already been set.
9686 if not From_Aspect_Specification (N) then
9687 Set_Imported (Def_Id);
9690 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9692 -- Note that we do not set Is_Public here. That's because we
9693 -- only want to set it if there is no address clause, and we
9694 -- don't know that yet, so we delay that processing till
9697 -- pragma Import completes deferred constants
9699 if Ekind (Def_Id) = E_Constant then
9700 Set_Has_Completion (Def_Id);
9703 -- It is not possible to import a constant of an unconstrained
9704 -- array type (e.g. string) because there is no simple way to
9705 -- write a meaningful subtype for it.
9707 if Is_Array_Type (Etype (Def_Id))
9708 and then not Is_Constrained (Etype (Def_Id))
9711 ("imported constant& must have a constrained subtype",
9716 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9718 -- If the name is overloaded, pragma applies to all of the denoted
9719 -- entities in the same declarative part, unless the pragma comes
9720 -- from an aspect specification or was generated by the compiler
9721 -- (such as for pragma Provide_Shift_Operators).
9724 while Present (Hom_Id) loop
9726 Def_Id := Get_Base_Subprogram (Hom_Id);
9728 -- Ignore inherited subprograms because the pragma will apply
9729 -- to the parent operation, which is the one called.
9731 if Is_Overloadable (Def_Id)
9732 and then Present (Alias (Def_Id))
9736 -- If it is not a subprogram, it must be in an outer scope and
9737 -- pragma does not apply.
9739 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9742 -- The pragma does not apply to primitives of interfaces
9744 elsif Is_Dispatching_Operation (Def_Id)
9745 and then Present (Find_Dispatching_Type (Def_Id))
9746 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9750 -- Verify that the homonym is in the same declarative part (not
9751 -- just the same scope). If the pragma comes from an aspect
9752 -- specification we know that it is part of the declaration.
9754 elsif (No (Unit_Declaration_Node (Def_Id))
9755 or else Parent (Unit_Declaration_Node (Def_Id)) /=
9757 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9758 and then not From_Aspect_Specification (N)
9763 -- If the pragma comes from an aspect specification the
9764 -- Is_Imported flag has already been set.
9766 if not From_Aspect_Specification (N) then
9767 Set_Imported (Def_Id);
9770 -- Reject an Import applied to an abstract subprogram
9772 if Is_Subprogram (Def_Id)
9773 and then Is_Abstract_Subprogram (Def_Id)
9775 Error_Msg_Sloc := Sloc (Def_Id);
9777 ("cannot import abstract subprogram& declared#",
9781 -- Special processing for Convention_Intrinsic
9783 if C = Convention_Intrinsic then
9785 -- Link_Name argument not allowed for intrinsic
9789 Set_Is_Intrinsic_Subprogram (Def_Id);
9791 -- If no external name is present, then check that this
9792 -- is a valid intrinsic subprogram. If an external name
9793 -- is present, then this is handled by the back end.
9796 Check_Intrinsic_Subprogram
9797 (Def_Id, Get_Pragma_Arg (Arg2));
9801 -- Verify that the subprogram does not have a completion
9802 -- through a renaming declaration. For other completions the
9803 -- pragma appears as a too late representation.
9806 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9810 and then Nkind (Decl) = N_Subprogram_Declaration
9811 and then Present (Corresponding_Body (Decl))
9812 and then Nkind (Unit_Declaration_Node
9813 (Corresponding_Body (Decl))) =
9814 N_Subprogram_Renaming_Declaration
9816 Error_Msg_Sloc := Sloc (Def_Id);
9818 ("cannot import&, renaming already provided for "
9819 & "declaration #", N, Def_Id);
9823 -- If the pragma comes from an aspect specification, there
9824 -- must be an Import aspect specified as well. In the rare
9825 -- case where Import is set to False, the subprogram needs
9826 -- to have a local completion.
9829 Imp_Aspect : constant Node_Id :=
9830 Find_Aspect (Def_Id, Aspect_Import);
9834 if Present (Imp_Aspect)
9835 and then Present (Expression (Imp_Aspect))
9837 Expr := Expression (Imp_Aspect);
9838 Analyze_And_Resolve (Expr, Standard_Boolean);
9840 if Is_Entity_Name (Expr)
9841 and then Entity (Expr) = Standard_True
9843 Set_Has_Completion (Def_Id);
9846 -- If there is no expression, the default is True, as for
9847 -- all boolean aspects. Same for the older pragma.
9850 Set_Has_Completion (Def_Id);
9854 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9857 if Is_Compilation_Unit (Hom_Id) then
9859 -- Its possible homonyms are not affected by the pragma.
9860 -- Such homonyms might be present in the context of other
9861 -- units being compiled.
9865 elsif From_Aspect_Specification (N) then
9868 -- If the pragma was created by the compiler, then we don't
9869 -- want it to apply to other homonyms. This kind of case can
9870 -- occur when using pragma Provide_Shift_Operators, which
9871 -- generates implicit shift and rotate operators with Import
9872 -- pragmas that might apply to earlier explicit or implicit
9873 -- declarations marked with Import (for example, coming from
9874 -- an earlier pragma Provide_Shift_Operators for another type),
9875 -- and we don't generally want other homonyms being treated
9876 -- as imported or the pragma flagged as an illegal duplicate.
9878 elsif not Comes_From_Source (N) then
9882 Hom_Id := Homonym (Hom_Id);
9886 -- Import a CPP class
9888 elsif C = Convention_CPP
9889 and then (Is_Record_Type (Def_Id)
9890 or else Ekind (Def_Id) = E_Incomplete_Type)
9892 if Ekind (Def_Id) = E_Incomplete_Type then
9893 if Present (Full_View (Def_Id)) then
9894 Def_Id := Full_View (Def_Id);
9898 ("cannot import 'C'P'P type before full declaration seen",
9899 Get_Pragma_Arg (Arg2));
9901 -- Although we have reported the error we decorate it as
9902 -- CPP_Class to avoid reporting spurious errors
9904 Set_Is_CPP_Class (Def_Id);
9909 -- Types treated as CPP classes must be declared limited (note:
9910 -- this used to be a warning but there is no real benefit to it
9911 -- since we did effectively intend to treat the type as limited
9914 if not Is_Limited_Type (Def_Id) then
9916 ("imported 'C'P'P type must be limited",
9917 Get_Pragma_Arg (Arg2));
9920 if Etype (Def_Id) /= Def_Id
9921 and then not Is_CPP_Class (Root_Type (Def_Id))
9923 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9926 Set_Is_CPP_Class (Def_Id);
9928 -- Imported CPP types must not have discriminants (because C++
9929 -- classes do not have discriminants).
9931 if Has_Discriminants (Def_Id) then
9933 ("imported 'C'P'P type cannot have discriminants",
9934 First (Discriminant_Specifications
9935 (Declaration_Node (Def_Id))));
9938 -- Check that components of imported CPP types do not have default
9939 -- expressions. For private types this check is performed when the
9940 -- full view is analyzed (see Process_Full_View).
9942 if not Is_Private_Type (Def_Id) then
9943 Check_CPP_Type_Has_No_Defaults (Def_Id);
9946 -- Import a CPP exception
9948 elsif C = Convention_CPP
9949 and then Ekind (Def_Id) = E_Exception
9953 ("'External_'Name arguments is required for 'Cpp exception",
9956 -- As only a string is allowed, Check_Arg_Is_External_Name
9959 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9962 if Present (Arg4) then
9964 ("Link_Name argument not allowed for imported Cpp exception",
9968 -- Do not call Set_Interface_Name as the name of the exception
9969 -- shouldn't be modified (and in particular it shouldn't be
9970 -- the External_Name). For exceptions, the External_Name is the
9971 -- name of the RTTI structure.
9973 -- ??? Emit an error if pragma Import/Export_Exception is present
9975 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9977 Check_Arg_Count (3);
9978 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9980 Process_Import_Predefined_Type;
9982 -- Emit an error unless Relaxed_RM_Semantics since some legacy Ada
9983 -- compilers may accept more cases, e.g. JGNAT allowed importing
9986 elsif not Relaxed_RM_Semantics then
9987 if From_Aspect_Specification (N) then
9989 ("entity for aspect% must be object, subprogram "
9990 & "or incomplete type",
9994 ("second argument of pragma% must be object, subprogram "
9995 & "or incomplete type",
10000 -- If this pragma applies to a compilation unit, then the unit, which
10001 -- is a subprogram, does not require (or allow) a body. We also do
10002 -- not need to elaborate imported procedures.
10004 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
10006 Cunit : constant Node_Id := Parent (Parent (N));
10008 Set_Body_Required (Cunit, False);
10011 end Process_Import_Or_Interface;
10013 --------------------
10014 -- Process_Inline --
10015 --------------------
10017 procedure Process_Inline (Status : Inline_Status) is
10024 Ghost_Error_Posted : Boolean := False;
10025 -- Flag set when an error concerning the illegal mix of Ghost and
10026 -- non-Ghost subprograms is emitted.
10028 Ghost_Id : Entity_Id := Empty;
10029 -- The entity of the first Ghost subprogram encountered while
10030 -- processing the arguments of the pragma.
10032 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
10033 -- Verify the placement of pragma Inline_Always with respect to the
10034 -- initial declaration of subprogram Spec_Id.
10036 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
10037 -- Returns True if it can be determined at this stage that inlining
10038 -- is not possible, for example if the body is available and contains
10039 -- exception handlers, we prevent inlining, since otherwise we can
10040 -- get undefined symbols at link time. This function also emits a
10041 -- warning if the pragma appears too late.
10043 -- ??? is business with link symbols still valid, or does it relate
10044 -- to front end ZCX which is being phased out ???
10046 procedure Make_Inline (Subp : Entity_Id);
10047 -- Subp is the defining unit name of the subprogram declaration. If
10048 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
10049 -- the corresponding body, if there is one present.
10051 procedure Set_Inline_Flags (Subp : Entity_Id);
10052 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
10053 -- Also set or clear Is_Inlined flag on Subp depending on Status.
10055 -----------------------------------
10056 -- Check_Inline_Always_Placement --
10057 -----------------------------------
10059 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
10060 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
10062 function Compilation_Unit_OK return Boolean;
10063 pragma Inline (Compilation_Unit_OK);
10064 -- Determine whether pragma Inline_Always applies to a compatible
10065 -- compilation unit denoted by Spec_Id.
10067 function Declarative_List_OK return Boolean;
10068 pragma Inline (Declarative_List_OK);
10069 -- Determine whether the initial declaration of subprogram Spec_Id
10070 -- and the pragma appear in compatible declarative lists.
10072 function Subprogram_Body_OK return Boolean;
10073 pragma Inline (Subprogram_Body_OK);
10074 -- Determine whether pragma Inline_Always applies to a compatible
10075 -- subprogram body denoted by Spec_Id.
10077 -------------------------
10078 -- Compilation_Unit_OK --
10079 -------------------------
10081 function Compilation_Unit_OK return Boolean is
10082 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
10085 -- The pragma appears after the initial declaration of a
10086 -- compilation unit.
10088 -- procedure Comp_Unit;
10089 -- pragma Inline_Always (Comp_Unit);
10091 -- Note that for compatibility reasons, the following case is
10094 -- procedure Stand_Alone_Body_Comp_Unit is
10096 -- end Stand_Alone_Body_Comp_Unit;
10097 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
10100 Nkind (Comp_Unit) = N_Compilation_Unit
10101 and then Present (Aux_Decls_Node (Comp_Unit))
10102 and then Is_List_Member (N)
10103 and then List_Containing (N) =
10104 Pragmas_After (Aux_Decls_Node (Comp_Unit));
10105 end Compilation_Unit_OK;
10107 -------------------------
10108 -- Declarative_List_OK --
10109 -------------------------
10111 function Declarative_List_OK return Boolean is
10112 Context : constant Node_Id := Parent (Spec_Decl);
10114 Init_Decl : Node_Id;
10115 Init_List : List_Id;
10116 Prag_List : List_Id;
10119 -- Determine the proper initial declaration. In general this is
10120 -- the declaration node of the subprogram except when the input
10121 -- denotes a generic instantiation.
10123 -- procedure Inst is new Gen;
10124 -- pragma Inline_Always (Inst);
10126 -- In this case the original subprogram is moved inside an
10127 -- anonymous package while pragma Inline_Always remains at the
10128 -- level of the anonymous package. Use the declaration of the
10129 -- package because it reflects the placement of the original
10132 -- package Anon_Pack is
10133 -- procedure Inst is ... end Inst; -- original
10136 -- procedure Inst renames Anon_Pack.Inst;
10137 -- pragma Inline_Always (Inst);
10139 if Is_Generic_Instance (Spec_Id) then
10140 Init_Decl := Parent (Parent (Spec_Decl));
10141 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
10143 Init_Decl := Spec_Decl;
10146 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
10147 Init_List := List_Containing (Init_Decl);
10148 Prag_List := List_Containing (N);
10150 -- The pragma and then initial declaration appear within the
10151 -- same declarative list.
10153 if Init_List = Prag_List then
10156 -- A special case of the above is when both the pragma and
10157 -- the initial declaration appear in different lists of a
10158 -- package spec, protected definition, or a task definition.
10163 -- pragma Inline_Always (Proc);
10166 elsif Nkind (Context) in N_Package_Specification
10167 | N_Protected_Definition
10168 | N_Task_Definition
10169 and then Init_List = Visible_Declarations (Context)
10170 and then Prag_List = Private_Declarations (Context)
10177 end Declarative_List_OK;
10179 ------------------------
10180 -- Subprogram_Body_OK --
10181 ------------------------
10183 function Subprogram_Body_OK return Boolean is
10184 Body_Decl : Node_Id;
10187 -- The pragma appears within the declarative list of a stand-
10188 -- alone subprogram body.
10190 -- procedure Stand_Alone_Body is
10191 -- pragma Inline_Always (Stand_Alone_Body);
10194 -- end Stand_Alone_Body;
10196 -- The compiler creates a dummy spec in this case, however the
10197 -- pragma remains within the declarative list of the body.
10199 if Nkind (Spec_Decl) = N_Subprogram_Declaration
10200 and then not Comes_From_Source (Spec_Decl)
10201 and then Present (Corresponding_Body (Spec_Decl))
10204 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
10206 if Present (Declarations (Body_Decl))
10207 and then Is_List_Member (N)
10208 and then List_Containing (N) = Declarations (Body_Decl)
10215 end Subprogram_Body_OK;
10217 -- Start of processing for Check_Inline_Always_Placement
10220 -- This check is relevant only for pragma Inline_Always
10222 if Pname /= Name_Inline_Always then
10225 -- Nothing to do when the pragma is internally generated on the
10226 -- assumption that it is properly placed.
10228 elsif not Comes_From_Source (N) then
10231 -- Nothing to do for internally generated subprograms that act
10232 -- as accidental homonyms of a source subprogram being inlined.
10234 elsif not Comes_From_Source (Spec_Id) then
10237 -- Nothing to do for generic formal subprograms that act as
10238 -- homonyms of another source subprogram being inlined.
10240 elsif Is_Formal_Subprogram (Spec_Id) then
10243 elsif Compilation_Unit_OK
10244 or else Declarative_List_OK
10245 or else Subprogram_Body_OK
10250 -- At this point it is known that the pragma applies to or appears
10251 -- within a completing body, a completing stub, or a subunit.
10253 Error_Msg_Name_1 := Pname;
10254 Error_Msg_Name_2 := Chars (Spec_Id);
10255 Error_Msg_Sloc := Sloc (Spec_Id);
10258 ("pragma % must appear on initial declaration of subprogram "
10259 & "% defined #", N);
10260 end Check_Inline_Always_Placement;
10262 ---------------------------
10263 -- Inlining_Not_Possible --
10264 ---------------------------
10266 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
10267 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
10271 if Nkind (Decl) = N_Subprogram_Body then
10272 Stats := Handled_Statement_Sequence (Decl);
10273 return Present (Exception_Handlers (Stats))
10274 or else Present (At_End_Proc (Stats));
10276 elsif Nkind (Decl) = N_Subprogram_Declaration
10277 and then Present (Corresponding_Body (Decl))
10279 if Analyzed (Corresponding_Body (Decl)) then
10280 Error_Msg_N ("pragma appears too late, ignored??", N);
10283 -- If the subprogram is a renaming as body, the body is just a
10284 -- call to the renamed subprogram, and inlining is trivially
10288 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
10289 N_Subprogram_Renaming_Declaration
10295 Handled_Statement_Sequence
10296 (Unit_Declaration_Node (Corresponding_Body (Decl)));
10299 Present (Exception_Handlers (Stats))
10300 or else Present (At_End_Proc (Stats));
10304 -- If body is not available, assume the best, the check is
10305 -- performed again when compiling enclosing package bodies.
10309 end Inlining_Not_Possible;
10315 procedure Make_Inline (Subp : Entity_Id) is
10316 Kind : constant Entity_Kind := Ekind (Subp);
10317 Inner_Subp : Entity_Id := Subp;
10320 -- Ignore if bad type, avoid cascaded error
10322 if Etype (Subp) = Any_Type then
10326 -- If inlining is not possible, for now do not treat as an error
10328 elsif Status /= Suppressed
10329 and then Front_End_Inlining
10330 and then Inlining_Not_Possible (Subp)
10335 -- Here we have a candidate for inlining, but we must exclude
10336 -- derived operations. Otherwise we would end up trying to inline
10337 -- a phantom declaration, and the result would be to drag in a
10338 -- body which has no direct inlining associated with it. That
10339 -- would not only be inefficient but would also result in the
10340 -- backend doing cross-unit inlining in cases where it was
10341 -- definitely inappropriate to do so.
10343 -- However, a simple Comes_From_Source test is insufficient, since
10344 -- we do want to allow inlining of generic instances which also do
10345 -- not come from source. We also need to recognize specs generated
10346 -- by the front-end for bodies that carry the pragma. Finally,
10347 -- predefined operators do not come from source but are not
10348 -- inlineable either.
10350 elsif Is_Generic_Instance (Subp)
10351 or else Parent_Kind (Parent (Subp)) = N_Subprogram_Declaration
10355 elsif not Comes_From_Source (Subp)
10356 and then Scope (Subp) /= Standard_Standard
10362 -- The referenced entity must either be the enclosing entity, or
10363 -- an entity declared within the current open scope.
10365 if Present (Scope (Subp))
10366 and then Scope (Subp) /= Current_Scope
10367 and then Subp /= Current_Scope
10370 ("argument of% must be entity in current scope", Assoc);
10373 -- Processing for procedure, operator or function. If subprogram
10374 -- is aliased (as for an instance) indicate that the renamed
10375 -- entity (if declared in the same unit) is inlined.
10376 -- If this is the anonymous subprogram created for a subprogram
10377 -- instance, the inlining applies to it directly. Otherwise we
10378 -- retrieve it as the alias of the visible subprogram instance.
10380 if Is_Subprogram (Subp) then
10382 -- Ensure that pragma Inline_Always is associated with the
10383 -- initial declaration of the subprogram.
10385 Check_Inline_Always_Placement (Subp);
10387 if Is_Wrapper_Package (Scope (Subp)) then
10388 Inner_Subp := Subp;
10390 Inner_Subp := Ultimate_Alias (Inner_Subp);
10393 if In_Same_Source_Unit (Subp, Inner_Subp) then
10394 Set_Inline_Flags (Inner_Subp);
10396 if Present (Parent (Inner_Subp)) then
10397 Decl := Parent (Parent (Inner_Subp));
10402 if Nkind (Decl) = N_Subprogram_Declaration
10403 and then Present (Corresponding_Body (Decl))
10405 Set_Inline_Flags (Corresponding_Body (Decl));
10407 elsif Is_Generic_Instance (Subp)
10408 and then Comes_From_Source (Subp)
10410 -- Indicate that the body needs to be created for
10411 -- inlining subsequent calls. The instantiation node
10412 -- follows the declaration of the wrapper package
10413 -- created for it. The subprogram that requires the
10414 -- body is the anonymous one in the wrapper package.
10416 if Scope (Subp) /= Standard_Standard
10418 Need_Subprogram_Instance_Body
10419 (Next (Unit_Declaration_Node
10420 (Scope (Alias (Subp)))), Subp)
10425 -- Inline is a program unit pragma (RM 10.1.5) and cannot
10426 -- appear in a formal part to apply to a formal subprogram.
10427 -- Do not apply check within an instance or a formal package
10428 -- the test will have been applied to the original generic.
10430 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
10431 and then In_Same_List (Decl, N)
10432 and then not In_Instance
10435 ("Inline cannot apply to a formal subprogram", N);
10441 -- For a generic subprogram set flag as well, for use at the point
10442 -- of instantiation, to determine whether the body should be
10445 elsif Is_Generic_Subprogram (Subp) then
10446 Set_Inline_Flags (Subp);
10449 -- Literals are by definition inlined
10451 elsif Kind = E_Enumeration_Literal then
10454 -- Anything else is an error
10458 ("expect subprogram name for pragma%", Assoc);
10462 ----------------------
10463 -- Set_Inline_Flags --
10464 ----------------------
10466 procedure Set_Inline_Flags (Subp : Entity_Id) is
10468 -- First set the Has_Pragma_XXX flags and issue the appropriate
10469 -- errors and warnings for suspicious combinations.
10471 if Prag_Id = Pragma_No_Inline then
10472 if Has_Pragma_Inline_Always (Subp) then
10474 ("Inline_Always and No_Inline are mutually exclusive", N);
10475 elsif Has_Pragma_Inline (Subp) then
10477 ("Inline and No_Inline both specified for& ??",
10478 N, Entity (Subp_Id));
10481 Set_Has_Pragma_No_Inline (Subp);
10483 if Prag_Id = Pragma_Inline_Always then
10484 if Has_Pragma_No_Inline (Subp) then
10486 ("Inline_Always and No_Inline are mutually exclusive",
10490 Set_Has_Pragma_Inline_Always (Subp);
10492 if Has_Pragma_No_Inline (Subp) then
10494 ("Inline and No_Inline both specified for& ??",
10495 N, Entity (Subp_Id));
10499 Set_Has_Pragma_Inline (Subp);
10502 -- Then adjust the Is_Inlined flag. It can never be set if the
10503 -- subprogram is subject to pragma No_Inline.
10507 Set_Is_Inlined (Subp, False);
10513 if not Has_Pragma_No_Inline (Subp) then
10514 Set_Is_Inlined (Subp, True);
10518 -- A pragma that applies to a Ghost entity becomes Ghost for the
10519 -- purposes of legality checks and removal of ignored Ghost code.
10521 Mark_Ghost_Pragma (N, Subp);
10523 -- Capture the entity of the first Ghost subprogram being
10524 -- processed for error detection purposes.
10526 if Is_Ghost_Entity (Subp) then
10527 if No (Ghost_Id) then
10531 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10532 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10534 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
10535 Ghost_Error_Posted := True;
10537 Error_Msg_Name_1 := Pname;
10539 ("pragma % cannot mention ghost and non-ghost subprograms",
10542 Error_Msg_Sloc := Sloc (Ghost_Id);
10543 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10545 Error_Msg_Sloc := Sloc (Subp);
10546 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10548 end Set_Inline_Flags;
10550 -- Start of processing for Process_Inline
10553 -- An inlined subprogram may grant access to its private enclosing
10554 -- context depending on the placement of its body. From elaboration
10555 -- point of view, the flow of execution may enter this private
10556 -- context, and then reach an external unit, thus producing a
10557 -- dependency on that external unit. For such a path to be properly
10558 -- discovered and encoded in the ALI file of the main unit, let the
10559 -- ABE mechanism process the body of the main unit, and encode all
10560 -- relevant invocation constructs and the relations between them.
10562 Mark_Save_Invocation_Graph_Of_Body;
10564 Check_No_Identifiers;
10565 Check_At_Least_N_Arguments (1);
10567 if Status = Enabled then
10568 Inline_Processing_Required := True;
10572 while Present (Assoc) loop
10573 Subp_Id := Get_Pragma_Arg (Assoc);
10577 if Is_Entity_Name (Subp_Id) then
10578 Subp := Entity (Subp_Id);
10580 if Subp = Any_Id then
10582 -- If previous error, avoid cascaded errors
10584 Check_Error_Detected;
10588 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10589 -- is given that directly specifies an aspect of an entity,
10590 -- then it is illegal to give another [...]
10591 -- aspect_specification that directly specifies the same
10592 -- aspect of the entity.
10593 -- We only check Subp directly as per "directly specifies"
10594 -- above and because the case of pragma Inline is really
10595 -- special given its pre aspect usage.
10597 Check_Duplicate_Pragma (Subp);
10598 Record_Rep_Item (Subp, N);
10600 Make_Inline (Subp);
10602 -- For the pragma case, climb homonym chain. This is
10603 -- what implements allowing the pragma in the renaming
10604 -- case, with the result applying to the ancestors, and
10605 -- also allows Inline to apply to all previous homonyms.
10607 if not From_Aspect_Specification (N) then
10608 while Present (Homonym (Subp))
10609 and then Scope (Homonym (Subp)) = Current_Scope
10611 Subp := Homonym (Subp);
10612 Make_Inline (Subp);
10618 if not Applies then
10619 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10625 -- If the context is a package declaration, the pragma indicates
10626 -- that inlining will require the presence of the corresponding
10627 -- body. (this may be further refined).
10630 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10631 N_Package_Declaration
10633 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10635 end Process_Inline;
10637 ----------------------------
10638 -- Process_Interface_Name --
10639 ----------------------------
10641 procedure Process_Interface_Name
10642 (Subprogram_Def : Entity_Id;
10644 Link_Arg : Node_Id;
10648 Link_Nam : Node_Id;
10649 String_Val : String_Id;
10651 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10652 -- SN is a string literal node for an interface name. This routine
10653 -- performs some minimal checks that the name is reasonable. In
10654 -- particular that no spaces or other obviously incorrect characters
10655 -- appear. This is only a warning, since any characters are allowed.
10657 ----------------------------------
10658 -- Check_Form_Of_Interface_Name --
10659 ----------------------------------
10661 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10662 S : constant String_Id := Strval (Expr_Value_S (SN));
10663 SL : constant Nat := String_Length (S);
10668 Error_Msg_N ("interface name cannot be null string", SN);
10671 for J in 1 .. SL loop
10672 C := Get_String_Char (S, J);
10674 -- Look for dubious character and issue unconditional warning.
10675 -- Definitely dubious if not in character range.
10677 if not In_Character_Range (C)
10679 -- Commas, spaces and (back)slashes are dubious
10681 or else Get_Character (C) = ','
10682 or else Get_Character (C) = '\'
10683 or else Get_Character (C) = ' '
10684 or else Get_Character (C) = '/'
10687 ("??interface name contains illegal character",
10688 Sloc (SN) + Source_Ptr (J));
10691 end Check_Form_Of_Interface_Name;
10693 -- Start of processing for Process_Interface_Name
10696 -- If we are looking at a pragma that comes from an aspect then it
10697 -- needs to have its corresponding aspect argument expressions
10698 -- analyzed in addition to the generated pragma so that aspects
10699 -- within generic units get properly resolved.
10701 if Present (Prag) and then From_Aspect_Specification (Prag) then
10703 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10711 -- Obtain all interfacing aspects used to construct the pragma
10713 Get_Interfacing_Aspects
10714 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10716 -- Analyze the expression of aspect External_Name
10718 if Present (EN) then
10719 Analyze (Expression (EN));
10722 -- Analyze the expressio of aspect Link_Name
10724 if Present (LN) then
10725 Analyze (Expression (LN));
10730 if No (Link_Arg) then
10731 if No (Ext_Arg) then
10734 elsif Chars (Ext_Arg) = Name_Link_Name then
10736 Link_Nam := Expression (Ext_Arg);
10739 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10740 Ext_Nam := Expression (Ext_Arg);
10745 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10746 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10747 Ext_Nam := Expression (Ext_Arg);
10748 Link_Nam := Expression (Link_Arg);
10751 -- Check expressions for external name and link name are static
10753 if Present (Ext_Nam) then
10754 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10755 Check_Form_Of_Interface_Name (Ext_Nam);
10757 -- Verify that external name is not the name of a local entity,
10758 -- which would hide the imported one and could lead to run-time
10759 -- surprises. The problem can only arise for entities declared in
10760 -- a package body (otherwise the external name is fully qualified
10761 -- and will not conflict).
10769 if Prag_Id = Pragma_Import then
10770 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10771 E := Entity_Id (Get_Name_Table_Int (Nam));
10773 if Nam /= Chars (Subprogram_Def)
10774 and then Present (E)
10775 and then not Is_Overloadable (E)
10776 and then Is_Immediately_Visible (E)
10777 and then not Is_Imported (E)
10778 and then Ekind (Scope (E)) = E_Package
10781 while Present (Par) loop
10782 if Nkind (Par) = N_Package_Body then
10783 Error_Msg_Sloc := Sloc (E);
10785 ("imported entity is hidden by & declared#",
10790 Par := Parent (Par);
10797 if Present (Link_Nam) then
10798 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10799 Check_Form_Of_Interface_Name (Link_Nam);
10802 -- If there is no link name, just set the external name
10804 if No (Link_Nam) then
10805 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10807 -- For the Link_Name case, the given literal is preceded by an
10808 -- asterisk, which indicates to GCC that the given name should be
10809 -- taken literally, and in particular that no prepending of
10810 -- underlines should occur, even in systems where this is the
10815 Store_String_Char (Get_Char_Code ('*'));
10816 String_Val := Strval (Expr_Value_S (Link_Nam));
10817 Store_String_Chars (String_Val);
10819 Make_String_Literal (Sloc (Link_Nam),
10820 Strval => End_String);
10823 -- Set the interface name. If the entity is a generic instance, use
10824 -- its alias, which is the callable entity.
10826 if Is_Generic_Instance (Subprogram_Def) then
10827 Set_Encoded_Interface_Name
10828 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10830 Set_Encoded_Interface_Name
10831 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10834 Check_Duplicated_Export_Name (Link_Nam);
10835 end Process_Interface_Name;
10837 -----------------------------------------
10838 -- Process_Interrupt_Or_Attach_Handler --
10839 -----------------------------------------
10841 procedure Process_Interrupt_Or_Attach_Handler is
10842 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10843 Prot_Typ : constant Entity_Id := Scope (Handler);
10846 -- A pragma that applies to a Ghost entity becomes Ghost for the
10847 -- purposes of legality checks and removal of ignored Ghost code.
10849 Mark_Ghost_Pragma (N, Handler);
10850 Set_Is_Interrupt_Handler (Handler);
10852 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10854 Record_Rep_Item (Prot_Typ, N);
10856 -- Chain the pragma on the contract for completeness
10858 Add_Contract_Item (N, Handler);
10859 end Process_Interrupt_Or_Attach_Handler;
10861 --------------------------------------------------
10862 -- Process_Restrictions_Or_Restriction_Warnings --
10863 --------------------------------------------------
10865 -- Note: some of the simple identifier cases were handled in par-prag,
10866 -- but it is harmless (and more straightforward) to simply handle all
10867 -- cases here, even if it means we repeat a bit of work in some cases.
10869 procedure Process_Restrictions_Or_Restriction_Warnings
10873 R_Id : Restriction_Id;
10878 procedure Process_No_Specification_of_Aspect;
10879 -- Process the No_Specification_of_Aspect restriction
10881 procedure Process_No_Use_Of_Attribute;
10882 -- Process the No_Use_Of_Attribute restriction
10884 ----------------------------------------
10885 -- Process_No_Specification_of_Aspect --
10886 ----------------------------------------
10888 procedure Process_No_Specification_of_Aspect is
10889 Name : constant Name_Id := Chars (Expr);
10891 if Nkind (Expr) = N_Identifier
10892 and then Is_Aspect_Id (Name)
10894 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10896 Bad_Aspect (Expr, Name, Warn => True);
10900 end Process_No_Specification_of_Aspect;
10902 ---------------------------------
10903 -- Process_No_Use_Of_Attribute --
10904 ---------------------------------
10906 procedure Process_No_Use_Of_Attribute is
10907 Name : constant Name_Id := Chars (Expr);
10909 if Nkind (Expr) = N_Identifier
10910 and then Is_Attribute_Name (Name)
10912 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10914 Bad_Attribute (Expr, Name, Warn => True);
10917 end Process_No_Use_Of_Attribute;
10919 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
10922 -- Ignore all Restrictions pragmas in CodePeer mode
10924 if CodePeer_Mode then
10928 Check_Ada_83_Warning;
10929 Check_At_Least_N_Arguments (1);
10930 Check_Valid_Configuration_Pragma;
10933 while Present (Arg) loop
10935 Expr := Get_Pragma_Arg (Arg);
10937 -- Case of no restriction identifier present
10939 if Id = No_Name then
10940 if Nkind (Expr) /= N_Identifier then
10942 ("invalid form for restriction", Arg);
10947 (Process_Restriction_Synonyms (Expr));
10949 if R_Id not in All_Boolean_Restrictions then
10950 Error_Msg_Name_1 := Pname;
10952 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10954 -- Check for possible misspelling
10956 for J in All_Restrictions loop
10958 Rnm : constant String := Restriction_Id'Image (J);
10961 Name_Buffer (1 .. Rnm'Length) := Rnm;
10962 Name_Len := Rnm'Length;
10963 Set_Casing (All_Lower_Case);
10965 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10968 (Source_Index (Current_Sem_Unit)));
10969 Error_Msg_String (1 .. Rnm'Length) :=
10970 Name_Buffer (1 .. Name_Len);
10971 Error_Msg_Strlen := Rnm'Length;
10972 Error_Msg_N -- CODEFIX
10973 ("\possible misspelling of ""~""",
10974 Get_Pragma_Arg (Arg));
10983 if Implementation_Restriction (R_Id) then
10984 Check_Restriction (No_Implementation_Restrictions, Arg);
10987 -- Special processing for No_Elaboration_Code restriction
10989 if R_Id = No_Elaboration_Code then
10991 -- Restriction is only recognized within a configuration
10992 -- pragma file, or within a unit of the main extended
10993 -- program. Note: the test for Main_Unit is needed to
10994 -- properly include the case of configuration pragma files.
10996 if not (Current_Sem_Unit = Main_Unit
10997 or else In_Extended_Main_Source_Unit (N))
11001 -- Don't allow in a subunit unless already specified in
11004 elsif Nkind (Parent (N)) = N_Compilation_Unit
11005 and then Nkind (Unit (Parent (N))) = N_Subunit
11006 and then not Restriction_Active (No_Elaboration_Code)
11009 ("invalid specification of ""No_Elaboration_Code""",
11012 ("\restriction cannot be specified in a subunit", N);
11014 ("\unless also specified in body or spec", N);
11017 -- If we accept a No_Elaboration_Code restriction, then it
11018 -- needs to be added to the configuration restriction set so
11019 -- that we get proper application to other units in the main
11020 -- extended source as required.
11023 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
11026 -- Special processing for No_Dynamic_Accessibility_Checks to
11027 -- disallow exclusive specification in a body or subunit.
11029 elsif R_Id = No_Dynamic_Accessibility_Checks
11030 -- Check if the restriction is within configuration pragma
11031 -- in a similar way to No_Elaboration_Code.
11033 and then not (Current_Sem_Unit = Main_Unit
11034 or else In_Extended_Main_Source_Unit (N))
11036 and then Nkind (Unit (Parent (N))) = N_Compilation_Unit
11038 and then (Nkind (Unit (Parent (N))) = N_Package_Body
11039 or else Nkind (Unit (Parent (N))) = N_Subunit)
11041 and then not Restriction_Active
11042 (No_Dynamic_Accessibility_Checks)
11045 ("invalid specification of " &
11046 """No_Dynamic_Accessibility_Checks""", N);
11048 if Nkind (Unit (Parent (N))) = N_Package_Body then
11050 ("\restriction cannot be specified in a package " &
11053 elsif Nkind (Unit (Parent (N))) = N_Subunit then
11055 ("\restriction cannot be specified in a subunit", N);
11059 ("\unless also specified in spec", N);
11061 -- Special processing for No_Tasking restriction (not just a
11062 -- warning) when it appears as a configuration pragma.
11064 elsif R_Id = No_Tasking
11065 and then No (Cunit (Main_Unit))
11068 Set_Global_No_Tasking;
11071 Set_Restriction (R_Id, N, Warn);
11073 if R_Id = No_Dynamic_CPU_Assignment
11074 or else R_Id = No_Tasks_Unassigned_To_CPU
11076 -- These imply No_Dependence =>
11077 -- "System.Multiprocessors.Dispatching_Domains".
11078 -- This is not strictly what the AI says, but it eliminates
11079 -- the need for run-time checks, which are undesirable in
11082 Set_Restriction_No_Dependence
11084 (Sel_Comp ("system", "multiprocessors", Loc),
11085 "dispatching_domains"),
11089 if R_Id = No_Tasks_Unassigned_To_CPU then
11090 -- Likewise, imply No_Dynamic_CPU_Assignment
11092 Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
11095 -- Check for obsolescent restrictions in Ada 2005 mode
11098 and then Ada_Version >= Ada_2005
11099 and then (R_Id = No_Asynchronous_Control
11101 R_Id = No_Unchecked_Deallocation
11103 R_Id = No_Unchecked_Conversion)
11105 Check_Restriction (No_Obsolescent_Features, N);
11108 -- A very special case that must be processed here: pragma
11109 -- Restrictions (No_Exceptions) turns off all run-time
11110 -- checking. This is a bit dubious in terms of the formal
11111 -- language definition, but it is what is intended by RM
11112 -- H.4(12). Restriction_Warnings never affects generated code
11113 -- so this is done only in the real restriction case.
11115 -- Atomic_Synchronization is not a real check, so it is not
11116 -- affected by this processing).
11118 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
11119 -- run-time checks in CodePeer and GNATprove modes: we want to
11120 -- generate checks for analysis purposes, as set respectively
11121 -- by -gnatC and -gnatd.F
11124 and then not (CodePeer_Mode or GNATprove_Mode)
11125 and then R_Id = No_Exceptions
11127 for J in Scope_Suppress.Suppress'Range loop
11128 if J /= Atomic_Synchronization then
11129 Scope_Suppress.Suppress (J) := True;
11134 -- Case of No_Dependence => unit-name. Note that the parser
11135 -- already made the necessary entry in the No_Dependence table.
11137 elsif Id = Name_No_Dependence then
11138 if not OK_No_Dependence_Unit_Name (Expr) then
11142 -- Case of No_Specification_Of_Aspect => aspect-identifier
11144 elsif Id = Name_No_Specification_Of_Aspect then
11145 Process_No_Specification_of_Aspect;
11147 -- Case of No_Use_Of_Attribute => attribute-identifier
11149 elsif Id = Name_No_Use_Of_Attribute then
11150 Process_No_Use_Of_Attribute;
11152 -- Case of No_Use_Of_Entity => fully-qualified-name
11154 elsif Id = Name_No_Use_Of_Entity then
11156 -- Restriction is only recognized within a configuration
11157 -- pragma file, or within a unit of the main extended
11158 -- program. Note: the test for Main_Unit is needed to
11159 -- properly include the case of configuration pragma files.
11161 if Current_Sem_Unit = Main_Unit
11162 or else In_Extended_Main_Source_Unit (N)
11164 if not OK_No_Dependence_Unit_Name (Expr) then
11165 Error_Msg_N ("wrong form for entity name", Expr);
11167 Set_Restriction_No_Use_Of_Entity
11168 (Expr, Warn, No_Profile);
11172 -- Case of No_Use_Of_Pragma => pragma-identifier
11174 elsif Id = Name_No_Use_Of_Pragma then
11175 if Nkind (Expr) /= N_Identifier
11176 or else not Is_Pragma_Name (Chars (Expr))
11178 Error_Msg_N ("unknown pragma name??", Expr);
11180 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
11183 -- All other cases of restriction identifier present
11186 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
11188 if R_Id not in All_Parameter_Restrictions then
11190 ("invalid restriction parameter identifier", Arg);
11193 Analyze_And_Resolve (Expr, Any_Integer);
11195 if not Is_OK_Static_Expression (Expr) then
11196 Flag_Non_Static_Expr
11197 ("value must be static expression!", Expr);
11200 elsif not Is_Integer_Type (Etype (Expr))
11201 or else Expr_Value (Expr) < 0
11204 ("value must be non-negative integer", Arg);
11207 -- Restriction pragma is active
11209 Val := Expr_Value (Expr);
11211 if not UI_Is_In_Int_Range (Val) then
11213 ("pragma ignored, value too large??", Arg);
11216 Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
11221 end Process_Restrictions_Or_Restriction_Warnings;
11223 ---------------------------------
11224 -- Process_Suppress_Unsuppress --
11225 ---------------------------------
11227 -- Note: this procedure makes entries in the check suppress data
11228 -- structures managed by Sem. See spec of package Sem for full
11229 -- details on how we handle recording of check suppression.
11231 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
11236 In_Package_Spec : constant Boolean :=
11237 Is_Package_Or_Generic_Package (Current_Scope)
11238 and then not In_Package_Body (Current_Scope);
11240 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
11241 -- Used to suppress a single check on the given entity
11243 --------------------------------
11244 -- Suppress_Unsuppress_Echeck --
11245 --------------------------------
11247 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
11249 -- Check for error of trying to set atomic synchronization for
11250 -- a non-atomic variable.
11252 if C = Atomic_Synchronization
11253 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
11256 ("pragma & requires atomic type or variable",
11257 Pragma_Identifier (Original_Node (N)));
11260 Set_Checks_May_Be_Suppressed (E);
11262 if In_Package_Spec then
11263 Push_Global_Suppress_Stack_Entry
11266 Suppress => Suppress_Case);
11268 Push_Local_Suppress_Stack_Entry
11271 Suppress => Suppress_Case);
11274 -- If this is a first subtype, and the base type is distinct,
11275 -- then also set the suppress flags on the base type.
11277 if Is_First_Subtype (E) and then Etype (E) /= E then
11278 Suppress_Unsuppress_Echeck (Etype (E), C);
11280 end Suppress_Unsuppress_Echeck;
11282 -- Start of processing for Process_Suppress_Unsuppress
11285 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
11286 -- on user code: we want to generate checks for analysis purposes, as
11287 -- set respectively by -gnatC and -gnatd.F
11289 if Comes_From_Source (N)
11290 and then (CodePeer_Mode or GNATprove_Mode)
11295 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
11296 -- declarative part or a package spec (RM 11.5(5)).
11298 if not Is_Configuration_Pragma then
11299 Check_Is_In_Decl_Part_Or_Package_Spec;
11302 Check_At_Least_N_Arguments (1);
11303 Check_At_Most_N_Arguments (2);
11304 Check_No_Identifier (Arg1);
11305 Check_Arg_Is_Identifier (Arg1);
11307 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
11309 if C = No_Check_Id then
11311 ("argument of pragma% is not valid check name", Arg1);
11314 -- Warn that suppress of Elaboration_Check has no effect in SPARK
11316 if C = Elaboration_Check
11317 and then Suppress_Case
11318 and then SPARK_Mode = On
11321 ("Suppress of Elaboration_Check ignored in SPARK??",
11322 "\elaboration checking rules are statically enforced "
11323 & "(SPARK RM 7.7)", Arg1);
11326 -- One-argument case
11328 if Arg_Count = 1 then
11330 -- Make an entry in the local scope suppress table. This is the
11331 -- table that directly shows the current value of the scope
11332 -- suppress check for any check id value.
11334 if C = All_Checks then
11336 -- For All_Checks, we set all specific predefined checks with
11337 -- the exception of Elaboration_Check, which is handled
11338 -- specially because of not wanting All_Checks to have the
11339 -- effect of deactivating static elaboration order processing.
11340 -- Atomic_Synchronization is also not affected, since this is
11341 -- not a real check.
11343 for J in Scope_Suppress.Suppress'Range loop
11344 if J /= Elaboration_Check
11346 J /= Atomic_Synchronization
11348 Scope_Suppress.Suppress (J) := Suppress_Case;
11352 -- If not All_Checks, and predefined check, then set appropriate
11353 -- scope entry. Note that we will set Elaboration_Check if this
11354 -- is explicitly specified. Atomic_Synchronization is allowed
11355 -- only if internally generated and entity is atomic.
11357 elsif C in Predefined_Check_Id
11358 and then (not Comes_From_Source (N)
11359 or else C /= Atomic_Synchronization)
11361 Scope_Suppress.Suppress (C) := Suppress_Case;
11364 -- Also push an entry in the local suppress stack
11366 Push_Local_Suppress_Stack_Entry
11369 Suppress => Suppress_Case);
11371 -- Case of two arguments present, where the check is suppressed for
11372 -- a specified entity (given as the second argument of the pragma)
11375 -- This is obsolescent in Ada 2005 mode
11377 if Ada_Version >= Ada_2005 then
11378 Check_Restriction (No_Obsolescent_Features, Arg2);
11381 Check_Optional_Identifier (Arg2, Name_On);
11382 E_Id := Get_Pragma_Arg (Arg2);
11385 if not Is_Entity_Name (E_Id) then
11387 ("second argument of pragma% must be entity name", Arg2);
11390 E := Entity (E_Id);
11396 -- A pragma that applies to a Ghost entity becomes Ghost for the
11397 -- purposes of legality checks and removal of ignored Ghost code.
11399 Mark_Ghost_Pragma (N, E);
11401 -- Enforce RM 11.5(7) which requires that for a pragma that
11402 -- appears within a package spec, the named entity must be
11403 -- within the package spec. We allow the package name itself
11404 -- to be mentioned since that makes sense, although it is not
11405 -- strictly allowed by 11.5(7).
11408 and then E /= Current_Scope
11409 and then Scope (E) /= Current_Scope
11412 ("entity in pragma% is not in package spec (RM 11.5(7))",
11416 -- Loop through homonyms. As noted below, in the case of a package
11417 -- spec, only homonyms within the package spec are considered.
11420 Suppress_Unsuppress_Echeck (E, C);
11422 if Is_Generic_Instance (E)
11423 and then Is_Subprogram (E)
11424 and then Present (Alias (E))
11426 Suppress_Unsuppress_Echeck (Alias (E), C);
11429 -- Move to next homonym if not aspect spec case
11431 exit when From_Aspect_Specification (N);
11435 -- If we are within a package specification, the pragma only
11436 -- applies to homonyms in the same scope.
11438 exit when In_Package_Spec
11439 and then Scope (E) /= Current_Scope;
11442 end Process_Suppress_Unsuppress;
11444 -------------------------------
11445 -- Record_Independence_Check --
11446 -------------------------------
11448 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
11449 pragma Unreferenced (N, E);
11451 -- For GCC back ends the validation is done a priori. This code is
11452 -- dead, but might be useful in the future.
11454 -- if not AAMP_On_Target then
11458 -- Independence_Checks.Append ((N, E));
11461 end Record_Independence_Check;
11467 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
11469 if Is_Imported (E) then
11471 ("cannot export entity& that was previously imported", Arg);
11473 elsif Present (Address_Clause (E))
11474 and then not Relaxed_RM_Semantics
11477 ("cannot export entity& that has an address clause", Arg);
11480 Set_Is_Exported (E);
11482 -- Generate a reference for entity explicitly, because the
11483 -- identifier may be overloaded and name resolution will not
11486 Generate_Reference (E, Arg);
11488 -- Deal with exporting non-library level entity
11490 if not Is_Library_Level_Entity (E) then
11492 -- Not allowed at all for subprograms
11494 if Is_Subprogram (E) then
11495 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
11497 -- Otherwise set public and statically allocated
11501 Set_Is_Statically_Allocated (E);
11503 -- Warn if the corresponding W flag is set
11505 if Warn_On_Export_Import
11507 -- Only do this for something that was in the source. Not
11508 -- clear if this can be False now (there used for sure to be
11509 -- cases on some systems where it was False), but anyway the
11510 -- test is harmless if not needed, so it is retained.
11512 and then Comes_From_Source (Arg)
11515 ("?x?& has been made static as a result of Export",
11518 ("\?x?this usage is non-standard and non-portable",
11524 if Warn_On_Export_Import and Inside_A_Generic then
11526 ("all instances of& will have the same external name?x?",
11531 ----------------------------------------------
11532 -- Set_Extended_Import_Export_External_Name --
11533 ----------------------------------------------
11535 procedure Set_Extended_Import_Export_External_Name
11536 (Internal_Ent : Entity_Id;
11537 Arg_External : Node_Id)
11539 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
11540 New_Name : Node_Id;
11543 if No (Arg_External) then
11547 Check_Arg_Is_External_Name (Arg_External);
11549 if Nkind (Arg_External) = N_String_Literal then
11550 if String_Length (Strval (Arg_External)) = 0 then
11553 New_Name := Adjust_External_Name_Case (Arg_External);
11556 elsif Nkind (Arg_External) = N_Identifier then
11557 New_Name := Get_Default_External_Name (Arg_External);
11559 -- Check_Arg_Is_External_Name should let through only identifiers and
11560 -- string literals or static string expressions (which are folded to
11561 -- string literals).
11564 raise Program_Error;
11567 -- If we already have an external name set (by a prior normal Import
11568 -- or Export pragma), then the external names must match
11570 if Present (Interface_Name (Internal_Ent)) then
11572 -- Ignore mismatching names in CodePeer mode, to support some
11573 -- old compilers which would export the same procedure under
11574 -- different names, e.g:
11576 -- pragma Export_Procedure (P, "a");
11577 -- pragma Export_Procedure (P, "b");
11579 if CodePeer_Mode then
11583 Check_Matching_Internal_Names : declare
11584 S1 : constant String_Id := Strval (Old_Name);
11585 S2 : constant String_Id := Strval (New_Name);
11587 procedure Mismatch;
11588 pragma No_Return (Mismatch);
11589 -- Called if names do not match
11595 procedure Mismatch is
11597 Error_Msg_Sloc := Sloc (Old_Name);
11599 ("external name does not match that given #",
11603 -- Start of processing for Check_Matching_Internal_Names
11606 if String_Length (S1) /= String_Length (S2) then
11610 for J in 1 .. String_Length (S1) loop
11611 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11616 end Check_Matching_Internal_Names;
11618 -- Otherwise set the given name
11621 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11622 Check_Duplicated_Export_Name (New_Name);
11624 end Set_Extended_Import_Export_External_Name;
11630 procedure Set_Imported (E : Entity_Id) is
11632 -- Error message if already imported or exported
11634 if Is_Exported (E) or else Is_Imported (E) then
11636 -- Error if being set Exported twice
11638 if Is_Exported (E) then
11639 Error_Msg_NE ("entity& was previously exported", N, E);
11641 -- Ignore error in CodePeer mode where we treat all imported
11642 -- subprograms as unknown.
11644 elsif CodePeer_Mode then
11647 -- OK if Import/Interface case
11649 elsif Import_Interface_Present (N) then
11652 -- Error if being set Imported twice
11655 Error_Msg_NE ("entity& was previously imported", N, E);
11658 Error_Msg_Name_1 := Pname;
11660 ("\(pragma% applies to all previous entities)", N);
11662 Error_Msg_Sloc := Sloc (E);
11663 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11665 -- Here if not previously imported or exported, OK to import
11668 Set_Is_Imported (E);
11670 -- For subprogram, set Import_Pragma field
11672 if Is_Subprogram (E) then
11673 Set_Import_Pragma (E, N);
11676 -- If the entity is an object that is not at the library level,
11677 -- then it is statically allocated. We do not worry about objects
11678 -- with address clauses in this context since they are not really
11679 -- imported in the linker sense.
11682 and then not Is_Library_Level_Entity (E)
11683 and then No (Address_Clause (E))
11685 Set_Is_Statically_Allocated (E);
11692 -------------------------
11693 -- Set_Mechanism_Value --
11694 -------------------------
11696 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11697 -- analyzed, since it is semantic nonsense), so we get it in the exact
11698 -- form created by the parser.
11700 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11701 procedure Bad_Mechanism;
11702 pragma No_Return (Bad_Mechanism);
11703 -- Signal bad mechanism name
11705 -------------------
11706 -- Bad_Mechanism --
11707 -------------------
11709 procedure Bad_Mechanism is
11711 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11714 -- Start of processing for Set_Mechanism_Value
11717 if Mechanism (Ent) /= Default_Mechanism then
11719 ("mechanism for & has already been set", Mech_Name, Ent);
11722 -- MECHANISM_NAME ::= value | reference
11724 if Nkind (Mech_Name) = N_Identifier then
11725 if Chars (Mech_Name) = Name_Value then
11726 Set_Mechanism (Ent, By_Copy);
11729 elsif Chars (Mech_Name) = Name_Reference then
11730 Set_Mechanism (Ent, By_Reference);
11733 elsif Chars (Mech_Name) = Name_Copy then
11735 ("bad mechanism name, Value assumed", Mech_Name);
11744 end Set_Mechanism_Value;
11746 --------------------------
11747 -- Set_Rational_Profile --
11748 --------------------------
11750 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11751 -- extension to the semantics of renaming declarations.
11753 procedure Set_Rational_Profile is
11755 Implicit_Packing := True;
11756 Overriding_Renamings := True;
11757 Use_VADS_Size := True;
11758 end Set_Rational_Profile;
11760 ---------------------------
11761 -- Set_Ravenscar_Profile --
11762 ---------------------------
11764 -- The tasks to be done here are
11766 -- Set required policies
11768 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11769 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11770 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11771 -- (For GNAT_Ravenscar_EDF profile)
11772 -- pragma Locking_Policy (Ceiling_Locking)
11774 -- Set Detect_Blocking mode
11776 -- Set required restrictions (see System.Rident for detailed list)
11778 -- Set the No_Dependence rules
11779 -- No_Dependence => Ada.Asynchronous_Task_Control
11780 -- No_Dependence => Ada.Calendar
11781 -- No_Dependence => Ada.Execution_Time.Group_Budget
11782 -- No_Dependence => Ada.Execution_Time.Timers
11783 -- No_Dependence => Ada.Task_Attributes
11784 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11786 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11787 procedure Set_Error_Msg_To_Profile_Name;
11788 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11791 -----------------------------------
11792 -- Set_Error_Msg_To_Profile_Name --
11793 -----------------------------------
11795 procedure Set_Error_Msg_To_Profile_Name is
11796 Prof_Nam : constant Node_Id :=
11798 (First (Pragma_Argument_Associations (N)));
11801 Get_Name_String (Chars (Prof_Nam));
11802 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11803 Error_Msg_Strlen := Name_Len;
11804 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11805 end Set_Error_Msg_To_Profile_Name;
11807 Profile_Dispatching_Policy : Character;
11809 -- Start of processing for Set_Ravenscar_Profile
11812 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11814 if Profile = GNAT_Ravenscar_EDF then
11815 Profile_Dispatching_Policy := 'E';
11817 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11820 Profile_Dispatching_Policy := 'F';
11823 if Task_Dispatching_Policy /= ' '
11824 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11826 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11827 Set_Error_Msg_To_Profile_Name;
11828 Error_Pragma ("Profile (~) incompatible with policy#");
11830 -- Set the FIFO_Within_Priorities policy, but always preserve
11831 -- System_Location since we like the error message with the run time
11835 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11837 if Task_Dispatching_Policy_Sloc /= System_Location then
11838 Task_Dispatching_Policy_Sloc := Loc;
11842 -- pragma Locking_Policy (Ceiling_Locking)
11844 if Locking_Policy /= ' '
11845 and then Locking_Policy /= 'C'
11847 Error_Msg_Sloc := Locking_Policy_Sloc;
11848 Set_Error_Msg_To_Profile_Name;
11849 Error_Pragma ("Profile (~) incompatible with policy#");
11851 -- Set the Ceiling_Locking policy, but preserve System_Location since
11852 -- we like the error message with the run time name.
11855 Locking_Policy := 'C';
11857 if Locking_Policy_Sloc /= System_Location then
11858 Locking_Policy_Sloc := Loc;
11862 -- pragma Detect_Blocking
11864 Detect_Blocking := True;
11866 -- Set the corresponding restrictions
11868 Set_Profile_Restrictions
11869 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11871 -- Set the No_Dependence restrictions
11873 -- The following No_Dependence restrictions:
11874 -- No_Dependence => Ada.Asynchronous_Task_Control
11875 -- No_Dependence => Ada.Calendar
11876 -- No_Dependence => Ada.Task_Attributes
11877 -- are already set by previous call to Set_Profile_Restrictions.
11880 -- Set the following restrictions which were added to Ada 2005:
11881 -- No_Dependence => Ada.Execution_Time.Group_Budget
11882 -- No_Dependence => Ada.Execution_Time.Timers
11884 if Ada_Version >= Ada_2005 then
11886 Execution_Time : constant Node_Id :=
11887 Sel_Comp ("ada", "execution_time", Loc);
11888 Group_Budgets : constant Node_Id :=
11889 Sel_Comp (Execution_Time, "group_budgets");
11890 Timers : constant Node_Id :=
11891 Sel_Comp (Execution_Time, "timers");
11893 Set_Restriction_No_Dependence
11894 (Unit => Group_Budgets,
11895 Warn => Treat_Restrictions_As_Warnings,
11896 Profile => Ravenscar);
11897 Set_Restriction_No_Dependence
11899 Warn => Treat_Restrictions_As_Warnings,
11900 Profile => Ravenscar);
11904 -- Set the following restriction which was added to Ada 2012 (see
11906 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11908 if Ada_Version >= Ada_2012 then
11909 Set_Restriction_No_Dependence
11911 (Sel_Comp ("system", "multiprocessors", Loc),
11912 "dispatching_domains"),
11913 Warn => Treat_Restrictions_As_Warnings,
11914 Profile => Ravenscar);
11916 -- Set the following restriction which was added to Ada 2022,
11917 -- but as a binding interpretation:
11918 -- No_Dependence => Ada.Synchronous_Barriers
11919 -- for Ravenscar (and therefore for Ravenscar variants) but not
11920 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11921 -- in Ada2012 (AI05-0174).
11923 if Profile /= Jorvik then
11924 Set_Restriction_No_Dependence
11925 (Sel_Comp ("ada", "synchronous_barriers", Loc),
11926 Warn => Treat_Restrictions_As_Warnings,
11927 Profile => Ravenscar);
11931 end Set_Ravenscar_Profile;
11933 -- Start of processing for Analyze_Pragma
11936 -- The following code is a defense against recursion. Not clear that
11937 -- this can happen legitimately, but perhaps some error situations can
11938 -- cause it, and we did see this recursion during testing.
11940 if Analyzed (N) then
11946 Check_Restriction_No_Use_Of_Pragma (N);
11948 if Is_Aspect_Id (Chars (Pragma_Identifier (N))) then
11949 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11950 -- no aspect_specification, attribute_definition_clause, or pragma
11952 Check_Restriction_No_Specification_Of_Aspect (N);
11955 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11956 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11958 if Should_Ignore_Pragma_Sem (N)
11959 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11960 and then Ignore_Rep_Clauses)
11965 -- Deal with unrecognized pragma
11967 if not Is_Pragma_Name (Pname) then
11969 Msg_Issued : Boolean := False;
11972 (Msg_Issued, No_Unrecognized_Pragmas, Pragma_Identifier (N));
11973 if not Msg_Issued and then Warn_On_Unrecognized_Pragma then
11974 Error_Msg_Name_1 := Pname;
11975 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11977 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11978 if Is_Bad_Spelling_Of (Pname, PN) then
11979 Error_Msg_Name_1 := PN;
11980 Error_Msg_N -- CODEFIX
11981 ("\?g?possible misspelling of %!",
11982 Pragma_Identifier (N));
11992 -- Here to start processing for recognized pragma
11994 Pname := Original_Aspect_Pragma_Name (N);
11996 -- Capture setting of Opt.Uneval_Old
11998 case Opt.Uneval_Old is
12000 Set_Uneval_Old_Accept (N);
12006 Set_Uneval_Old_Warn (N);
12009 raise Program_Error;
12012 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
12013 -- is already set, indicating that we have already checked the policy
12014 -- at the right point. This happens for example in the case of a pragma
12015 -- that is derived from an Aspect.
12017 if Is_Ignored (N) or else Is_Checked (N) then
12020 -- For a pragma that is a rewriting of another pragma, copy the
12021 -- Is_Checked/Is_Ignored status from the rewritten pragma.
12023 elsif Is_Rewrite_Substitution (N)
12024 and then Nkind (Original_Node (N)) = N_Pragma
12026 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12027 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12029 -- Otherwise query the applicable policy at this point
12032 Check_Applicable_Policy (N);
12034 -- If pragma is disabled, rewrite as NULL and skip analysis
12036 if Is_Disabled (N) then
12037 Rewrite (N, Make_Null_Statement (Loc));
12043 -- Mark assertion pragmas as Ghost depending on their enclosing context
12045 if Assertion_Expression_Pragma (Prag_Id) then
12046 Mark_Ghost_Pragma (N, Current_Scope);
12049 -- Preset arguments
12051 Arg_Count := List_Length (Pragma_Argument_Associations (N));
12052 Arg1 := First (Pragma_Argument_Associations (N));
12058 if Present (Arg1) then
12059 Arg2 := Next (Arg1);
12061 if Present (Arg2) then
12062 Arg3 := Next (Arg2);
12064 if Present (Arg3) then
12065 Arg4 := Next (Arg3);
12067 if Present (Arg4) then
12068 Arg5 := Next (Arg4);
12074 -- An enumeration type defines the pragmas that are supported by the
12075 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
12076 -- into the corresponding enumeration value for the following case.
12084 -- pragma Abort_Defer;
12086 when Pragma_Abort_Defer =>
12088 Check_Arg_Count (0);
12090 -- The only required semantic processing is to check the
12091 -- placement. This pragma must appear at the start of the
12092 -- statement sequence of a handled sequence of statements.
12094 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
12095 or else N /= First (Statements (Parent (N)))
12100 --------------------
12101 -- Abstract_State --
12102 --------------------
12104 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
12106 -- ABSTRACT_STATE_LIST ::=
12108 -- | STATE_NAME_WITH_OPTIONS
12109 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
12111 -- STATE_NAME_WITH_OPTIONS ::=
12113 -- | (STATE_NAME with OPTION_LIST)
12115 -- OPTION_LIST ::= OPTION {, OPTION}
12119 -- | NAME_VALUE_OPTION
12121 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
12123 -- NAME_VALUE_OPTION ::=
12124 -- Part_Of => ABSTRACT_STATE
12125 -- | External [=> EXTERNAL_PROPERTY_LIST]
12127 -- EXTERNAL_PROPERTY_LIST ::=
12128 -- EXTERNAL_PROPERTY
12129 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
12131 -- EXTERNAL_PROPERTY ::=
12132 -- Async_Readers [=> boolean_EXPRESSION]
12133 -- | Async_Writers [=> boolean_EXPRESSION]
12134 -- | Effective_Reads [=> boolean_EXPRESSION]
12135 -- | Effective_Writes [=> boolean_EXPRESSION]
12136 -- others => boolean_EXPRESSION
12138 -- STATE_NAME ::= defining_identifier
12140 -- ABSTRACT_STATE ::= name
12142 -- Characteristics:
12144 -- * Analysis - The annotation is fully analyzed immediately upon
12145 -- elaboration as it cannot forward reference entities.
12147 -- * Expansion - None.
12149 -- * Template - The annotation utilizes the generic template of the
12150 -- related package declaration.
12152 -- * Globals - The annotation cannot reference global entities.
12154 -- * Instance - The annotation is instantiated automatically when
12155 -- the related generic package is instantiated.
12157 when Pragma_Abstract_State => Abstract_State : declare
12158 Missing_Parentheses : Boolean := False;
12159 -- Flag set when a state declaration with options is not properly
12162 -- Flags used to verify the consistency of states
12164 Non_Null_Seen : Boolean := False;
12165 Null_Seen : Boolean := False;
12167 procedure Analyze_Abstract_State
12169 Pack_Id : Entity_Id);
12170 -- Verify the legality of a single state declaration. Create and
12171 -- decorate a state abstraction entity and introduce it into the
12172 -- visibility chain. Pack_Id denotes the entity or the related
12173 -- package where pragma Abstract_State appears.
12175 procedure Malformed_State_Error (State : Node_Id);
12176 -- Emit an error concerning the illegal declaration of abstract
12177 -- state State. This routine diagnoses syntax errors that lead to
12178 -- a different parse tree. The error is issued regardless of the
12179 -- SPARK mode in effect.
12181 ----------------------------
12182 -- Analyze_Abstract_State --
12183 ----------------------------
12185 procedure Analyze_Abstract_State
12187 Pack_Id : Entity_Id)
12189 -- Flags used to verify the consistency of options
12191 AR_Seen : Boolean := False;
12192 AW_Seen : Boolean := False;
12193 ER_Seen : Boolean := False;
12194 EW_Seen : Boolean := False;
12195 External_Seen : Boolean := False;
12196 Ghost_Seen : Boolean := False;
12197 Others_Seen : Boolean := False;
12198 Part_Of_Seen : Boolean := False;
12199 Synchronous_Seen : Boolean := False;
12201 -- Flags used to store the static value of all external states'
12204 AR_Val : Boolean := False;
12205 AW_Val : Boolean := False;
12206 ER_Val : Boolean := False;
12207 EW_Val : Boolean := False;
12209 State_Id : Entity_Id := Empty;
12210 -- The entity to be generated for the current state declaration
12212 procedure Analyze_External_Option (Opt : Node_Id);
12213 -- Verify the legality of option External
12215 procedure Analyze_External_Property
12217 Expr : Node_Id := Empty);
12218 -- Verify the legailty of a single external property. Prop
12219 -- denotes the external property. Expr is the expression used
12220 -- to set the property.
12222 procedure Analyze_Part_Of_Option (Opt : Node_Id);
12223 -- Verify the legality of option Part_Of
12225 procedure Check_Duplicate_Option
12227 Status : in out Boolean);
12228 -- Flag Status denotes whether a particular option has been
12229 -- seen while processing a state. This routine verifies that
12230 -- Opt is not a duplicate option and sets the flag Status
12231 -- (SPARK RM 7.1.4(1)).
12233 procedure Check_Duplicate_Property
12235 Status : in out Boolean);
12236 -- Flag Status denotes whether a particular property has been
12237 -- seen while processing option External. This routine verifies
12238 -- that Prop is not a duplicate property and sets flag Status.
12239 -- Opt is not a duplicate property and sets the flag Status.
12240 -- (SPARK RM 7.1.4(2))
12242 procedure Check_Ghost_Synchronous;
12243 -- Ensure that the abstract state is not subject to both Ghost
12244 -- and Synchronous simple options. Emit an error if this is the
12247 procedure Create_Abstract_State
12251 Is_Null : Boolean);
12252 -- Generate an abstract state entity with name Nam and enter it
12253 -- into visibility. Decl is the "declaration" of the state as
12254 -- it appears in pragma Abstract_State. Loc is the location of
12255 -- the related state "declaration". Flag Is_Null should be set
12256 -- when the associated Abstract_State pragma defines a null
12259 -----------------------------
12260 -- Analyze_External_Option --
12261 -----------------------------
12263 procedure Analyze_External_Option (Opt : Node_Id) is
12264 Errors : constant Nat := Serious_Errors_Detected;
12266 Props : Node_Id := Empty;
12269 if Nkind (Opt) = N_Component_Association then
12270 Props := Expression (Opt);
12273 -- External state with properties
12275 if Present (Props) then
12277 -- Multiple properties appear as an aggregate
12279 if Nkind (Props) = N_Aggregate then
12281 -- Simple property form
12283 Prop := First (Expressions (Props));
12284 while Present (Prop) loop
12285 Analyze_External_Property (Prop);
12289 -- Property with expression form
12291 Prop := First (Component_Associations (Props));
12292 while Present (Prop) loop
12293 Analyze_External_Property
12294 (Prop => First (Choices (Prop)),
12295 Expr => Expression (Prop));
12303 Analyze_External_Property (Props);
12306 -- An external state defined without any properties defaults
12307 -- all properties to True.
12316 -- Once all external properties have been processed, verify
12317 -- their mutual interaction. Do not perform the check when
12318 -- at least one of the properties is illegal as this will
12319 -- produce a bogus error.
12321 if Errors = Serious_Errors_Detected then
12322 Check_External_Properties
12323 (State, AR_Val, AW_Val, ER_Val, EW_Val);
12325 end Analyze_External_Option;
12327 -------------------------------
12328 -- Analyze_External_Property --
12329 -------------------------------
12331 procedure Analyze_External_Property
12333 Expr : Node_Id := Empty)
12335 Expr_Val : Boolean;
12338 -- Check the placement of "others" (if available)
12340 if Nkind (Prop) = N_Others_Choice then
12341 if Others_Seen then
12343 ("only one OTHERS choice allowed in option External",
12346 Others_Seen := True;
12349 elsif Others_Seen then
12351 ("OTHERS must be the last property in option External",
12354 -- The only remaining legal options are the four predefined
12355 -- external properties.
12357 elsif Nkind (Prop) = N_Identifier
12358 and then Chars (Prop) in Name_Async_Readers
12359 | Name_Async_Writers
12360 | Name_Effective_Reads
12361 | Name_Effective_Writes
12365 -- Otherwise the construct is not a valid property
12368 SPARK_Msg_N ("invalid external state property", Prop);
12372 -- Ensure that the expression of the external state property
12373 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
12375 if Present (Expr) then
12376 Analyze_And_Resolve (Expr, Standard_Boolean);
12378 if Is_OK_Static_Expression (Expr) then
12379 Expr_Val := Is_True (Expr_Value (Expr));
12382 ("expression of external state property must be "
12387 -- The lack of expression defaults the property to True
12393 -- Named properties
12395 if Nkind (Prop) = N_Identifier then
12396 if Chars (Prop) = Name_Async_Readers then
12397 Check_Duplicate_Property (Prop, AR_Seen);
12398 AR_Val := Expr_Val;
12400 elsif Chars (Prop) = Name_Async_Writers then
12401 Check_Duplicate_Property (Prop, AW_Seen);
12402 AW_Val := Expr_Val;
12404 elsif Chars (Prop) = Name_Effective_Reads then
12405 Check_Duplicate_Property (Prop, ER_Seen);
12406 ER_Val := Expr_Val;
12409 Check_Duplicate_Property (Prop, EW_Seen);
12410 EW_Val := Expr_Val;
12413 -- The handling of property "others" must take into account
12414 -- all other named properties that have been encountered so
12415 -- far. Only those that have not been seen are affected by
12419 if not AR_Seen then
12420 AR_Val := Expr_Val;
12423 if not AW_Seen then
12424 AW_Val := Expr_Val;
12427 if not ER_Seen then
12428 ER_Val := Expr_Val;
12431 if not EW_Seen then
12432 EW_Val := Expr_Val;
12435 end Analyze_External_Property;
12437 ----------------------------
12438 -- Analyze_Part_Of_Option --
12439 ----------------------------
12441 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
12442 Encap : constant Node_Id := Expression (Opt);
12443 Constits : Elist_Id;
12444 Encap_Id : Entity_Id;
12448 Check_Duplicate_Option (Opt, Part_Of_Seen);
12451 (Indic => First (Choices (Opt)),
12452 Item_Id => State_Id,
12454 Encap_Id => Encap_Id,
12457 -- The Part_Of indicator transforms the abstract state into
12458 -- a constituent of the encapsulating state or single
12459 -- concurrent type.
12462 pragma Assert (Present (Encap_Id));
12463 Constits := Part_Of_Constituents (Encap_Id);
12465 if No (Constits) then
12466 Constits := New_Elmt_List;
12467 Set_Part_Of_Constituents (Encap_Id, Constits);
12470 Append_Elmt (State_Id, Constits);
12471 Set_Encapsulating_State (State_Id, Encap_Id);
12473 end Analyze_Part_Of_Option;
12475 ----------------------------
12476 -- Check_Duplicate_Option --
12477 ----------------------------
12479 procedure Check_Duplicate_Option
12481 Status : in out Boolean)
12485 SPARK_Msg_N ("duplicate state option", Opt);
12489 end Check_Duplicate_Option;
12491 ------------------------------
12492 -- Check_Duplicate_Property --
12493 ------------------------------
12495 procedure Check_Duplicate_Property
12497 Status : in out Boolean)
12501 SPARK_Msg_N ("duplicate external property", Prop);
12505 end Check_Duplicate_Property;
12507 -----------------------------
12508 -- Check_Ghost_Synchronous --
12509 -----------------------------
12511 procedure Check_Ghost_Synchronous is
12513 -- A synchronized abstract state cannot be Ghost and vice
12514 -- versa (SPARK RM 6.9(19)).
12516 if Ghost_Seen and Synchronous_Seen then
12517 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12519 end Check_Ghost_Synchronous;
12521 ---------------------------
12522 -- Create_Abstract_State --
12523 ---------------------------
12525 procedure Create_Abstract_State
12532 -- The abstract state may be semi-declared when the related
12533 -- package was withed through a limited with clause. In that
12534 -- case reuse the entity to fully declare the state.
12536 if Present (Decl) and then Present (Entity (Decl)) then
12537 State_Id := Entity (Decl);
12539 -- Otherwise the elaboration of pragma Abstract_State
12540 -- declares the state.
12543 State_Id := Make_Defining_Identifier (Loc, Nam);
12545 if Present (Decl) then
12546 Set_Entity (Decl, State_Id);
12550 -- Null states never come from source
12552 Set_Comes_From_Source (State_Id, not Is_Null);
12553 Set_Parent (State_Id, State);
12554 Mutate_Ekind (State_Id, E_Abstract_State);
12555 Set_Is_Not_Self_Hidden (State_Id);
12556 Set_Etype (State_Id, Standard_Void_Type);
12557 Set_Encapsulating_State (State_Id, Empty);
12559 -- Set the SPARK mode from the current context
12561 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12562 Set_SPARK_Pragma_Inherited (State_Id);
12564 -- An abstract state declared within a Ghost region becomes
12565 -- Ghost (SPARK RM 6.9(2)).
12567 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12568 Set_Is_Ghost_Entity (State_Id);
12571 -- Establish a link between the state declaration and the
12572 -- abstract state entity. Note that a null state remains as
12573 -- N_Null and does not carry any linkages.
12575 if not Is_Null then
12576 if Present (Decl) then
12577 Set_Entity (Decl, State_Id);
12578 Set_Etype (Decl, Standard_Void_Type);
12581 -- Every non-null state must be defined, nameable and
12584 Push_Scope (Pack_Id);
12585 Generate_Definition (State_Id);
12586 Enter_Name (State_Id);
12589 end Create_Abstract_State;
12596 -- Start of processing for Analyze_Abstract_State
12599 -- A package with a null abstract state is not allowed to
12600 -- declare additional states.
12604 ("package & has null abstract state", State, Pack_Id);
12606 -- Null states appear as internally generated entities
12608 elsif Nkind (State) = N_Null then
12609 Create_Abstract_State
12610 (Nam => New_Internal_Name ('S'),
12612 Loc => Sloc (State),
12616 -- Catch a case where a null state appears in a list of
12617 -- non-null states.
12619 if Non_Null_Seen then
12621 ("package & has non-null abstract state",
12625 -- Simple state declaration
12627 elsif Nkind (State) = N_Identifier then
12628 Create_Abstract_State
12629 (Nam => Chars (State),
12631 Loc => Sloc (State),
12633 Non_Null_Seen := True;
12635 -- State declaration with various options. This construct
12636 -- appears as an extension aggregate in the tree.
12638 elsif Nkind (State) = N_Extension_Aggregate then
12639 if Nkind (Ancestor_Part (State)) = N_Identifier then
12640 Create_Abstract_State
12641 (Nam => Chars (Ancestor_Part (State)),
12642 Decl => Ancestor_Part (State),
12643 Loc => Sloc (Ancestor_Part (State)),
12645 Non_Null_Seen := True;
12648 ("state name must be an identifier",
12649 Ancestor_Part (State));
12652 -- Options External, Ghost and Synchronous appear as
12655 Opt := First (Expressions (State));
12656 while Present (Opt) loop
12657 if Nkind (Opt) = N_Identifier then
12661 if Chars (Opt) = Name_External then
12662 Check_Duplicate_Option (Opt, External_Seen);
12663 Analyze_External_Option (Opt);
12667 elsif Chars (Opt) = Name_Ghost then
12668 Check_Duplicate_Option (Opt, Ghost_Seen);
12669 Check_Ghost_Synchronous;
12671 if Present (State_Id) then
12672 Set_Is_Ghost_Entity (State_Id);
12677 elsif Chars (Opt) = Name_Synchronous then
12678 Check_Duplicate_Option (Opt, Synchronous_Seen);
12679 Check_Ghost_Synchronous;
12681 -- Option Part_Of without an encapsulating state is
12682 -- illegal (SPARK RM 7.1.4(8)).
12684 elsif Chars (Opt) = Name_Part_Of then
12686 ("indicator Part_Of must denote abstract state, "
12687 & "single protected type or single task type",
12690 -- Do not emit an error message when a previous state
12691 -- declaration with options was not parenthesized as
12692 -- the option is actually another state declaration.
12694 -- with Abstract_State
12695 -- (State_1 with ..., -- missing parentheses
12696 -- (State_2 with ...),
12697 -- State_3) -- ok state declaration
12699 elsif Missing_Parentheses then
12702 -- Otherwise the option is not allowed. Note that it
12703 -- is not possible to distinguish between an option
12704 -- and a state declaration when a previous state with
12705 -- options not properly parentheses.
12707 -- with Abstract_State
12708 -- (State_1 with ..., -- missing parentheses
12709 -- State_2); -- could be an option
12713 ("simple option not allowed in state declaration",
12717 -- Catch a case where missing parentheses around a state
12718 -- declaration with options cause a subsequent state
12719 -- declaration with options to be treated as an option.
12721 -- with Abstract_State
12722 -- (State_1 with ..., -- missing parentheses
12723 -- (State_2 with ...))
12725 elsif Nkind (Opt) = N_Extension_Aggregate then
12726 Missing_Parentheses := True;
12728 ("state declaration must be parenthesized",
12729 Ancestor_Part (State));
12731 -- Otherwise the option is malformed
12734 SPARK_Msg_N ("malformed option", Opt);
12740 -- Options External and Part_Of appear as component
12743 Opt := First (Component_Associations (State));
12744 while Present (Opt) loop
12745 Opt_Nam := First (Choices (Opt));
12747 if Nkind (Opt_Nam) = N_Identifier then
12748 if Chars (Opt_Nam) = Name_External then
12749 Analyze_External_Option (Opt);
12751 elsif Chars (Opt_Nam) = Name_Part_Of then
12752 Analyze_Part_Of_Option (Opt);
12755 SPARK_Msg_N ("invalid state option", Opt);
12758 SPARK_Msg_N ("invalid state option", Opt);
12764 -- Any other attempt to declare a state is illegal
12767 Malformed_State_Error (State);
12771 -- Guard against a junk state. In such cases no entity is
12772 -- generated and the subsequent checks cannot be applied.
12774 if Present (State_Id) then
12776 -- Verify whether the state does not introduce an illegal
12777 -- hidden state within a package subject to a null abstract
12780 Check_No_Hidden_State (State_Id);
12782 -- Check whether the lack of option Part_Of agrees with the
12783 -- placement of the abstract state with respect to the state
12786 if not Part_Of_Seen then
12787 Check_Missing_Part_Of (State_Id);
12790 -- Associate the state with its related package
12792 if No (Abstract_States (Pack_Id)) then
12793 Set_Abstract_States (Pack_Id, New_Elmt_List);
12796 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12798 end Analyze_Abstract_State;
12800 ---------------------------
12801 -- Malformed_State_Error --
12802 ---------------------------
12804 procedure Malformed_State_Error (State : Node_Id) is
12806 Error_Msg_N ("malformed abstract state declaration", State);
12808 -- An abstract state with a simple option is being declared
12809 -- with "=>" rather than the legal "with". The state appears
12810 -- as a component association.
12812 if Nkind (State) = N_Component_Association then
12813 Error_Msg_N ("\use WITH to specify simple option", State);
12815 end Malformed_State_Error;
12819 Pack_Decl : Node_Id;
12820 Pack_Id : Entity_Id;
12824 -- Start of processing for Abstract_State
12828 Check_No_Identifiers;
12829 Check_Arg_Count (1);
12831 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12833 if Nkind (Pack_Decl) not in
12834 N_Generic_Package_Declaration | N_Package_Declaration
12839 Pack_Id := Defining_Entity (Pack_Decl);
12841 -- A pragma that applies to a Ghost entity becomes Ghost for the
12842 -- purposes of legality checks and removal of ignored Ghost code.
12844 Mark_Ghost_Pragma (N, Pack_Id);
12845 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12847 -- Chain the pragma on the contract for completeness
12849 Add_Contract_Item (N, Pack_Id);
12851 -- The legality checks of pragmas Abstract_State, Initializes, and
12852 -- Initial_Condition are affected by the SPARK mode in effect. In
12853 -- addition, these three pragmas are subject to an inherent order:
12855 -- 1) Abstract_State
12857 -- 3) Initial_Condition
12859 -- Analyze all these pragmas in the order outlined above
12861 Analyze_If_Present (Pragma_SPARK_Mode);
12862 States := Expression (Get_Argument (N, Pack_Id));
12864 -- Multiple non-null abstract states appear as an aggregate
12866 if Nkind (States) = N_Aggregate then
12867 State := First (Expressions (States));
12868 while Present (State) loop
12869 Analyze_Abstract_State (State, Pack_Id);
12873 -- An abstract state with a simple option is being illegaly
12874 -- declared with "=>" rather than "with". In this case the
12875 -- state declaration appears as a component association.
12877 if Present (Component_Associations (States)) then
12878 State := First (Component_Associations (States));
12879 while Present (State) loop
12880 Malformed_State_Error (State);
12885 -- Various forms of a single abstract state. Note that these may
12886 -- include malformed state declarations.
12889 Analyze_Abstract_State (States, Pack_Id);
12892 Analyze_If_Present (Pragma_Initializes);
12893 Analyze_If_Present (Pragma_Initial_Condition);
12894 end Abstract_State;
12902 -- Note: this pragma also has some specific processing in Par.Prag
12903 -- because we want to set the Ada version mode during parsing.
12905 when Pragma_Ada_83 =>
12907 Check_Arg_Count (0);
12909 -- We really should check unconditionally for proper configuration
12910 -- pragma placement, since we really don't want mixed Ada modes
12911 -- within a single unit, and the GNAT reference manual has always
12912 -- said this was a configuration pragma, but we did not check and
12913 -- are hesitant to add the check now.
12915 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12916 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12917 -- or Ada 2012 mode.
12919 if Ada_Version >= Ada_2005 then
12920 Check_Valid_Configuration_Pragma;
12923 -- Now set Ada 83 mode
12925 if Latest_Ada_Only then
12926 Error_Pragma ("??pragma% ignored");
12928 Ada_Version := Ada_83;
12929 Ada_Version_Explicit := Ada_83;
12930 Ada_Version_Pragma := N;
12939 -- Note: this pragma also has some specific processing in Par.Prag
12940 -- because we want to set the Ada 83 version mode during parsing.
12942 when Pragma_Ada_95 =>
12944 Check_Arg_Count (0);
12946 -- We really should check unconditionally for proper configuration
12947 -- pragma placement, since we really don't want mixed Ada modes
12948 -- within a single unit, and the GNAT reference manual has always
12949 -- said this was a configuration pragma, but we did not check and
12950 -- are hesitant to add the check now.
12952 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12953 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12955 if Ada_Version >= Ada_2005 then
12956 Check_Valid_Configuration_Pragma;
12959 -- Now set Ada 95 mode
12961 if Latest_Ada_Only then
12962 Error_Pragma ("??pragma% ignored");
12964 Ada_Version := Ada_95;
12965 Ada_Version_Explicit := Ada_95;
12966 Ada_Version_Pragma := N;
12969 ---------------------
12970 -- Ada_05/Ada_2005 --
12971 ---------------------
12974 -- pragma Ada_05 (LOCAL_NAME);
12976 -- pragma Ada_2005;
12977 -- pragma Ada_2005 (LOCAL_NAME):
12979 -- Note: these pragmas also have some specific processing in Par.Prag
12980 -- because we want to set the Ada 2005 version mode during parsing.
12982 -- The one argument form is used for managing the transition from
12983 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12984 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12985 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12986 -- mode, a preference rule is established which does not choose
12987 -- such an entity unless it is unambiguously specified. This avoids
12988 -- extra subprograms marked this way from generating ambiguities in
12989 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12990 -- intended for exclusive use in the GNAT run-time library.
13001 if Arg_Count = 1 then
13002 Check_Arg_Is_Local_Name (Arg1);
13003 E_Id := Get_Pragma_Arg (Arg1);
13005 if Etype (E_Id) = Any_Type then
13009 Set_Is_Ada_2005_Only (Entity (E_Id));
13010 Record_Rep_Item (Entity (E_Id), N);
13013 Check_Arg_Count (0);
13015 -- For Ada_2005 we unconditionally enforce the documented
13016 -- configuration pragma placement, since we do not want to
13017 -- tolerate mixed modes in a unit involving Ada 2005. That
13018 -- would cause real difficulties for those cases where there
13019 -- are incompatibilities between Ada 95 and Ada 2005.
13021 Check_Valid_Configuration_Pragma;
13023 -- Now set appropriate Ada mode
13025 if Latest_Ada_Only then
13026 Error_Pragma ("??pragma% ignored");
13028 Ada_Version := Ada_2005;
13029 Ada_Version_Explicit := Ada_2005;
13030 Ada_Version_Pragma := N;
13035 ---------------------
13036 -- Ada_12/Ada_2012 --
13037 ---------------------
13040 -- pragma Ada_12 (LOCAL_NAME);
13042 -- pragma Ada_2012;
13043 -- pragma Ada_2012 (LOCAL_NAME):
13045 -- Note: these pragmas also have some specific processing in Par.Prag
13046 -- because we want to set the Ada 2012 version mode during parsing.
13048 -- The one argument form is used for managing the transition from Ada
13049 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
13050 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
13051 -- mode will generate a warning. In addition, in any pre-Ada_2012
13052 -- mode, a preference rule is established which does not choose
13053 -- such an entity unless it is unambiguously specified. This avoids
13054 -- extra subprograms marked this way from generating ambiguities in
13055 -- otherwise legal pre-Ada_2012 programs. The one argument form is
13056 -- intended for exclusive use in the GNAT run-time library.
13067 if Arg_Count = 1 then
13068 Check_Arg_Is_Local_Name (Arg1);
13069 E_Id := Get_Pragma_Arg (Arg1);
13071 if Etype (E_Id) = Any_Type then
13075 Set_Is_Ada_2012_Only (Entity (E_Id));
13076 Record_Rep_Item (Entity (E_Id), N);
13079 Check_Arg_Count (0);
13081 -- For Ada_2012 we unconditionally enforce the documented
13082 -- configuration pragma placement, since we do not want to
13083 -- tolerate mixed modes in a unit involving Ada 2012. That
13084 -- would cause real difficulties for those cases where there
13085 -- are incompatibilities between Ada 95 and Ada 2012. We could
13086 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
13088 Check_Valid_Configuration_Pragma;
13090 -- Now set appropriate Ada mode
13092 Ada_Version := Ada_2012;
13093 Ada_Version_Explicit := Ada_2012;
13094 Ada_Version_Pragma := N;
13102 -- pragma Ada_2022;
13103 -- pragma Ada_2022 (LOCAL_NAME):
13105 -- Note: this pragma also has some specific processing in Par.Prag
13106 -- because we want to set the Ada 2022 version mode during parsing.
13108 -- The one argument form is used for managing the transition from Ada
13109 -- 2012 to Ada 2022 in the run-time library. If an entity is marked
13110 -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022
13111 -- mode will generate a warning;for calls to Ada_2022 only primitives
13112 -- that require overriding an error will be reported. In addition, in
13113 -- any pre-Ada_2022 mode, a preference rule is established which does
13114 -- not choose such an entity unless it is unambiguously specified.
13115 -- This avoids extra subprograms marked this way from generating
13116 -- ambiguities in otherwise legal pre-Ada 2022 programs. The one
13117 -- argument form is intended for exclusive use in the GNAT run-time
13120 when Pragma_Ada_2022 =>
13127 if Arg_Count = 1 then
13128 Check_Arg_Is_Local_Name (Arg1);
13129 E_Id := Get_Pragma_Arg (Arg1);
13131 if Etype (E_Id) = Any_Type then
13135 Set_Is_Ada_2022_Only (Entity (E_Id));
13136 Record_Rep_Item (Entity (E_Id), N);
13139 Check_Arg_Count (0);
13141 -- For Ada_2022 we unconditionally enforce the documented
13142 -- configuration pragma placement, since we do not want to
13143 -- tolerate mixed modes in a unit involving Ada 2022. That
13144 -- would cause real difficulties for those cases where there
13145 -- are incompatibilities between Ada 2012 and Ada 2022. We
13146 -- could allow mixing of Ada 2012 and Ada 2022 but it's not
13149 Check_Valid_Configuration_Pragma;
13151 -- Now set appropriate Ada mode
13153 Ada_Version := Ada_2022;
13154 Ada_Version_Explicit := Ada_2022;
13155 Ada_Version_Pragma := N;
13159 -------------------------------------
13160 -- Aggregate_Individually_Assign --
13161 -------------------------------------
13163 -- pragma Aggregate_Individually_Assign;
13165 when Pragma_Aggregate_Individually_Assign =>
13167 Check_Arg_Count (0);
13168 Check_Valid_Configuration_Pragma;
13169 Aggregate_Individually_Assign := True;
13171 ----------------------
13172 -- All_Calls_Remote --
13173 ----------------------
13175 -- pragma All_Calls_Remote [(library_package_NAME)];
13177 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
13178 Lib_Entity : Entity_Id;
13181 Check_Ada_83_Warning;
13182 Check_Valid_Library_Unit_Pragma;
13184 -- If N was rewritten as a null statement there is nothing more
13187 if Nkind (N) = N_Null_Statement then
13191 Lib_Entity := Find_Lib_Unit_Name;
13193 -- A pragma that applies to a Ghost entity becomes Ghost for the
13194 -- purposes of legality checks and removal of ignored Ghost code.
13196 Mark_Ghost_Pragma (N, Lib_Entity);
13198 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13200 if Present (Lib_Entity) and then not Debug_Flag_U then
13201 if not Is_Remote_Call_Interface (Lib_Entity) then
13202 Error_Pragma ("pragma% only apply to rci unit");
13204 -- Set flag for entity of the library unit
13207 Set_Has_All_Calls_Remote (Lib_Entity);
13210 end All_Calls_Remote;
13212 ---------------------------
13213 -- Allow_Integer_Address --
13214 ---------------------------
13216 -- pragma Allow_Integer_Address;
13218 when Pragma_Allow_Integer_Address =>
13220 Check_Valid_Configuration_Pragma;
13221 Check_Arg_Count (0);
13223 -- If Address is a private type, then set the flag to allow
13224 -- integer address values. If Address is not private, then this
13225 -- pragma has no purpose, so it is simply ignored. Not clear if
13226 -- there are any such targets now.
13228 if Opt.Address_Is_Private then
13229 Opt.Allow_Integer_Address := True;
13232 -----------------------
13233 -- Always_Terminates --
13234 -----------------------
13236 -- pragma Always_Terminates [ (boolean_EXPRESSION) ];
13238 -- Characteristics:
13240 -- * Analysis - The annotation undergoes initial checks to verify
13241 -- the legal placement and context. Secondary checks preanalyze the
13244 -- Analyze_Always_Terminates_Cases_In_Decl_Part
13246 -- * Expansion - The annotation is expanded during the expansion of
13247 -- the related subprogram [body] contract as performed in:
13249 -- Expand_Subprogram_Contract
13251 -- * Template - The annotation utilizes the generic template of the
13252 -- related subprogram [body] when it is:
13254 -- aspect on subprogram declaration
13255 -- aspect on stand-alone subprogram body
13256 -- pragma on stand-alone subprogram body
13258 -- The annotation must prepare its own template when it is:
13260 -- pragma on subprogram declaration
13262 -- * Globals - Capture of global references must occur after full
13265 -- * Instance - The annotation is instantiated automatically when
13266 -- the related generic subprogram [body] is instantiated except for
13267 -- the "pragma on subprogram declaration" case. In that scenario
13268 -- the annotation must instantiate itself.
13270 when Pragma_Always_Terminates => Always_Terminates : declare
13271 Spec_Id : Entity_Id;
13272 Subp_Decl : Node_Id;
13273 Subp_Spec : Node_Id;
13277 Check_No_Identifiers;
13278 Check_At_Most_N_Arguments (1);
13280 -- Ensure the proper placement of the pragma. Always_Terminates
13281 -- must be associated with a subprogram declaration or a body that
13285 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13287 -- Generic subprogram and package declaration
13289 if Nkind (Subp_Decl) in N_Generic_Declaration then
13292 -- Package declaration
13294 elsif Nkind (Subp_Decl) = N_Package_Declaration then
13297 -- Body acts as spec
13299 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13300 and then No (Corresponding_Spec (Subp_Decl))
13304 -- Body stub acts as spec
13306 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13307 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13313 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13314 Subp_Spec := Specification (Subp_Decl);
13316 -- Pragma Always_Terminates is forbidden on null procedures,
13317 -- as this may lead to potential ambiguities in behavior
13318 -- when interface null procedures are involved. Also, it
13319 -- just wouldn't make sense, because null procedures always
13320 -- terminate anyway.
13322 if Nkind (Subp_Spec) = N_Procedure_Specification
13323 and then Null_Present (Subp_Spec)
13325 Error_Msg_N (Fix_Error
13326 ("pragma % cannot apply to null procedure"), N);
13332 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
13339 Spec_Id := Unique_Defining_Entity (Subp_Decl);
13341 -- In order to call Is_Function_With_Side_Effects, analyze pragma
13342 -- Side_Effects if present.
13344 Analyze_If_Present (Pragma_Side_Effects);
13346 -- Pragma Always_Terminates is not allowed on functions without
13349 if Ekind (Spec_Id) in E_Function | E_Generic_Function
13350 and then not Is_Function_With_Side_Effects (Spec_Id)
13352 Error_Msg_Code := GEC_Always_Terminates_On_Function;
13354 if Ekind (Spec_Id) = E_Function then
13355 Error_Msg_N (Fix_Error
13356 ("pragma % cannot apply to function '[[]']"), N);
13359 elsif Ekind (Spec_Id) = E_Generic_Function then
13360 Error_Msg_N (Fix_Error
13361 ("pragma % cannot apply to generic function '[[]']"), N);
13366 -- Pragma Always_Terminates applied to packages doesn't allow any
13369 if Is_Package_Or_Generic_Package (Spec_Id)
13370 and then Arg_Count /= 0
13372 Error_Msg_N (Fix_Error
13373 ("pragma % applied to package cannot have arguments"), N);
13377 -- A pragma that applies to a Ghost entity becomes Ghost for the
13378 -- purposes of legality checks and removal of ignored Ghost code.
13380 Mark_Ghost_Pragma (N, Spec_Id);
13382 -- Chain the pragma on the contract for further processing by
13383 -- Analyze_Always_Terminates_In_Decl_Part.
13385 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13387 -- Fully analyze the pragma when it appears inside a subprogram
13388 -- body because it cannot benefit from forward references.
13390 if Nkind (Subp_Decl) in N_Subprogram_Body
13391 | N_Subprogram_Body_Stub
13393 -- The legality checks of pragma Always_Terminates are affected
13394 -- by the SPARK mode in effect and the volatility of the
13395 -- context. Analyze all pragmas in a specific order.
13397 Analyze_If_Present (Pragma_SPARK_Mode);
13398 Analyze_If_Present (Pragma_Volatile_Function);
13399 Analyze_Always_Terminates_In_Decl_Part (N);
13401 end Always_Terminates;
13408 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13409 -- ARG ::= NAME | EXPRESSION
13411 -- The first two arguments are by convention intended to refer to an
13412 -- external tool and a tool-specific function. These arguments are
13415 when Pragma_Annotate | Pragma_GNAT_Annotate => Annotate : declare
13420 --------------------------
13421 -- Inferred_String_Type --
13422 --------------------------
13424 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
13425 -- Infer the type to use for a string literal or a concatentation
13426 -- of operands whose types can be inferred. For such expressions,
13427 -- returns the "narrowest" of the three predefined string types
13428 -- that can represent the characters occurring in the expression.
13429 -- For other expressions, returns Empty.
13431 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
13433 case Nkind (Expr) is
13434 when N_String_Literal =>
13435 if Has_Wide_Wide_Character (Expr) then
13436 return Standard_Wide_Wide_String;
13437 elsif Has_Wide_Character (Expr) then
13438 return Standard_Wide_String;
13440 return Standard_String;
13443 when N_Op_Concat =>
13445 L_Type : constant Entity_Id
13446 := Preferred_String_Type (Left_Opnd (Expr));
13447 R_Type : constant Entity_Id
13448 := Preferred_String_Type (Right_Opnd (Expr));
13450 Type_Table : constant array (1 .. 4) of Entity_Id
13452 Standard_Wide_Wide_String,
13453 Standard_Wide_String,
13456 for Idx in Type_Table'Range loop
13457 if L_Type = Type_Table (Idx) or
13458 R_Type = Type_Table (Idx)
13460 return Type_Table (Idx);
13463 raise Program_Error;
13469 end Preferred_String_Type;
13472 Check_At_Least_N_Arguments (1);
13474 Nam_Arg := Last (Pragma_Argument_Associations (N));
13476 -- Determine whether the last argument is "Entity => local_NAME"
13477 -- and if it is, perform the required semantic checks. Remove the
13478 -- argument from further processing.
13480 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
13481 and then Chars (Nam_Arg) = Name_Entity
13483 Check_Arg_Is_Local_Name (Nam_Arg);
13484 Arg_Count := Arg_Count - 1;
13486 -- A pragma that applies to a Ghost entity becomes Ghost for
13487 -- the purposes of legality checks and removal of ignored Ghost
13490 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
13491 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
13493 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
13497 -- Continue the processing with last argument removed for now
13499 Check_Arg_Is_Identifier (Arg1);
13500 Check_No_Identifiers;
13503 -- The second parameter is optional, it is never analyzed
13508 -- Otherwise there is a second parameter
13511 -- The second parameter must be an identifier
13513 Check_Arg_Is_Identifier (Arg2);
13515 -- Process the remaining parameters (if any)
13517 Arg := Next (Arg2);
13518 while Present (Arg) loop
13519 Expr := Get_Pragma_Arg (Arg);
13522 if Is_Entity_Name (Expr) then
13525 -- For string literals and concatenations of string literals
13526 -- we assume Standard_String as the type, unless the string
13527 -- contains wide or wide_wide characters.
13529 elsif Present (Preferred_String_Type (Expr)) then
13530 Resolve (Expr, Preferred_String_Type (Expr));
13532 elsif Is_Overloaded (Expr) then
13533 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
13544 -------------------------------------------------
13545 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13546 -------------------------------------------------
13549 -- ( [Check => ] Boolean_EXPRESSION
13550 -- [, [Message =>] Static_String_EXPRESSION]);
13552 -- pragma Assert_And_Cut
13553 -- ( [Check => ] Boolean_EXPRESSION
13554 -- [, [Message =>] Static_String_EXPRESSION]);
13557 -- ( [Check => ] Boolean_EXPRESSION
13558 -- [, [Message =>] Static_String_EXPRESSION]);
13560 -- pragma Loop_Invariant
13561 -- ( [Check => ] Boolean_EXPRESSION
13562 -- [, [Message =>] Static_String_EXPRESSION]);
13565 | Pragma_Assert_And_Cut
13567 | Pragma_Loop_Invariant
13570 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
13571 -- Determine whether expression Expr contains a Loop_Entry
13572 -- attribute reference.
13574 -------------------------
13575 -- Contains_Loop_Entry --
13576 -------------------------
13578 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
13579 Has_Loop_Entry : Boolean := False;
13581 function Process (N : Node_Id) return Traverse_Result;
13582 -- Process function for traversal to look for Loop_Entry
13588 function Process (N : Node_Id) return Traverse_Result is
13590 if Nkind (N) = N_Attribute_Reference
13591 and then Attribute_Name (N) = Name_Loop_Entry
13593 Has_Loop_Entry := True;
13600 procedure Traverse is new Traverse_Proc (Process);
13602 -- Start of processing for Contains_Loop_Entry
13606 return Has_Loop_Entry;
13607 end Contains_Loop_Entry;
13612 New_Args : List_Id;
13614 -- Start of processing for Assert
13617 -- Assert is an Ada 2005 RM-defined pragma
13619 if Prag_Id = Pragma_Assert then
13622 -- The remaining ones are GNAT pragmas
13628 Check_At_Least_N_Arguments (1);
13629 Check_At_Most_N_Arguments (2);
13630 Check_Arg_Order ((Name_Check, Name_Message));
13631 Check_Optional_Identifier (Arg1, Name_Check);
13632 Expr := Get_Pragma_Arg (Arg1);
13634 -- Special processing for Loop_Invariant, Loop_Variant or for
13635 -- other cases where a Loop_Entry attribute is present. If the
13636 -- assertion pragma contains attribute Loop_Entry, ensure that
13637 -- the related pragma is within a loop.
13639 if Prag_Id = Pragma_Loop_Invariant
13640 or else Prag_Id = Pragma_Loop_Variant
13641 or else Contains_Loop_Entry (Expr)
13643 Check_Loop_Pragma_Placement;
13645 -- Perform preanalysis to deal with embedded Loop_Entry
13648 Preanalyze_Assert_Expression (Expr, Any_Boolean);
13651 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13652 -- a corresponding Check pragma:
13654 -- pragma Check (name, condition [, msg]);
13656 -- Where name is the identifier matching the pragma name. So
13657 -- rewrite pragma in this manner, transfer the message argument
13658 -- if present, and analyze the result
13660 -- Note: When dealing with a semantically analyzed tree, the
13661 -- information that a Check node N corresponds to a source Assert,
13662 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13663 -- pragma kind of Original_Node(N).
13665 New_Args := New_List (
13666 Make_Pragma_Argument_Association (Loc,
13667 Expression => Make_Identifier (Loc, Pname)),
13668 Make_Pragma_Argument_Association (Sloc (Expr),
13669 Expression => Expr));
13671 if Arg_Count > 1 then
13672 Check_Optional_Identifier (Arg2, Name_Message);
13674 -- Provide semantic annotations for optional argument, for
13675 -- ASIS use, before rewriting.
13676 -- Is this still needed???
13678 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
13679 Append_To (New_Args, New_Copy_Tree (Arg2));
13682 -- Rewrite as Check pragma
13686 Chars => Name_Check,
13687 Pragma_Argument_Associations => New_Args));
13692 ----------------------
13693 -- Assertion_Policy --
13694 ----------------------
13696 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13698 -- The following form is Ada 2012 only, but we allow it in all modes
13700 -- Pragma Assertion_Policy (
13701 -- ASSERTION_KIND => POLICY_IDENTIFIER
13702 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13704 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13706 -- RM_ASSERTION_KIND ::= Assert |
13707 -- Static_Predicate |
13708 -- Dynamic_Predicate |
13713 -- Type_Invariant |
13714 -- Type_Invariant'Class |
13715 -- Default_Initial_Condition
13717 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13719 -- Contract_Cases |
13722 -- Initial_Condition |
13723 -- Loop_Invariant |
13729 -- Statement_Assertions |
13730 -- Subprogram_Variant
13732 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13733 -- ID_ASSERTION_KIND list contains implementation-defined additions
13734 -- recognized by GNAT. The effect is to control the behavior of
13735 -- identically named aspects and pragmas, depending on the specified
13736 -- policy identifier:
13738 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13740 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13741 -- implementation-defined addition that results in totally ignoring
13742 -- the corresponding assertion. If Disable is specified, then the
13743 -- argument of the assertion is not even analyzed. This is useful
13744 -- when the aspect/pragma argument references entities in a with'ed
13745 -- package that is replaced by a dummy package in the final build.
13747 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13748 -- and Type_Invariant'Class were recognized by the parser and
13749 -- transformed into references to the special internal identifiers
13750 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13751 -- processing is required here.
13753 when Pragma_Assertion_Policy => Assertion_Policy : declare
13754 procedure Resolve_Suppressible (Policy : Node_Id);
13755 -- Converts the assertion policy 'Suppressible' to either Check or
13756 -- Ignore based on whether checks are suppressed via -gnatp.
13758 --------------------------
13759 -- Resolve_Suppressible --
13760 --------------------------
13762 procedure Resolve_Suppressible (Policy : Node_Id) is
13763 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13767 -- Transform policy argument Suppressible into either Ignore or
13768 -- Check depending on whether checks are enabled or suppressed.
13770 if Chars (Arg) = Name_Suppressible then
13771 if Suppress_Checks then
13772 Nam := Name_Ignore;
13777 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13779 end Resolve_Suppressible;
13791 -- This can always appear as a configuration pragma
13793 if Is_Configuration_Pragma then
13796 -- It can also appear in a declarative part or package spec in Ada
13797 -- 2012 mode. We allow this in other modes, but in that case we
13798 -- consider that we have an Ada 2012 pragma on our hands.
13801 Check_Is_In_Decl_Part_Or_Package_Spec;
13805 -- One argument case with no identifier (first form above)
13808 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13809 or else Chars (Arg1) = No_Name)
13811 Check_Arg_Is_One_Of (Arg1,
13812 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13814 Resolve_Suppressible (Arg1);
13816 -- Treat one argument Assertion_Policy as equivalent to:
13818 -- pragma Check_Policy (Assertion, policy)
13820 -- So rewrite pragma in that manner and link on to the chain
13821 -- of Check_Policy pragmas, marking the pragma as analyzed.
13823 Policy := Get_Pragma_Arg (Arg1);
13827 Chars => Name_Check_Policy,
13828 Pragma_Argument_Associations => New_List (
13829 Make_Pragma_Argument_Association (Loc,
13830 Expression => Make_Identifier (Loc, Name_Assertion)),
13832 Make_Pragma_Argument_Association (Loc,
13834 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13837 -- Here if we have two or more arguments
13840 Check_At_Least_N_Arguments (1);
13843 -- Loop through arguments
13846 while Present (Arg) loop
13847 LocP := Sloc (Arg);
13849 -- Kind must be specified
13851 if Nkind (Arg) /= N_Pragma_Argument_Association
13852 or else Chars (Arg) = No_Name
13855 ("missing assertion kind for pragma%", Arg);
13858 -- Check Kind and Policy have allowed forms
13860 Kind := Chars (Arg);
13861 Policy := Get_Pragma_Arg (Arg);
13863 if not Is_Valid_Assertion_Kind (Kind) then
13865 ("invalid assertion kind for pragma%", Arg);
13868 Check_Arg_Is_One_Of (Arg,
13869 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13871 Resolve_Suppressible (Arg);
13873 if Kind = Name_Ghost then
13875 -- The Ghost policy must be either Check or Ignore
13876 -- (SPARK RM 6.9(6)).
13878 if Chars (Policy) not in Name_Check | Name_Ignore then
13880 ("argument of pragma % Ghost must be Check or "
13881 & "Ignore", Policy);
13884 -- Pragma Assertion_Policy specifying a Ghost policy
13885 -- cannot occur within a Ghost subprogram or package
13886 -- (SPARK RM 6.9(14)).
13888 if Ghost_Mode > None then
13890 ("pragma % cannot appear within ghost subprogram or "
13895 -- Rewrite the Assertion_Policy pragma as a series of
13896 -- Check_Policy pragmas of the form:
13898 -- Check_Policy (Kind, Policy);
13900 -- Note: the insertion of the pragmas cannot be done with
13901 -- Insert_Action because in the configuration case, there
13902 -- are no scopes on the scope stack and the mechanism will
13905 Insert_Before_And_Analyze (N,
13907 Chars => Name_Check_Policy,
13908 Pragma_Argument_Associations => New_List (
13909 Make_Pragma_Argument_Association (LocP,
13910 Expression => Make_Identifier (LocP, Kind)),
13911 Make_Pragma_Argument_Association (LocP,
13912 Expression => Policy))));
13917 -- Rewrite the Assertion_Policy pragma as null since we have
13918 -- now inserted all the equivalent Check pragmas.
13920 Rewrite (N, Make_Null_Statement (Loc));
13923 end Assertion_Policy;
13925 ------------------------------
13926 -- Assume_No_Invalid_Values --
13927 ------------------------------
13929 -- pragma Assume_No_Invalid_Values (On | Off);
13931 when Pragma_Assume_No_Invalid_Values =>
13933 Check_Valid_Configuration_Pragma;
13934 Check_Arg_Count (1);
13935 Check_No_Identifiers;
13936 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13938 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13939 Assume_No_Invalid_Values := True;
13941 Assume_No_Invalid_Values := False;
13944 --------------------------
13945 -- Attribute_Definition --
13946 --------------------------
13948 -- pragma Attribute_Definition
13949 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13950 -- [Entity =>] LOCAL_NAME,
13951 -- [Expression =>] EXPRESSION | NAME);
13953 when Pragma_Attribute_Definition => Attribute_Definition : declare
13954 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13959 Check_Arg_Count (3);
13960 Check_Optional_Identifier (Arg1, "attribute");
13961 Check_Optional_Identifier (Arg2, "entity");
13962 Check_Optional_Identifier (Arg3, "expression");
13964 if Nkind (Attribute_Designator) /= N_Identifier then
13965 Error_Msg_N ("attribute name expected", Attribute_Designator);
13969 Check_Arg_Is_Local_Name (Arg2);
13971 -- If the attribute is not recognized, then issue a warning (not
13972 -- an error), and ignore the pragma.
13974 Aname := Chars (Attribute_Designator);
13976 if not Is_Attribute_Name (Aname) then
13977 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13981 -- Otherwise, rewrite the pragma as an attribute definition clause
13984 Make_Attribute_Definition_Clause (Loc,
13985 Name => Get_Pragma_Arg (Arg2),
13987 Expression => Get_Pragma_Arg (Arg3)));
13989 end Attribute_Definition;
13991 ------------------------------------------------------------------
13992 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13994 ------------------------------------------------------------------
13996 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13997 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13998 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13999 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
14000 -- pragma No_Caching [ (boolean_EXPRESSION) ];
14002 when Pragma_Async_Readers
14003 | Pragma_Async_Writers
14004 | Pragma_Effective_Reads
14005 | Pragma_Effective_Writes
14006 | Pragma_No_Caching
14008 Async_Effective : declare
14009 Obj_Or_Type_Decl : Node_Id;
14010 Obj_Or_Type_Id : Entity_Id;
14013 Check_No_Identifiers;
14014 Check_At_Most_N_Arguments (1);
14016 Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
14018 -- Pragma must apply to a object declaration or to a type
14019 -- declaration. Original_Node is necessary to account for
14020 -- untagged derived types that are rewritten as subtypes of
14021 -- their respective root types.
14023 if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration
14024 and then Nkind (Original_Node (Obj_Or_Type_Decl)) not in
14025 N_Full_Type_Declaration |
14026 N_Private_Type_Declaration |
14027 N_Formal_Type_Declaration |
14028 N_Task_Type_Declaration |
14029 N_Protected_Type_Declaration
14034 Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
14036 -- Perform minimal verification to ensure that the argument is at
14037 -- least an object or a type. Subsequent finer grained checks will
14038 -- be done at the end of the declarative region that contains the
14041 if Ekind (Obj_Or_Type_Id) in E_Constant | E_Variable
14042 or else Is_Type (Obj_Or_Type_Id)
14045 -- In the case of a type, pragma is a type-related
14046 -- representation item and so requires checks common to
14047 -- all type-related representation items.
14049 if Is_Type (Obj_Or_Type_Id)
14050 and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
14055 -- A pragma that applies to a Ghost entity becomes Ghost for
14056 -- the purposes of legality checks and removal of ignored Ghost
14059 Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
14061 -- Chain the pragma on the contract for further processing by
14062 -- Analyze_External_Property_In_Decl_Part.
14064 Add_Contract_Item (N, Obj_Or_Type_Id);
14066 -- Analyze the Boolean expression (if any)
14068 if Present (Arg1) then
14069 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14072 -- Otherwise the external property applies to a constant
14076 ("pragma % must apply to a volatile type or object");
14078 end Async_Effective;
14084 -- pragma Asynchronous (LOCAL_NAME);
14086 when Pragma_Asynchronous => Asynchronous : declare
14089 Formal : Entity_Id;
14094 procedure Process_Async_Pragma;
14095 -- Common processing for procedure and access-to-procedure case
14097 --------------------------
14098 -- Process_Async_Pragma --
14099 --------------------------
14101 procedure Process_Async_Pragma is
14104 Set_Is_Asynchronous (Nm);
14108 -- The formals should be of mode IN (RM E.4.1(6))
14111 while Present (S) loop
14112 Formal := Defining_Identifier (S);
14114 if Nkind (Formal) = N_Defining_Identifier
14115 and then Ekind (Formal) /= E_In_Parameter
14118 ("pragma% procedure can only have IN parameter",
14125 Set_Is_Asynchronous (Nm);
14126 end Process_Async_Pragma;
14128 -- Start of processing for pragma Asynchronous
14131 Check_Ada_83_Warning;
14132 Check_No_Identifiers;
14133 Check_Arg_Count (1);
14134 Check_Arg_Is_Local_Name (Arg1);
14136 if Debug_Flag_U then
14140 C_Ent := Cunit_Entity (Current_Sem_Unit);
14141 Analyze (Get_Pragma_Arg (Arg1));
14142 Nm := Entity (Get_Pragma_Arg (Arg1));
14144 -- A pragma that applies to a Ghost entity becomes Ghost for the
14145 -- purposes of legality checks and removal of ignored Ghost code.
14147 Mark_Ghost_Pragma (N, Nm);
14149 if not Is_Remote_Call_Interface (C_Ent)
14150 and then not Is_Remote_Types (C_Ent)
14152 -- This pragma should only appear in an RCI or Remote Types
14153 -- unit (RM E.4.1(4)).
14156 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
14159 if Ekind (Nm) = E_Procedure
14160 and then Nkind (Parent (Nm)) = N_Procedure_Specification
14162 if not Is_Remote_Call_Interface (Nm) then
14164 ("pragma% cannot be applied on non-remote procedure",
14168 L := Parameter_Specifications (Parent (Nm));
14169 Process_Async_Pragma;
14172 elsif Ekind (Nm) = E_Function then
14174 ("pragma% cannot be applied to function", Arg1);
14176 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
14177 if Is_Record_Type (Nm) then
14179 -- A record type that is the Equivalent_Type for a remote
14180 -- access-to-subprogram type.
14182 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
14185 -- A non-expanded RAS type (distribution is not enabled)
14187 Decl := Declaration_Node (Nm);
14190 if Nkind (Decl) = N_Full_Type_Declaration
14191 and then Nkind (Type_Definition (Decl)) =
14192 N_Access_Procedure_Definition
14194 L := Parameter_Specifications (Type_Definition (Decl));
14195 Process_Async_Pragma;
14197 if Is_Asynchronous (Nm)
14198 and then Expander_Active
14199 and then Get_PCS_Name /= Name_No_DSA
14201 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
14206 ("pragma% cannot reference access-to-function type",
14210 -- Only other possibility is access-to-class-wide type
14212 elsif Is_Access_Type (Nm)
14213 and then Is_Class_Wide_Type (Designated_Type (Nm))
14215 Check_First_Subtype (Arg1);
14216 Set_Is_Asynchronous (Nm);
14217 if Expander_Active then
14218 RACW_Type_Is_Asynchronous (Nm);
14222 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
14230 -- pragma Atomic (LOCAL_NAME);
14232 when Pragma_Atomic =>
14233 Process_Atomic_Independent_Shared_Volatile;
14235 -----------------------
14236 -- Atomic_Components --
14237 -----------------------
14239 -- pragma Atomic_Components (array_LOCAL_NAME);
14241 -- This processing is shared by Volatile_Components
14243 when Pragma_Atomic_Components
14244 | Pragma_Volatile_Components
14246 Atomic_Components : declare
14252 Check_Ada_83_Warning;
14253 Check_No_Identifiers;
14254 Check_Arg_Count (1);
14255 Check_Arg_Is_Local_Name (Arg1);
14256 E_Id := Get_Pragma_Arg (Arg1);
14258 if Etype (E_Id) = Any_Type then
14262 E := Entity (E_Id);
14264 -- A pragma that applies to a Ghost entity becomes Ghost for the
14265 -- purposes of legality checks and removal of ignored Ghost code.
14267 Mark_Ghost_Pragma (N, E);
14268 Check_Duplicate_Pragma (E);
14270 if Rep_Item_Too_Early (E, N)
14272 Rep_Item_Too_Late (E, N)
14277 D := Declaration_Node (E);
14279 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
14281 (Nkind (D) = N_Object_Declaration
14282 and then Ekind (E) in E_Constant | E_Variable
14283 and then Nkind (Object_Definition (D)) =
14284 N_Constrained_Array_Definition)
14286 (Ada_Version >= Ada_2022
14287 and then Nkind (D) = N_Formal_Type_Declaration)
14289 -- The flag is set on the base type, or on the object
14291 if Nkind (D) = N_Full_Type_Declaration then
14292 E := Base_Type (E);
14295 -- Atomic implies both Independent and Volatile
14297 if Prag_Id = Pragma_Atomic_Components then
14298 Set_Has_Atomic_Components (E);
14299 Set_Has_Independent_Components (E);
14302 Set_Has_Volatile_Components (E);
14305 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
14307 end Atomic_Components;
14309 --------------------
14310 -- Attach_Handler --
14311 --------------------
14313 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
14315 when Pragma_Attach_Handler =>
14316 Check_Ada_83_Warning;
14317 Check_No_Identifiers;
14318 Check_Arg_Count (2);
14320 if No_Run_Time_Mode then
14321 Error_Msg_CRT ("Attach_Handler pragma", N);
14323 Check_Interrupt_Or_Attach_Handler;
14325 -- The expression that designates the attribute may depend on a
14326 -- discriminant, and is therefore a per-object expression, to
14327 -- be expanded in the init proc. If expansion is enabled, then
14328 -- perform semantic checks on a copy only.
14333 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
14336 -- In Relaxed_RM_Semantics mode, we allow any static
14337 -- integer value, for compatibility with other compilers.
14339 if Relaxed_RM_Semantics
14340 and then Nkind (Parg2) = N_Integer_Literal
14342 Typ := Standard_Integer;
14344 Typ := RTE (RE_Interrupt_ID);
14347 if Expander_Active then
14348 Temp := New_Copy_Tree (Parg2);
14349 Set_Parent (Temp, N);
14350 Preanalyze_And_Resolve (Temp, Typ);
14353 Resolve (Parg2, Typ);
14357 Process_Interrupt_Or_Attach_Handler;
14360 --------------------
14361 -- C_Pass_By_Copy --
14362 --------------------
14364 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
14366 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
14372 Check_Valid_Configuration_Pragma;
14373 Check_Arg_Count (1);
14374 Check_Optional_Identifier (Arg1, "max_size");
14376 Arg := Get_Pragma_Arg (Arg1);
14377 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
14379 Val := Expr_Value (Arg);
14383 ("maximum size for pragma% must be positive", Arg1);
14385 elsif UI_Is_In_Int_Range (Val) then
14386 Default_C_Record_Mechanism := UI_To_Int (Val);
14388 -- If a giant value is given, Int'Last will do well enough.
14389 -- If sometime someone complains that a record larger than
14390 -- two gigabytes is not copied, we will worry about it then.
14393 Default_C_Record_Mechanism := Mechanism_Type'Last;
14395 end C_Pass_By_Copy;
14401 -- pragma Check ([Name =>] CHECK_KIND,
14402 -- [Check =>] Boolean_EXPRESSION
14403 -- [,[Message =>] String_EXPRESSION]);
14405 -- CHECK_KIND ::= IDENTIFIER |
14408 -- Invariant'Class |
14409 -- Type_Invariant'Class
14411 -- The identifiers Assertions and Statement_Assertions are not
14412 -- allowed, since they have special meaning for Check_Policy.
14414 -- WARNING: The code below manages Ghost regions. Return statements
14415 -- must be replaced by gotos which jump to the end of the code and
14416 -- restore the Ghost mode.
14418 when Pragma_Check => Check : declare
14419 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
14420 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
14421 -- Save the Ghost-related attributes to restore on exit
14427 pragma Warnings (Off, Str);
14430 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14431 -- the mode now to ensure that any nodes generated during analysis
14432 -- and expansion are marked as Ghost.
14434 Set_Ghost_Mode (N);
14437 Check_At_Least_N_Arguments (2);
14438 Check_At_Most_N_Arguments (3);
14439 Check_Optional_Identifier (Arg1, Name_Name);
14440 Check_Optional_Identifier (Arg2, Name_Check);
14442 if Arg_Count = 3 then
14443 Check_Optional_Identifier (Arg3, Name_Message);
14444 Str := Get_Pragma_Arg (Arg3);
14447 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
14448 Check_Arg_Is_Identifier (Arg1);
14449 Cname := Chars (Get_Pragma_Arg (Arg1));
14451 -- Check forbidden name Assertions or Statement_Assertions
14454 when Name_Assertions =>
14456 ("""Assertions"" is not allowed as a check kind for "
14457 & "pragma%", Arg1);
14459 when Name_Statement_Assertions =>
14461 ("""Statement_Assertions"" is not allowed as a check kind "
14462 & "for pragma%", Arg1);
14468 -- Check applicable policy. We skip this if Checked/Ignored status
14469 -- is already set (e.g. in the case of a pragma from an aspect).
14471 if Is_Checked (N) or else Is_Ignored (N) then
14474 -- For a non-source pragma that is a rewriting of another pragma,
14475 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14477 elsif Is_Rewrite_Substitution (N)
14478 and then Nkind (Original_Node (N)) = N_Pragma
14480 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
14481 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
14483 -- Otherwise query the applicable policy at this point
14486 case Check_Kind (Cname) is
14487 when Name_Ignore =>
14488 Set_Is_Ignored (N, True);
14489 Set_Is_Checked (N, False);
14492 Set_Is_Ignored (N, False);
14493 Set_Is_Checked (N, True);
14495 -- For disable, rewrite pragma as null statement and skip
14496 -- rest of the analysis of the pragma.
14498 when Name_Disable =>
14499 Rewrite (N, Make_Null_Statement (Loc));
14503 -- No other possibilities
14506 raise Program_Error;
14510 -- If check kind was not Disable, then continue pragma analysis
14512 Expr := Get_Pragma_Arg (Arg2);
14514 -- Mark the pragma (or, if rewritten from an aspect, the original
14515 -- aspect) as enabled. Nothing to do for an internally generated
14516 -- check for a dynamic predicate.
14519 and then not Split_PPC (N)
14520 and then Cname /= Name_Dynamic_Predicate
14522 Set_SCO_Pragma_Enabled (Loc);
14525 -- Deal with analyzing the string argument. If checks are not
14526 -- on we don't want any expansion (since such expansion would
14527 -- not get properly deleted) but we do want to analyze (to get
14528 -- proper references). The Preanalyze_And_Resolve routine does
14529 -- just what we want. Ditto if pragma is active, because it will
14530 -- be rewritten as an if-statement whose analysis will complete
14531 -- analysis and expansion of the string message. This makes a
14532 -- difference in the unusual case where the expression for the
14533 -- string may have a side effect, such as raising an exception.
14534 -- This is mandated by RM 11.4.2, which specifies that the string
14535 -- expression is only evaluated if the check fails and
14536 -- Assertion_Error is to be raised.
14538 if Arg_Count = 3 then
14539 Preanalyze_And_Resolve (Str, Standard_String);
14542 -- Now you might think we could just do the same with the Boolean
14543 -- expression if checks are off (and expansion is on) and then
14544 -- rewrite the check as a null statement. This would work but we
14545 -- would lose the useful warnings about an assertion being bound
14546 -- to fail even if assertions are turned off.
14548 -- So instead we wrap the boolean expression in an if statement
14549 -- that looks like:
14551 -- if False and then condition then
14555 -- The reason we do this rewriting during semantic analysis rather
14556 -- than as part of normal expansion is that we cannot analyze and
14557 -- expand the code for the boolean expression directly, or it may
14558 -- cause insertion of actions that would escape the attempt to
14559 -- suppress the check code.
14561 -- Note that the Sloc for the if statement corresponds to the
14562 -- argument condition, not the pragma itself. The reason for
14563 -- this is that we may generate a warning if the condition is
14564 -- False at compile time, and we do not want to delete this
14565 -- warning when we delete the if statement.
14567 if Expander_Active and Is_Ignored (N) then
14568 Eloc := Sloc (Expr);
14571 Make_If_Statement (Eloc,
14573 Make_And_Then (Eloc,
14574 Left_Opnd => Make_Identifier (Eloc, Name_False),
14575 Right_Opnd => Expr),
14576 Then_Statements => New_List (
14577 Make_Null_Statement (Eloc))));
14579 -- Now go ahead and analyze the if statement
14581 In_Assertion_Expr := In_Assertion_Expr + 1;
14583 -- One rather special treatment. If we are now in Eliminated
14584 -- overflow mode, then suppress overflow checking since we do
14585 -- not want to drag in the bignum stuff if we are in Ignore
14586 -- mode anyway. This is particularly important if we are using
14587 -- a configurable run time that does not support bignum ops.
14589 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
14591 Svo : constant Boolean :=
14592 Scope_Suppress.Suppress (Overflow_Check);
14594 Scope_Suppress.Overflow_Mode_Assertions := Strict;
14595 Scope_Suppress.Suppress (Overflow_Check) := True;
14597 Scope_Suppress.Suppress (Overflow_Check) := Svo;
14598 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
14601 -- Not that special case
14607 -- All done with this check
14609 In_Assertion_Expr := In_Assertion_Expr - 1;
14611 -- Check is active or expansion not active. In these cases we can
14612 -- just go ahead and analyze the boolean with no worries.
14615 In_Assertion_Expr := In_Assertion_Expr + 1;
14616 Analyze_And_Resolve (Expr, Any_Boolean);
14617 In_Assertion_Expr := In_Assertion_Expr - 1;
14620 Restore_Ghost_Region (Saved_GM, Saved_IGR);
14623 --------------------------
14624 -- Check_Float_Overflow --
14625 --------------------------
14627 -- pragma Check_Float_Overflow;
14629 when Pragma_Check_Float_Overflow =>
14631 Check_Valid_Configuration_Pragma;
14632 Check_Arg_Count (0);
14633 Check_Float_Overflow := not Machine_Overflows_On_Target;
14639 -- pragma Check_Name (check_IDENTIFIER);
14641 when Pragma_Check_Name =>
14643 Check_No_Identifiers;
14644 Check_Valid_Configuration_Pragma;
14645 Check_Arg_Count (1);
14646 Check_Arg_Is_Identifier (Arg1);
14649 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
14652 for J in Check_Names.First .. Check_Names.Last loop
14653 if Check_Names.Table (J) = Nam then
14658 Check_Names.Append (Nam);
14665 -- This is the old style syntax, which is still allowed in all modes:
14667 -- pragma Check_Policy ([Name =>] CHECK_KIND
14668 -- [Policy =>] POLICY_IDENTIFIER);
14670 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14672 -- CHECK_KIND ::= IDENTIFIER |
14675 -- Type_Invariant'Class |
14678 -- This is the new style syntax, compatible with Assertion_Policy
14679 -- and also allowed in all modes.
14681 -- Pragma Check_Policy (
14682 -- CHECK_KIND => POLICY_IDENTIFIER
14683 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14685 -- Note: the identifiers Name and Policy are not allowed as
14686 -- Check_Kind values. This avoids ambiguities between the old and
14687 -- new form syntax.
14689 when Pragma_Check_Policy => Check_Policy : declare
14694 Check_At_Least_N_Arguments (1);
14696 -- A Check_Policy pragma can appear either as a configuration
14697 -- pragma, or in a declarative part or a package spec (see RM
14698 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14699 -- followed for Check_Policy).
14701 if not Is_Configuration_Pragma then
14702 Check_Is_In_Decl_Part_Or_Package_Spec;
14705 -- Figure out if we have the old or new syntax. We have the
14706 -- old syntax if the first argument has no identifier, or the
14707 -- identifier is Name.
14709 if Nkind (Arg1) /= N_Pragma_Argument_Association
14710 or else Chars (Arg1) in No_Name | Name_Name
14714 Check_Arg_Count (2);
14715 Check_Optional_Identifier (Arg1, Name_Name);
14716 Kind := Get_Pragma_Arg (Arg1);
14717 Rewrite_Assertion_Kind (Kind,
14718 From_Policy => Comes_From_Source (N));
14719 Check_Arg_Is_Identifier (Arg1);
14721 -- Check forbidden check kind
14723 if Chars (Kind) in Name_Name | Name_Policy then
14724 Error_Msg_Name_2 := Chars (Kind);
14726 ("pragma% does not allow% as check name", Arg1);
14731 Check_Optional_Identifier (Arg2, Name_Policy);
14732 Check_Arg_Is_One_Of
14734 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14736 -- And chain pragma on the Check_Policy_List for search
14738 Set_Next_Pragma (N, Opt.Check_Policy_List);
14739 Opt.Check_Policy_List := N;
14741 -- For the new syntax, what we do is to convert each argument to
14742 -- an old syntax equivalent. We do that because we want to chain
14743 -- old style Check_Policy pragmas for the search (we don't want
14744 -- to have to deal with multiple arguments in the search).
14755 while Present (Arg) loop
14756 LocP := Sloc (Arg);
14757 Argx := Get_Pragma_Arg (Arg);
14759 -- Kind must be specified
14761 if Nkind (Arg) /= N_Pragma_Argument_Association
14762 or else Chars (Arg) = No_Name
14765 ("missing assertion kind for pragma%", Arg);
14768 -- Construct equivalent old form syntax Check_Policy
14769 -- pragma and insert it to get remaining checks.
14773 Chars => Name_Check_Policy,
14774 Pragma_Argument_Associations => New_List (
14775 Make_Pragma_Argument_Association (LocP,
14777 Make_Identifier (LocP, Chars (Arg))),
14778 Make_Pragma_Argument_Association (Sloc (Argx),
14779 Expression => Argx)));
14783 -- For a configuration pragma, insert old form in
14784 -- the corresponding file.
14786 if Is_Configuration_Pragma then
14787 Insert_After (N, New_P);
14791 Insert_Action (N, New_P);
14795 -- Rewrite original Check_Policy pragma to null, since we
14796 -- have converted it into a series of old syntax pragmas.
14798 Rewrite (N, Make_Null_Statement (Loc));
14808 -- pragma Comment (static_string_EXPRESSION)
14810 -- Processing for pragma Comment shares the circuitry for pragma
14811 -- Ident. The only differences are that Ident enforces a limit of 31
14812 -- characters on its argument, and also enforces limitations on
14813 -- placement for DEC compatibility. Pragma Comment shares neither of
14814 -- these restrictions.
14816 -------------------
14817 -- Common_Object --
14818 -------------------
14820 -- pragma Common_Object (
14821 -- [Internal =>] LOCAL_NAME
14822 -- [, [External =>] EXTERNAL_SYMBOL]
14823 -- [, [Size =>] EXTERNAL_SYMBOL]);
14825 -- Processing for this pragma is shared with Psect_Object
14827 ----------------------------------------------
14828 -- Compile_Time_Error, Compile_Time_Warning --
14829 ----------------------------------------------
14831 -- pragma Compile_Time_Error
14832 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14834 -- pragma Compile_Time_Warning
14835 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14837 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14840 Process_Compile_Time_Warning_Or_Error;
14842 -----------------------------
14843 -- Complete_Representation --
14844 -----------------------------
14846 -- pragma Complete_Representation;
14848 when Pragma_Complete_Representation =>
14850 Check_Arg_Count (0);
14852 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14854 ("pragma & must appear within record representation clause");
14857 ----------------------------
14858 -- Complex_Representation --
14859 ----------------------------
14861 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14863 when Pragma_Complex_Representation => Complex_Representation : declare
14870 Check_Arg_Count (1);
14871 Check_Optional_Identifier (Arg1, Name_Entity);
14872 Check_Arg_Is_Local_Name (Arg1);
14873 E_Id := Get_Pragma_Arg (Arg1);
14875 if Etype (E_Id) = Any_Type then
14879 E := Entity (E_Id);
14881 if not Is_Record_Type (E) then
14883 ("argument for pragma% must be record type", Arg1);
14886 Ent := First_Entity (E);
14889 or else No (Next_Entity (Ent))
14890 or else Present (Next_Entity (Next_Entity (Ent)))
14891 or else not Is_Floating_Point_Type (Etype (Ent))
14892 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14895 ("record for pragma% must have two fields of the same "
14896 & "floating-point type", Arg1);
14899 Set_Has_Complex_Representation (Base_Type (E));
14901 -- We need to treat the type has having a non-standard
14902 -- representation, for back-end purposes, even though in
14903 -- general a complex will have the default representation
14904 -- of a record with two real components.
14906 Set_Has_Non_Standard_Rep (Base_Type (E));
14908 end Complex_Representation;
14910 -------------------------
14911 -- Component_Alignment --
14912 -------------------------
14914 -- pragma Component_Alignment (
14915 -- [Form =>] ALIGNMENT_CHOICE
14916 -- [, [Name =>] type_LOCAL_NAME]);
14918 -- ALIGNMENT_CHOICE ::=
14920 -- | Component_Size_4
14924 when Pragma_Component_Alignment => Component_AlignmentP : declare
14925 Args : Args_List (1 .. 2);
14926 Names : constant Name_List (1 .. 2) := (
14930 Form : Node_Id renames Args (1);
14931 Name : Node_Id renames Args (2);
14933 Atype : Component_Alignment_Kind;
14938 Gather_Associations (Names, Args);
14941 Error_Pragma ("missing Form argument for pragma%");
14944 Check_Arg_Is_Identifier (Form);
14946 -- Get proper alignment, note that Default = Component_Size on all
14947 -- machines we have so far, and we want to set this value rather
14948 -- than the default value to indicate that it has been explicitly
14949 -- set (and thus will not get overridden by the default component
14950 -- alignment for the current scope)
14952 if Chars (Form) = Name_Component_Size then
14953 Atype := Calign_Component_Size;
14955 elsif Chars (Form) = Name_Component_Size_4 then
14956 Atype := Calign_Component_Size_4;
14958 elsif Chars (Form) = Name_Default then
14959 Atype := Calign_Component_Size;
14961 elsif Chars (Form) = Name_Storage_Unit then
14962 Atype := Calign_Storage_Unit;
14966 ("invalid Form parameter for pragma%", Form);
14969 -- The pragma appears in a configuration file
14971 if No (Parent (N)) then
14972 Check_Valid_Configuration_Pragma;
14974 -- Capture the component alignment in a global variable when
14975 -- the pragma appears in a configuration file. Note that the
14976 -- scope stack is empty at this point and cannot be used to
14977 -- store the alignment value.
14979 Configuration_Component_Alignment := Atype;
14981 -- Case with no name, supplied, affects scope table entry
14983 elsif No (Name) then
14985 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14987 -- Case of name supplied
14990 Check_Arg_Is_Local_Name (Name);
14992 Typ := Entity (Name);
14995 or else Rep_Item_Too_Early (Typ, N)
14999 Typ := Underlying_Type (Typ);
15002 if not Is_Record_Type (Typ)
15003 and then not Is_Array_Type (Typ)
15006 ("Name parameter of pragma% must identify record or "
15007 & "array type", Name);
15010 -- An explicit Component_Alignment pragma overrides an
15011 -- implicit pragma Pack, but not an explicit one.
15013 if not Has_Pragma_Pack (Base_Type (Typ)) then
15014 Set_Is_Packed (Base_Type (Typ), False);
15015 Set_Component_Alignment (Base_Type (Typ), Atype);
15018 end Component_AlignmentP;
15020 --------------------------------
15021 -- Constant_After_Elaboration --
15022 --------------------------------
15024 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
15026 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
15028 Obj_Decl : Node_Id;
15029 Obj_Id : Entity_Id;
15033 Check_No_Identifiers;
15034 Check_At_Most_N_Arguments (1);
15036 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
15038 if Nkind (Obj_Decl) /= N_Object_Declaration then
15042 Obj_Id := Defining_Entity (Obj_Decl);
15044 -- The object declaration must be a library-level variable which
15045 -- is either explicitly initialized or obtains a value during the
15046 -- elaboration of a package body (SPARK RM 3.3.1).
15048 if Ekind (Obj_Id) = E_Variable then
15049 if not Is_Library_Level_Entity (Obj_Id) then
15051 ("pragma % must apply to a library level variable");
15054 -- Otherwise the pragma applies to a constant, which is illegal
15057 Error_Pragma ("pragma % must apply to a variable declaration");
15060 -- A pragma that applies to a Ghost entity becomes Ghost for the
15061 -- purposes of legality checks and removal of ignored Ghost code.
15063 Mark_Ghost_Pragma (N, Obj_Id);
15065 -- Chain the pragma on the contract for completeness
15067 Add_Contract_Item (N, Obj_Id);
15069 -- Analyze the Boolean expression (if any)
15071 if Present (Arg1) then
15072 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
15074 end Constant_After_Elaboration;
15076 --------------------
15077 -- Contract_Cases --
15078 --------------------
15080 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
15082 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
15084 -- CASE_GUARD ::= boolean_EXPRESSION | others
15086 -- CONSEQUENCE ::= boolean_EXPRESSION
15088 -- Characteristics:
15090 -- * Analysis - The annotation undergoes initial checks to verify
15091 -- the legal placement and context. Secondary checks preanalyze the
15094 -- Analyze_Contract_Cases_In_Decl_Part
15096 -- * Expansion - The annotation is expanded during the expansion of
15097 -- the related subprogram [body] contract as performed in:
15099 -- Expand_Subprogram_Contract
15101 -- * Template - The annotation utilizes the generic template of the
15102 -- related subprogram [body] when it is:
15104 -- aspect on subprogram declaration
15105 -- aspect on stand-alone subprogram body
15106 -- pragma on stand-alone subprogram body
15108 -- The annotation must prepare its own template when it is:
15110 -- pragma on subprogram declaration
15112 -- * Globals - Capture of global references must occur after full
15115 -- * Instance - The annotation is instantiated automatically when
15116 -- the related generic subprogram [body] is instantiated except for
15117 -- the "pragma on subprogram declaration" case. In that scenario
15118 -- the annotation must instantiate itself.
15120 when Pragma_Contract_Cases => Contract_Cases : declare
15121 Spec_Id : Entity_Id;
15122 Subp_Decl : Node_Id;
15123 Subp_Spec : Node_Id;
15127 Check_No_Identifiers;
15128 Check_Arg_Count (1);
15130 -- Ensure the proper placement of the pragma. Contract_Cases must
15131 -- be associated with a subprogram declaration or a body that acts
15135 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15139 if Nkind (Subp_Decl) = N_Entry_Declaration then
15142 -- Generic subprogram
15144 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15147 -- Body acts as spec
15149 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15150 and then No (Corresponding_Spec (Subp_Decl))
15154 -- Body stub acts as spec
15156 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15157 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15163 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15164 Subp_Spec := Specification (Subp_Decl);
15166 -- Pragma Contract_Cases is forbidden on null procedures, as
15167 -- this may lead to potential ambiguities in behavior when
15168 -- interface null procedures are involved.
15170 if Nkind (Subp_Spec) = N_Procedure_Specification
15171 and then Null_Present (Subp_Spec)
15173 Error_Msg_N (Fix_Error
15174 ("pragma % cannot apply to null procedure"), N);
15182 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15184 -- A pragma that applies to a Ghost entity becomes Ghost for the
15185 -- purposes of legality checks and removal of ignored Ghost code.
15187 Mark_Ghost_Pragma (N, Spec_Id);
15188 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
15190 -- Chain the pragma on the contract for further processing by
15191 -- Analyze_Contract_Cases_In_Decl_Part.
15193 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15195 -- Fully analyze the pragma when it appears inside an entry
15196 -- or subprogram body because it cannot benefit from forward
15199 if Nkind (Subp_Decl) in N_Entry_Body
15200 | N_Subprogram_Body
15201 | N_Subprogram_Body_Stub
15203 -- The legality checks of pragma Contract_Cases are affected by
15204 -- the SPARK mode in effect and the volatility of the context.
15205 -- Analyze all pragmas in a specific order.
15207 Analyze_If_Present (Pragma_SPARK_Mode);
15208 Analyze_If_Present (Pragma_Volatile_Function);
15209 Analyze_Contract_Cases_In_Decl_Part (N);
15211 end Contract_Cases;
15217 -- pragma Controlled (first_subtype_LOCAL_NAME);
15219 when Pragma_Controlled => Controlled : declare
15223 Check_No_Identifiers;
15224 Check_Arg_Count (1);
15225 Check_Arg_Is_Local_Name (Arg1);
15226 Arg := Get_Pragma_Arg (Arg1);
15228 if not Is_Entity_Name (Arg)
15229 or else not Is_Access_Type (Entity (Arg))
15231 Error_Pragma_Arg ("pragma% requires access type", Arg1);
15233 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
15241 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
15242 -- [Entity =>] LOCAL_NAME);
15244 when Pragma_Convention => Convention : declare
15247 pragma Warnings (Off, C);
15248 pragma Warnings (Off, E);
15251 Check_Arg_Order ((Name_Convention, Name_Entity));
15252 Check_Ada_83_Warning;
15253 Check_Arg_Count (2);
15254 Process_Convention (C, E);
15256 -- A pragma that applies to a Ghost entity becomes Ghost for the
15257 -- purposes of legality checks and removal of ignored Ghost code.
15259 Mark_Ghost_Pragma (N, E);
15262 ---------------------------
15263 -- Convention_Identifier --
15264 ---------------------------
15266 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
15267 -- [Convention =>] convention_IDENTIFIER);
15269 when Pragma_Convention_Identifier => Convention_Identifier : declare
15275 Check_Arg_Order ((Name_Name, Name_Convention));
15276 Check_Arg_Count (2);
15277 Check_Optional_Identifier (Arg1, Name_Name);
15278 Check_Optional_Identifier (Arg2, Name_Convention);
15279 Check_Arg_Is_Identifier (Arg1);
15280 Check_Arg_Is_Identifier (Arg2);
15281 Idnam := Chars (Get_Pragma_Arg (Arg1));
15282 Cname := Chars (Get_Pragma_Arg (Arg2));
15284 if Is_Convention_Name (Cname) then
15285 Record_Convention_Identifier
15286 (Idnam, Get_Convention_Id (Cname));
15289 ("second arg for % pragma must be convention", Arg2);
15291 end Convention_Identifier;
15297 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
15299 when Pragma_CPP_Class =>
15302 if Warn_On_Obsolescent_Feature then
15304 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
15305 & "effect; replace it by pragma import?j?", N);
15308 Check_Arg_Count (1);
15312 Chars => Name_Import,
15313 Pragma_Argument_Associations => New_List (
15314 Make_Pragma_Argument_Association (Loc,
15315 Expression => Make_Identifier (Loc, Name_CPP)),
15316 New_Copy (First (Pragma_Argument_Associations (N))))));
15319 ---------------------
15320 -- CPP_Constructor --
15321 ---------------------
15323 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
15324 -- [, [External_Name =>] static_string_EXPRESSION ]
15325 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15327 when Pragma_CPP_Constructor => CPP_Constructor : declare
15329 Def_Id : Entity_Id;
15330 Tag_Typ : Entity_Id;
15334 Check_At_Least_N_Arguments (1);
15335 Check_At_Most_N_Arguments (3);
15336 Check_Optional_Identifier (Arg1, Name_Entity);
15337 Check_Arg_Is_Local_Name (Arg1);
15339 Id := Get_Pragma_Arg (Arg1);
15340 Find_Program_Unit_Name (Id);
15342 -- If we did not find the name, we are done
15344 if Etype (Id) = Any_Type then
15348 Def_Id := Entity (Id);
15350 -- Check if already defined as constructor
15352 if Is_Constructor (Def_Id) then
15354 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
15358 if Ekind (Def_Id) = E_Function
15359 and then (Is_CPP_Class (Etype (Def_Id))
15360 or else (Is_Class_Wide_Type (Etype (Def_Id))
15362 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
15364 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
15366 ("'C'P'P constructor must be defined in the scope of "
15367 & "its returned type", Arg1);
15370 if Arg_Count >= 2 then
15371 Set_Imported (Def_Id);
15372 Set_Is_Public (Def_Id);
15373 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
15376 Set_Has_Completion (Def_Id);
15377 Set_Is_Constructor (Def_Id);
15378 Set_Convention (Def_Id, Convention_CPP);
15380 -- Imported C++ constructors are not dispatching primitives
15381 -- because in C++ they don't have a dispatch table slot.
15382 -- However, in Ada the constructor has the profile of a
15383 -- function that returns a tagged type and therefore it has
15384 -- been treated as a primitive operation during semantic
15385 -- analysis. We now remove it from the list of primitive
15386 -- operations of the type.
15388 if Is_Tagged_Type (Etype (Def_Id))
15389 and then not Is_Class_Wide_Type (Etype (Def_Id))
15390 and then Is_Dispatching_Operation (Def_Id)
15392 Tag_Typ := Etype (Def_Id);
15394 Remove (Primitive_Operations (Tag_Typ), Def_Id);
15395 Set_Is_Dispatching_Operation (Def_Id, False);
15398 -- For backward compatibility, if the constructor returns a
15399 -- class wide type, and we internally change the return type to
15400 -- the corresponding root type.
15402 if Is_Class_Wide_Type (Etype (Def_Id)) then
15403 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
15407 ("pragma% requires function returning a 'C'P'P_Class type",
15410 end CPP_Constructor;
15416 when Pragma_CPP_Virtual =>
15419 if Warn_On_Obsolescent_Feature then
15421 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15429 when Pragma_CUDA_Device => CUDA_Device : declare
15430 Arg_Node : Node_Id;
15431 Device_Entity : Entity_Id;
15434 Check_Arg_Count (1);
15435 Check_Arg_Is_Library_Level_Local_Name (Arg1);
15437 Arg_Node := Get_Pragma_Arg (Arg1);
15438 Device_Entity := Entity (Arg_Node);
15440 if Ekind (Device_Entity) in E_Variable
15445 Add_CUDA_Device_Entity
15446 (Package_Specification_Of_Scope (Scope (Device_Entity)),
15450 Error_Msg_NE ("& must be constant, variable or subprogram",
15461 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
15465 -- [, EXPRESSION]]);
15467 when Pragma_CUDA_Execute => CUDA_Execute : declare
15469 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
15470 -- Returns True if N is an acceptable argument for CUDA_Execute,
15471 -- False otherwise.
15473 ------------------------
15474 -- Is_Acceptable_Dim3 --
15475 ------------------------
15477 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
15480 if Is_RTE (Etype (N), RE_Dim3)
15481 or else Is_Integer_Type (Etype (N))
15486 if Nkind (N) = N_Aggregate
15487 and then not Null_Record_Present (N)
15488 and then No (Component_Associations (N))
15489 and then List_Length (Expressions (N)) = 3
15491 Expr := First (Expressions (N));
15492 while Present (Expr) loop
15493 Analyze_And_Resolve (Expr, Any_Integer);
15500 end Is_Acceptable_Dim3;
15504 Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
15505 Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
15506 Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
15507 Shared_Memory : Node_Id;
15510 -- Start of processing for CUDA_Execute
15514 Check_At_Least_N_Arguments (3);
15515 Check_At_Most_N_Arguments (5);
15517 Analyze_And_Resolve (Kernel_Call);
15518 if Nkind (Kernel_Call) /= N_Function_Call
15519 or else Etype (Kernel_Call) /= Standard_Void_Type
15521 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
15522 -- GNAT sees Kernel_Call as an N_Function_Call since
15523 -- Kernel_Call "looks" like an expression. However, only
15524 -- procedures can be kernels, so to make things easier for the
15525 -- user the error message complains about Kernel_Call not being
15526 -- a procedure call.
15528 Error_Msg_N ("first argument of & must be a procedure call", N);
15531 Analyze (Grid_Dimensions);
15532 if not Is_Acceptable_Dim3 (Grid_Dimensions) then
15534 ("second argument of & must be an Integer, Dim3 or aggregate "
15535 & "containing 3 Integers", N);
15538 Analyze (Block_Dimensions);
15539 if not Is_Acceptable_Dim3 (Block_Dimensions) then
15541 ("third argument of & must be an Integer, Dim3 or aggregate "
15542 & "containing 3 Integers", N);
15545 if Present (Arg4) then
15546 Shared_Memory := Get_Pragma_Arg (Arg4);
15547 Analyze_And_Resolve (Shared_Memory, Any_Integer);
15549 if Present (Arg5) then
15550 Stream := Get_Pragma_Arg (Arg5);
15551 Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
15560 -- pragma CUDA_Global ([Entity =>] IDENTIFIER);
15562 when Pragma_CUDA_Global => CUDA_Global : declare
15563 Arg_Node : Node_Id;
15564 Kernel_Proc : Entity_Id;
15565 Pack_Id : Entity_Id;
15568 Check_Arg_Count (1);
15569 Check_Optional_Identifier (Arg1, Name_Entity);
15570 Check_Arg_Is_Local_Name (Arg1);
15572 Arg_Node := Get_Pragma_Arg (Arg1);
15573 Analyze (Arg_Node);
15575 Kernel_Proc := Entity (Arg_Node);
15576 Pack_Id := Scope (Kernel_Proc);
15578 if Ekind (Kernel_Proc) /= E_Procedure then
15579 Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
15581 elsif Ekind (Pack_Id) /= E_Package
15582 or else not Is_Library_Level_Entity (Pack_Id)
15585 ("& must reside in a library-level package", N, Kernel_Proc);
15588 Set_Is_CUDA_Kernel (Kernel_Proc);
15589 Add_CUDA_Kernel (Pack_Id, Kernel_Proc);
15597 when Pragma_CPP_Vtable =>
15600 if Warn_On_Obsolescent_Feature then
15602 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15610 -- pragma CPU (EXPRESSION);
15612 when Pragma_CPU => CPU : declare
15613 P : constant Node_Id := Parent (N);
15619 Check_No_Identifiers;
15620 Check_Arg_Count (1);
15621 Arg := Get_Pragma_Arg (Arg1);
15625 if Nkind (P) = N_Subprogram_Body then
15626 Check_In_Main_Program;
15628 Analyze_And_Resolve (Arg, Any_Integer);
15630 Ent := Defining_Unit_Name (Specification (P));
15632 if Nkind (Ent) = N_Defining_Program_Unit_Name then
15633 Ent := Defining_Identifier (Ent);
15638 if not Is_OK_Static_Expression (Arg) then
15639 Flag_Non_Static_Expr
15640 ("main subprogram affinity is not static!", Arg);
15643 -- If constraint error, then we already signalled an error
15645 elsif Raises_Constraint_Error (Arg) then
15648 -- Otherwise check in range
15652 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
15653 -- This is the entity System.Multiprocessors.CPU_Range;
15655 Val : constant Uint := Expr_Value (Arg);
15658 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
15660 Val > Expr_Value (Type_High_Bound (CPU_Id))
15663 ("main subprogram CPU is out of range", Arg1);
15669 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
15673 elsif Nkind (P) = N_Task_Definition then
15674 Ent := Defining_Identifier (Parent (P));
15676 -- The expression must be analyzed in the special manner
15677 -- described in "Handling of Default and Per-Object
15678 -- Expressions" in sem.ads.
15680 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
15682 -- See comment in Sem_Ch13 about the following restrictions
15684 if Is_OK_Static_Expression (Arg) then
15685 if Expr_Value (Arg) = Uint_0 then
15686 Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
15689 Check_Restriction (No_Dynamic_CPU_Assignment, N);
15692 -- Anything else is incorrect
15698 -- Check duplicate pragma before we chain the pragma in the Rep
15699 -- Item chain of Ent.
15701 Check_Duplicate_Pragma (Ent);
15702 Record_Rep_Item (Ent, N);
15705 --------------------
15706 -- Deadline_Floor --
15707 --------------------
15709 -- pragma Deadline_Floor (time_span_EXPRESSION);
15711 when Pragma_Deadline_Floor => Deadline_Floor : declare
15712 P : constant Node_Id := Parent (N);
15718 Check_No_Identifiers;
15719 Check_Arg_Count (1);
15721 Arg := Get_Pragma_Arg (Arg1);
15723 -- The expression must be analyzed in the special manner described
15724 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15726 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15728 -- Only protected types allowed
15730 if Nkind (P) /= N_Protected_Definition then
15734 Ent := Defining_Identifier (Parent (P));
15736 -- Check duplicate pragma before we chain the pragma in the Rep
15737 -- Item chain of Ent.
15739 Check_Duplicate_Pragma (Ent);
15740 Record_Rep_Item (Ent, N);
15742 end Deadline_Floor;
15748 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15750 when Pragma_Debug => Debug : declare
15757 -- The condition for executing the call is that the expander
15758 -- is active and that we are not ignoring this debug pragma.
15763 (Expander_Active and then not Is_Ignored (N)),
15766 if not Is_Ignored (N) then
15767 Set_SCO_Pragma_Enabled (Loc);
15770 if Arg_Count = 2 then
15772 Make_And_Then (Loc,
15773 Left_Opnd => Relocate_Node (Cond),
15774 Right_Opnd => Get_Pragma_Arg (Arg1));
15775 Call := Get_Pragma_Arg (Arg2);
15777 Call := Get_Pragma_Arg (Arg1);
15780 if Nkind (Call) in N_Expanded_Name
15783 | N_Indexed_Component
15784 | N_Selected_Component
15786 -- If this pragma Debug comes from source, its argument was
15787 -- parsed as a name form (which is syntactically identical).
15788 -- In a generic context a parameterless call will be left as
15789 -- an expanded name (if global) or selected_component if local.
15790 -- Change it to a procedure call statement now.
15792 Change_Name_To_Procedure_Call_Statement (Call);
15794 elsif Nkind (Call) = N_Procedure_Call_Statement then
15796 -- Already in the form of a procedure call statement: nothing
15797 -- to do (could happen in case of an internally generated
15803 -- All other cases: diagnose error
15806 ("argument of pragma ""Debug"" is not procedure call", Call);
15810 -- Rewrite into a conditional with an appropriate condition. We
15811 -- wrap the procedure call in a block so that overhead from e.g.
15812 -- use of the secondary stack does not generate execution overhead
15813 -- for suppressed conditions.
15815 -- Normally the analysis that follows will freeze the subprogram
15816 -- being called. However, if the call is to a null procedure,
15817 -- we want to freeze it before creating the block, because the
15818 -- analysis that follows may be done with expansion disabled, in
15819 -- which case the body will not be generated, leading to spurious
15822 if Nkind (Call) = N_Procedure_Call_Statement
15823 and then Is_Entity_Name (Name (Call))
15825 Analyze (Name (Call));
15826 Freeze_Before (N, Entity (Name (Call)));
15830 Make_Implicit_If_Statement (N,
15832 Then_Statements => New_List (
15833 Make_Block_Statement (Loc,
15834 Handled_Statement_Sequence =>
15835 Make_Handled_Sequence_Of_Statements (Loc,
15836 Statements => New_List (Relocate_Node (Call)))))));
15839 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15840 -- after analysis of the normally rewritten node, to capture all
15841 -- references to entities, which avoids issuing wrong warnings
15842 -- about unused entities.
15844 if GNATprove_Mode then
15845 Rewrite (N, Make_Null_Statement (Loc));
15853 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15855 when Pragma_Debug_Policy =>
15857 Check_Arg_Count (1);
15858 Check_No_Identifiers;
15859 Check_Arg_Is_Identifier (Arg1);
15861 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15862 -- rewrite it that way, and let the rest of the checking come
15863 -- from analyzing the rewritten pragma.
15867 Chars => Name_Check_Policy,
15868 Pragma_Argument_Associations => New_List (
15869 Make_Pragma_Argument_Association (Loc,
15870 Expression => Make_Identifier (Loc, Name_Debug)),
15872 Make_Pragma_Argument_Association (Loc,
15873 Expression => Get_Pragma_Arg (Arg1)))));
15876 -------------------------------
15877 -- Default_Initial_Condition --
15878 -------------------------------
15880 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15882 when Pragma_Default_Initial_Condition => DIC : declare
15889 Check_No_Identifiers;
15890 Check_At_Most_N_Arguments (2); -- Accounts for implicit type arg
15894 while Present (Stmt) loop
15896 -- Skip prior pragmas, but check for duplicates
15898 if Nkind (Stmt) = N_Pragma then
15899 if Pragma_Name (Stmt) = Pname then
15906 -- Skip internally generated code. Note that derived type
15907 -- declarations of untagged types with discriminants are
15908 -- rewritten as private type declarations.
15910 elsif not Comes_From_Source (Stmt)
15911 and then Nkind (Stmt) /= N_Private_Type_Declaration
15915 -- The associated private type [extension] has been found, stop
15918 elsif Nkind (Stmt) in N_Private_Extension_Declaration
15919 | N_Private_Type_Declaration
15921 Typ := Defining_Entity (Stmt);
15924 -- The pragma does not apply to a legal construct, issue an
15925 -- error and stop the analysis.
15931 Stmt := Prev (Stmt);
15934 -- The pragma does not apply to a legal construct, issue an error
15935 -- and stop the analysis.
15941 -- A pragma that applies to a Ghost entity becomes Ghost for the
15942 -- purposes of legality checks and removal of ignored Ghost code.
15944 Mark_Ghost_Pragma (N, Typ);
15946 -- The pragma signals that the type defines its own DIC assertion
15949 Set_Has_Own_DIC (Typ);
15951 -- A type entity argument is appended to facilitate inheriting the
15952 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
15953 -- though that extra argument isn't documented for the pragma.
15956 -- When the pragma has no arguments, create an argument with
15957 -- the value Empty, so the type name argument can be appended
15958 -- following it (since it's expected as the second argument).
15961 Set_Pragma_Argument_Associations (N, New_List (
15962 Make_Pragma_Argument_Association (Sloc (Typ),
15963 Expression => Empty)));
15967 (Pragma_Argument_Associations (N),
15968 Make_Pragma_Argument_Association (Sloc (Typ),
15969 Expression => New_Occurrence_Of (Typ, Sloc (Typ))));
15972 -- Chain the pragma on the rep item chain for further processing
15974 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15976 -- Create the declaration of the procedure which verifies the
15977 -- assertion expression of pragma DIC at runtime.
15979 Build_DIC_Procedure_Declaration (Typ);
15982 ----------------------------------
15983 -- Default_Scalar_Storage_Order --
15984 ----------------------------------
15986 -- pragma Default_Scalar_Storage_Order
15987 -- (High_Order_First | Low_Order_First);
15989 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15990 Default : Character;
15994 Check_Arg_Count (1);
15996 -- Default_Scalar_Storage_Order can appear as a configuration
15997 -- pragma, or in a declarative part of a package spec.
15999 if not Is_Configuration_Pragma then
16000 Check_Is_In_Decl_Part_Or_Package_Spec;
16003 Check_No_Identifiers;
16004 Check_Arg_Is_One_Of
16005 (Arg1, Name_High_Order_First, Name_Low_Order_First);
16006 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16007 Default := Fold_Upper (Name_Buffer (1));
16009 if not Support_Nondefault_SSO_On_Target
16010 and then Ttypes.Bytes_Big_Endian /= (Default = 'H')
16012 if Warn_On_Unrecognized_Pragma then
16014 ("non-default Scalar_Storage_Order not supported "
16015 & "on target?g?", N);
16017 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
16020 -- Here set the specified default
16023 Opt.Default_SSO := Default;
16027 --------------------------
16028 -- Default_Storage_Pool --
16029 --------------------------
16031 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
16033 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
16038 Check_Arg_Count (1);
16040 -- Default_Storage_Pool can appear as a configuration pragma, or
16041 -- in a declarative part of a package spec.
16043 if not Is_Configuration_Pragma then
16044 Check_Is_In_Decl_Part_Or_Package_Spec;
16047 if From_Aspect_Specification (N) then
16049 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
16051 if not In_Open_Scopes (E) then
16053 ("aspect must apply to package or subprogram", N);
16058 if Present (Arg1) then
16059 Pool := Get_Pragma_Arg (Arg1);
16061 -- Case of Default_Storage_Pool (null);
16063 if Nkind (Pool) = N_Null then
16066 -- This is an odd case, this is not really an expression,
16067 -- so we don't have a type for it. So just set the type to
16070 Set_Etype (Pool, Empty);
16072 -- Case of Default_Storage_Pool (Standard);
16074 elsif Nkind (Pool) = N_Identifier
16075 and then Chars (Pool) = Name_Standard
16079 if Entity (Pool) /= Standard_Standard then
16081 ("package Standard is not directly visible", Arg1);
16084 -- Case of Default_Storage_Pool (storage_pool_NAME);
16087 -- If it's a configuration pragma, then the only allowed
16088 -- argument is "null".
16090 if Is_Configuration_Pragma then
16091 Error_Pragma_Arg ("NULL or Standard expected", Arg1);
16094 -- The expected type for a non-"null" argument is
16095 -- Root_Storage_Pool'Class, and the pool must be a variable.
16097 Analyze_And_Resolve
16098 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
16100 if Is_Variable (Pool) then
16102 -- A pragma that applies to a Ghost entity becomes Ghost
16103 -- for the purposes of legality checks and removal of
16104 -- ignored Ghost code.
16106 Mark_Ghost_Pragma (N, Entity (Pool));
16110 ("default storage pool must be a variable", Arg1);
16114 -- Record the pool name (or null). Freeze.Freeze_Entity for an
16115 -- access type will use this information to set the appropriate
16116 -- attributes of the access type. If the pragma appears in a
16117 -- generic unit it is ignored, given that it may refer to a
16120 if not Inside_A_Generic then
16121 Default_Pool := Pool;
16124 end Default_Storage_Pool;
16130 -- pragma Depends (DEPENDENCY_RELATION);
16132 -- DEPENDENCY_RELATION ::=
16134 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
16136 -- DEPENDENCY_CLAUSE ::=
16137 -- OUTPUT_LIST =>[+] INPUT_LIST
16138 -- | NULL_DEPENDENCY_CLAUSE
16140 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
16142 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
16144 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
16146 -- OUTPUT ::= NAME | FUNCTION_RESULT
16149 -- where FUNCTION_RESULT is a function Result attribute_reference
16151 -- Characteristics:
16153 -- * Analysis - The annotation undergoes initial checks to verify
16154 -- the legal placement and context. Secondary checks fully analyze
16155 -- the dependency clauses in:
16157 -- Analyze_Depends_In_Decl_Part
16159 -- * Expansion - None.
16161 -- * Template - The annotation utilizes the generic template of the
16162 -- related subprogram [body] when it is:
16164 -- aspect on subprogram declaration
16165 -- aspect on stand-alone subprogram body
16166 -- pragma on stand-alone subprogram body
16168 -- The annotation must prepare its own template when it is:
16170 -- pragma on subprogram declaration
16172 -- * Globals - Capture of global references must occur after full
16175 -- * Instance - The annotation is instantiated automatically when
16176 -- the related generic subprogram [body] is instantiated except for
16177 -- the "pragma on subprogram declaration" case. In that scenario
16178 -- the annotation must instantiate itself.
16180 when Pragma_Depends => Depends : declare
16182 Spec_Id : Entity_Id;
16183 Subp_Decl : Node_Id;
16186 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
16190 -- Chain the pragma on the contract for further processing by
16191 -- Analyze_Depends_In_Decl_Part.
16193 Add_Contract_Item (N, Spec_Id);
16195 -- Fully analyze the pragma when it appears inside an entry
16196 -- or subprogram body because it cannot benefit from forward
16199 if Nkind (Subp_Decl) in N_Entry_Body
16200 | N_Subprogram_Body
16201 | N_Subprogram_Body_Stub
16203 -- The legality checks of pragmas Depends and Global are
16204 -- affected by the SPARK mode in effect and the volatility
16205 -- of the context. In addition these two pragmas are subject
16206 -- to an inherent order:
16211 -- Analyze all these pragmas in the order outlined above
16213 Analyze_If_Present (Pragma_SPARK_Mode);
16214 Analyze_If_Present (Pragma_Volatile_Function);
16215 Analyze_If_Present (Pragma_Side_Effects);
16216 Analyze_If_Present (Pragma_Global);
16217 Analyze_Depends_In_Decl_Part (N);
16222 ---------------------
16223 -- Detect_Blocking --
16224 ---------------------
16226 -- pragma Detect_Blocking;
16228 when Pragma_Detect_Blocking =>
16230 Check_Arg_Count (0);
16231 Check_Valid_Configuration_Pragma;
16232 Detect_Blocking := True;
16234 ------------------------------------
16235 -- Disable_Atomic_Synchronization --
16236 ------------------------------------
16238 -- pragma Disable_Atomic_Synchronization [(Entity)];
16240 when Pragma_Disable_Atomic_Synchronization =>
16242 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
16244 -------------------
16245 -- Discard_Names --
16246 -------------------
16248 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
16250 when Pragma_Discard_Names => Discard_Names : declare
16255 Check_Ada_83_Warning;
16257 -- Deal with configuration pragma case
16259 if Is_Configuration_Pragma then
16260 if Arg_Count /= 0 then
16262 ("nonzero number of arguments for configuration pragma%");
16264 Global_Discard_Names := True;
16268 -- Otherwise, check correct appropriate context
16271 Check_Is_In_Decl_Part_Or_Package_Spec;
16273 if Arg_Count = 0 then
16275 -- If there is no parameter, then from now on this pragma
16276 -- applies to any enumeration, exception or tagged type
16277 -- defined in the current declarative part, and recursively
16278 -- to any nested scope.
16280 Set_Discard_Names (Current_Scope);
16284 Check_Arg_Count (1);
16285 Check_Optional_Identifier (Arg1, Name_On);
16286 Check_Arg_Is_Local_Name (Arg1);
16288 E_Id := Get_Pragma_Arg (Arg1);
16290 if Etype (E_Id) = Any_Type then
16294 E := Entity (E_Id);
16296 -- A pragma that applies to a Ghost entity becomes Ghost for
16297 -- the purposes of legality checks and removal of ignored
16300 Mark_Ghost_Pragma (N, E);
16302 if (Is_First_Subtype (E)
16304 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
16305 or else Ekind (E) = E_Exception
16307 Set_Discard_Names (E);
16308 Record_Rep_Item (E, N);
16312 ("inappropriate entity for pragma%", Arg1);
16318 ------------------------
16319 -- Dispatching_Domain --
16320 ------------------------
16322 -- pragma Dispatching_Domain (EXPRESSION);
16324 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
16325 P : constant Node_Id := Parent (N);
16331 Check_No_Identifiers;
16332 Check_Arg_Count (1);
16334 -- This pragma is born obsolete, but not the aspect
16336 if not From_Aspect_Specification (N) then
16338 (No_Obsolescent_Features, Pragma_Identifier (N));
16341 if Nkind (P) = N_Task_Definition then
16342 Arg := Get_Pragma_Arg (Arg1);
16343 Ent := Defining_Identifier (Parent (P));
16345 -- A pragma that applies to a Ghost entity becomes Ghost for
16346 -- the purposes of legality checks and removal of ignored Ghost
16349 Mark_Ghost_Pragma (N, Ent);
16351 -- The expression must be analyzed in the special manner
16352 -- described in "Handling of Default and Per-Object
16353 -- Expressions" in sem.ads.
16355 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
16357 -- Check duplicate pragma before we chain the pragma in the Rep
16358 -- Item chain of Ent.
16360 Check_Duplicate_Pragma (Ent);
16361 Record_Rep_Item (Ent, N);
16363 -- Anything else is incorrect
16368 end Dispatching_Domain;
16374 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
16376 when Pragma_Elaborate => Elaborate : declare
16381 -- Pragma must be in context items list of a compilation unit
16383 if not Is_In_Context_Clause then
16387 -- Must be at least one argument
16389 if Arg_Count = 0 then
16390 Error_Pragma ("pragma% requires at least one argument");
16393 -- In Ada 83 mode, there can be no items following it in the
16394 -- context list except other pragmas and implicit with clauses
16395 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
16396 -- placement rule does not apply.
16398 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
16400 while Present (Citem) loop
16401 if Nkind (Citem) = N_Pragma
16402 or else (Nkind (Citem) = N_With_Clause
16403 and then Implicit_With (Citem))
16408 ("(Ada 83) pragma% must be at end of context clause");
16415 -- Finally, the arguments must all be units mentioned in a with
16416 -- clause in the same context clause. Note we already checked (in
16417 -- Par.Prag) that the arguments are all identifiers or selected
16421 Outer : while Present (Arg) loop
16422 Citem := First (List_Containing (N));
16423 Inner : while Citem /= N loop
16424 if Nkind (Citem) = N_With_Clause
16425 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
16427 Set_Elaborate_Present (Citem, True);
16428 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
16430 -- With the pragma present, elaboration calls on
16431 -- subprograms from the named unit need no further
16432 -- checks, as long as the pragma appears in the current
16433 -- compilation unit. If the pragma appears in some unit
16434 -- in the context, there might still be a need for an
16435 -- Elaborate_All_Desirable from the current compilation
16436 -- to the named unit, so we keep the check enabled. This
16437 -- does not apply in SPARK mode, where we allow pragma
16438 -- Elaborate, but we don't trust it to be right so we
16439 -- will still insist on the Elaborate_All.
16441 if Legacy_Elaboration_Checks
16442 and then In_Extended_Main_Source_Unit (N)
16443 and then SPARK_Mode /= On
16445 Set_Suppress_Elaboration_Warnings
16446 (Entity (Name (Citem)));
16457 ("argument of pragma% is not withed unit", Arg);
16464 -------------------
16465 -- Elaborate_All --
16466 -------------------
16468 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
16470 when Pragma_Elaborate_All => Elaborate_All : declare
16475 Check_Ada_83_Warning;
16477 -- Pragma must be in context items list of a compilation unit
16479 if not Is_In_Context_Clause then
16483 -- Must be at least one argument
16485 if Arg_Count = 0 then
16486 Error_Pragma ("pragma% requires at least one argument");
16489 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
16490 -- have to appear at the end of the context clause, but may
16491 -- appear mixed in with other items, even in Ada 83 mode.
16493 -- Final check: the arguments must all be units mentioned in
16494 -- a with clause in the same context clause. Note that we
16495 -- already checked (in Par.Prag) that all the arguments are
16496 -- either identifiers or selected components.
16499 Outr : while Present (Arg) loop
16500 Citem := First (List_Containing (N));
16501 Innr : while Citem /= N loop
16502 if Nkind (Citem) = N_With_Clause
16503 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
16505 Set_Elaborate_All_Present (Citem, True);
16506 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
16508 -- Suppress warnings and elaboration checks on the named
16509 -- unit if the pragma is in the current compilation, as
16510 -- for pragma Elaborate.
16512 if Legacy_Elaboration_Checks
16513 and then In_Extended_Main_Source_Unit (N)
16515 Set_Suppress_Elaboration_Warnings
16516 (Entity (Name (Citem)));
16527 ("argument of pragma% is not withed unit", Arg);
16534 --------------------
16535 -- Elaborate_Body --
16536 --------------------
16538 -- pragma Elaborate_Body [( library_unit_NAME )];
16540 when Pragma_Elaborate_Body => Elaborate_Body : declare
16541 Cunit_Node : Node_Id;
16542 Cunit_Ent : Entity_Id;
16545 Check_Ada_83_Warning;
16546 Check_Valid_Library_Unit_Pragma;
16548 -- If N was rewritten as a null statement there is nothing more
16551 if Nkind (N) = N_Null_Statement then
16555 Cunit_Node := Cunit (Current_Sem_Unit);
16556 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16558 -- A pragma that applies to a Ghost entity becomes Ghost for the
16559 -- purposes of legality checks and removal of ignored Ghost code.
16561 Mark_Ghost_Pragma (N, Cunit_Ent);
16563 if Nkind (Unit (Cunit_Node)) in
16564 N_Package_Body | N_Subprogram_Body
16566 Error_Pragma ("pragma% must refer to a spec, not a body");
16568 Set_Body_Required (Cunit_Node);
16569 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
16571 -- If we are in dynamic elaboration mode, then we suppress
16572 -- elaboration warnings for the unit, since it is definitely
16573 -- fine NOT to do dynamic checks at the first level (and such
16574 -- checks will be suppressed because no elaboration boolean
16575 -- is created for Elaborate_Body packages).
16577 -- But in the static model of elaboration, Elaborate_Body is
16578 -- definitely NOT good enough to ensure elaboration safety on
16579 -- its own, since the body may WITH other units that are not
16580 -- safe from an elaboration point of view, so a client must
16581 -- still do an Elaborate_All on such units.
16583 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16584 -- Elaborate_Body always suppressed elab warnings.
16586 if Legacy_Elaboration_Checks
16587 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
16589 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
16592 end Elaborate_Body;
16594 ------------------------
16595 -- Elaboration_Checks --
16596 ------------------------
16598 -- pragma Elaboration_Checks (Static | Dynamic);
16600 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
16601 procedure Check_Duplicate_Elaboration_Checks_Pragma;
16602 -- Emit an error if the current context list already contains
16603 -- a previous Elaboration_Checks pragma. This routine raises
16604 -- Pragma_Exit if a duplicate is found.
16606 procedure Ignore_Elaboration_Checks_Pragma;
16607 -- Warn that the effects of the pragma are ignored. This routine
16608 -- raises Pragma_Exit.
16610 -----------------------------------------------
16611 -- Check_Duplicate_Elaboration_Checks_Pragma --
16612 -----------------------------------------------
16614 procedure Check_Duplicate_Elaboration_Checks_Pragma is
16619 while Present (Item) loop
16620 if Nkind (Item) = N_Pragma
16621 and then Pragma_Name (Item) = Name_Elaboration_Checks
16631 end Check_Duplicate_Elaboration_Checks_Pragma;
16633 --------------------------------------
16634 -- Ignore_Elaboration_Checks_Pragma --
16635 --------------------------------------
16637 procedure Ignore_Elaboration_Checks_Pragma is
16639 Error_Msg_Name_1 := Pname;
16640 Error_Msg_N ("??effects of pragma % are ignored", N);
16642 ("\place pragma on initial declaration of library unit", N);
16645 end Ignore_Elaboration_Checks_Pragma;
16649 Context : constant Node_Id := Parent (N);
16652 -- Start of processing for Elaboration_Checks
16656 Check_Arg_Count (1);
16657 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
16659 -- The pragma appears in a configuration file
16661 if No (Context) then
16662 Check_Valid_Configuration_Pragma;
16663 Check_Duplicate_Elaboration_Checks_Pragma;
16665 -- The pragma acts as a configuration pragma in a compilation unit
16667 -- pragma Elaboration_Checks (...);
16668 -- package Pack is ...;
16670 elsif Nkind (Context) = N_Compilation_Unit
16671 and then List_Containing (N) = Context_Items (Context)
16673 Check_Valid_Configuration_Pragma;
16674 Check_Duplicate_Elaboration_Checks_Pragma;
16676 Unt := Unit (Context);
16678 -- The pragma must appear on the initial declaration of a unit.
16679 -- If this is not the case, warn that the effects of the pragma
16682 if Nkind (Unt) = N_Package_Body then
16683 Ignore_Elaboration_Checks_Pragma;
16685 -- Check the Acts_As_Spec flag of the compilation units itself
16686 -- to determine whether the subprogram body completes since it
16687 -- has not been analyzed yet. This is safe because compilation
16688 -- units are not overloadable.
16690 elsif Nkind (Unt) = N_Subprogram_Body
16691 and then not Acts_As_Spec (Context)
16693 Ignore_Elaboration_Checks_Pragma;
16695 elsif Nkind (Unt) = N_Subunit then
16696 Ignore_Elaboration_Checks_Pragma;
16699 -- Otherwise the pragma does not appear at the configuration level
16706 -- At this point the pragma is not a duplicate, and appears in the
16707 -- proper context. Set the elaboration model in effect.
16709 Dynamic_Elaboration_Checks :=
16710 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
16711 end Elaboration_Checks;
16717 -- pragma Eliminate (
16718 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16719 -- [Entity =>] IDENTIFIER |
16720 -- SELECTED_COMPONENT |
16722 -- [, Source_Location => SOURCE_TRACE]);
16724 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16725 -- SOURCE_TRACE ::= STRING_LITERAL
16727 when Pragma_Eliminate => Eliminate : declare
16728 Args : Args_List (1 .. 5);
16729 Names : constant Name_List (1 .. 5) := (
16732 Name_Parameter_Types,
16734 Name_Source_Location);
16736 -- Note : Parameter_Types and Result_Type are leftovers from
16737 -- prior implementations of the pragma. They are not generated
16738 -- by the gnatelim tool, and play no role in selecting which
16739 -- of a set of overloaded names is chosen for elimination.
16741 Unit_Name : Node_Id renames Args (1);
16742 Entity : Node_Id renames Args (2);
16743 Parameter_Types : Node_Id renames Args (3);
16744 Result_Type : Node_Id renames Args (4);
16745 Source_Location : Node_Id renames Args (5);
16749 Check_Valid_Configuration_Pragma;
16750 Gather_Associations (Names, Args);
16752 if No (Unit_Name) then
16753 Error_Pragma ("missing Unit_Name argument for pragma%");
16757 and then (Present (Parameter_Types)
16759 Present (Result_Type)
16761 Present (Source_Location))
16763 Error_Pragma ("missing Entity argument for pragma%");
16766 if (Present (Parameter_Types)
16768 Present (Result_Type))
16770 Present (Source_Location)
16773 ("parameter profile and source location cannot be used "
16774 & "together in pragma%");
16777 Process_Eliminate_Pragma
16786 -----------------------------------
16787 -- Enable_Atomic_Synchronization --
16788 -----------------------------------
16790 -- pragma Enable_Atomic_Synchronization [(Entity)];
16792 when Pragma_Enable_Atomic_Synchronization =>
16794 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16796 -----------------------
16797 -- Exceptional_Cases --
16798 -----------------------
16800 -- pragma Exceptional_Cases ( EXCEPTIONAL_CONTRACT_LIST );
16802 -- EXCEPTIONAL_CONTRACT_LIST ::=
16803 -- ( EXCEPTIONAL_CONTRACT {, EXCEPTIONAL_CONTRACT })
16805 -- EXCEPTIONAL_CONTRACT ::=
16806 -- EXCEPTION_CHOICE {'|' EXCEPTION_CHOICE} => CONSEQUENCE
16810 -- CONSEQUENCE ::= boolean_EXPRESSION
16812 -- Characteristics:
16814 -- * Analysis - The annotation undergoes initial checks to verify
16815 -- the legal placement and context. Secondary checks preanalyze the
16818 -- Analyze_Exceptional_Cases_In_Decl_Part
16820 -- * Expansion - The annotation is expanded during the expansion of
16821 -- the related subprogram [body] contract as performed in:
16823 -- Expand_Subprogram_Contract
16825 -- * Template - The annotation utilizes the generic template of the
16826 -- related subprogram [body] when it is:
16828 -- aspect on subprogram declaration
16829 -- aspect on stand-alone subprogram body
16830 -- pragma on stand-alone subprogram body
16832 -- The annotation must prepare its own template when it is:
16834 -- pragma on subprogram declaration
16836 -- * Globals - Capture of global references must occur after full
16839 -- * Instance - The annotation is instantiated automatically when
16840 -- the related generic subprogram [body] is instantiated except for
16841 -- the "pragma on subprogram declaration" case. In that scenario
16842 -- the annotation must instantiate itself.
16844 when Pragma_Exceptional_Cases => Exceptional_Cases : declare
16845 Spec_Id : Entity_Id;
16846 Subp_Decl : Node_Id;
16847 Subp_Spec : Node_Id;
16851 Check_No_Identifiers;
16852 Check_Arg_Count (1);
16854 -- Ensure the proper placement of the pragma. Exceptional_Cases
16855 -- must be associated with a subprogram declaration or a body that
16859 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16861 -- Generic subprogram
16863 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16866 -- Body acts as spec
16868 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16869 and then No (Corresponding_Spec (Subp_Decl))
16873 -- Body stub acts as spec
16875 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16876 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16882 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16883 Subp_Spec := Specification (Subp_Decl);
16885 -- Pragma Exceptional_Cases is forbidden on null procedures,
16886 -- as this may lead to potential ambiguities in behavior when
16887 -- interface null procedures are involved. Also, it just
16888 -- wouldn't make sense, because null procedures do not raise
16891 if Nkind (Subp_Spec) = N_Procedure_Specification
16892 and then Null_Present (Subp_Spec)
16894 Error_Msg_N (Fix_Error
16895 ("pragma % cannot apply to null procedure"), N);
16903 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16905 -- In order to call Is_Function_With_Side_Effects, analyze pragma
16906 -- Side_Effects if present.
16908 Analyze_If_Present (Pragma_Side_Effects);
16910 -- Pragma Exceptional_Cases is not allowed on functions without
16913 if Ekind (Spec_Id) in E_Function | E_Generic_Function
16914 and then not Is_Function_With_Side_Effects (Spec_Id)
16916 Error_Msg_Sloc := GEC_Exceptional_Cases_On_Function;
16918 if Ekind (Spec_Id) = E_Function then
16919 Error_Msg_N (Fix_Error
16920 ("pragma % cannot apply to function '[[]']"), N);
16923 elsif Ekind (Spec_Id) = E_Generic_Function then
16924 Error_Msg_N (Fix_Error
16925 ("pragma % cannot apply to generic function '[[]']"), N);
16930 -- A pragma that applies to a Ghost entity becomes Ghost for the
16931 -- purposes of legality checks and removal of ignored Ghost code.
16933 Mark_Ghost_Pragma (N, Spec_Id);
16934 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
16936 -- Chain the pragma on the contract for further processing by
16937 -- Analyze_Exceptional_Cases_In_Decl_Part.
16939 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16941 -- Fully analyze the pragma when it appears inside a subprogram
16942 -- body because it cannot benefit from forward references.
16944 if Nkind (Subp_Decl) in N_Subprogram_Body
16945 | N_Subprogram_Body_Stub
16947 -- The legality checks of pragma Exceptional_Cases are
16948 -- affected by the SPARK mode in effect and the volatility
16949 -- of the context. Analyze all pragmas in a specific order.
16951 Analyze_If_Present (Pragma_SPARK_Mode);
16952 Analyze_If_Present (Pragma_Volatile_Function);
16953 Analyze_Exceptional_Cases_In_Decl_Part (N);
16955 end Exceptional_Cases;
16962 -- [ Convention =>] convention_IDENTIFIER,
16963 -- [ Entity =>] LOCAL_NAME
16964 -- [, [External_Name =>] static_string_EXPRESSION ]
16965 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16967 when Pragma_Export => Export : declare
16969 Def_Id : Entity_Id;
16971 pragma Warnings (Off, C);
16974 Check_Ada_83_Warning;
16978 Name_External_Name,
16981 Check_At_Least_N_Arguments (2);
16982 Check_At_Most_N_Arguments (4);
16984 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16985 -- pragma Export (Entity, "external name");
16987 if Relaxed_RM_Semantics
16988 and then Arg_Count = 2
16989 and then Nkind (Expression (Arg2)) = N_String_Literal
16992 Def_Id := Get_Pragma_Arg (Arg1);
16995 if not Is_Entity_Name (Def_Id) then
16996 Error_Pragma_Arg ("entity name required", Arg1);
16999 Def_Id := Entity (Def_Id);
17000 Set_Exported (Def_Id, Arg1);
17003 Process_Convention (C, Def_Id);
17005 -- A pragma that applies to a Ghost entity becomes Ghost for
17006 -- the purposes of legality checks and removal of ignored Ghost
17009 Mark_Ghost_Pragma (N, Def_Id);
17011 if Ekind (Def_Id) /= E_Constant then
17012 Note_Possible_Modification
17013 (Get_Pragma_Arg (Arg2), Sure => False);
17016 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
17017 Set_Exported (Def_Id, Arg2);
17020 -- If the entity is a deferred constant, propagate the information
17021 -- to the full view, because gigi elaborates the full view only.
17023 if Ekind (Def_Id) = E_Constant
17024 and then Present (Full_View (Def_Id))
17027 Id2 : constant Entity_Id := Full_View (Def_Id);
17029 Set_Is_Exported (Id2, Is_Exported (Def_Id));
17030 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
17032 (Id2, Einfo.Entities.Interface_Name (Def_Id));
17037 ---------------------
17038 -- Export_Function --
17039 ---------------------
17041 -- pragma Export_Function (
17042 -- [Internal =>] LOCAL_NAME
17043 -- [, [External =>] EXTERNAL_SYMBOL]
17044 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17045 -- [, [Result_Type =>] TYPE_DESIGNATOR]
17046 -- [, [Mechanism =>] MECHANISM]
17047 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17049 -- EXTERNAL_SYMBOL ::=
17051 -- | static_string_EXPRESSION
17053 -- PARAMETER_TYPES ::=
17055 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17057 -- TYPE_DESIGNATOR ::=
17059 -- | subtype_Name ' Access
17063 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17065 -- MECHANISM_ASSOCIATION ::=
17066 -- [formal_parameter_NAME =>] MECHANISM_NAME
17068 -- MECHANISM_NAME ::=
17072 when Pragma_Export_Function => Export_Function : declare
17073 Args : Args_List (1 .. 6);
17074 Names : constant Name_List (1 .. 6) := (
17077 Name_Parameter_Types,
17080 Name_Result_Mechanism);
17082 Internal : Node_Id renames Args (1);
17083 External : Node_Id renames Args (2);
17084 Parameter_Types : Node_Id renames Args (3);
17085 Result_Type : Node_Id renames Args (4);
17086 Mechanism : Node_Id renames Args (5);
17087 Result_Mechanism : Node_Id renames Args (6);
17091 Gather_Associations (Names, Args);
17092 Process_Extended_Import_Export_Subprogram_Pragma (
17093 Arg_Internal => Internal,
17094 Arg_External => External,
17095 Arg_Parameter_Types => Parameter_Types,
17096 Arg_Result_Type => Result_Type,
17097 Arg_Mechanism => Mechanism,
17098 Arg_Result_Mechanism => Result_Mechanism);
17099 end Export_Function;
17101 -------------------
17102 -- Export_Object --
17103 -------------------
17105 -- pragma Export_Object (
17106 -- [Internal =>] LOCAL_NAME
17107 -- [, [External =>] EXTERNAL_SYMBOL]
17108 -- [, [Size =>] EXTERNAL_SYMBOL]);
17110 -- EXTERNAL_SYMBOL ::=
17112 -- | static_string_EXPRESSION
17114 -- PARAMETER_TYPES ::=
17116 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17118 -- TYPE_DESIGNATOR ::=
17120 -- | subtype_Name ' Access
17124 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17126 -- MECHANISM_ASSOCIATION ::=
17127 -- [formal_parameter_NAME =>] MECHANISM_NAME
17129 -- MECHANISM_NAME ::=
17133 when Pragma_Export_Object => Export_Object : declare
17134 Args : Args_List (1 .. 3);
17135 Names : constant Name_List (1 .. 3) := (
17140 Internal : Node_Id renames Args (1);
17141 External : Node_Id renames Args (2);
17142 Size : Node_Id renames Args (3);
17146 Gather_Associations (Names, Args);
17147 Process_Extended_Import_Export_Object_Pragma (
17148 Arg_Internal => Internal,
17149 Arg_External => External,
17153 ----------------------
17154 -- Export_Procedure --
17155 ----------------------
17157 -- pragma Export_Procedure (
17158 -- [Internal =>] LOCAL_NAME
17159 -- [, [External =>] EXTERNAL_SYMBOL]
17160 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17161 -- [, [Mechanism =>] MECHANISM]);
17163 -- EXTERNAL_SYMBOL ::=
17165 -- | static_string_EXPRESSION
17167 -- PARAMETER_TYPES ::=
17169 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17171 -- TYPE_DESIGNATOR ::=
17173 -- | subtype_Name ' Access
17177 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17179 -- MECHANISM_ASSOCIATION ::=
17180 -- [formal_parameter_NAME =>] MECHANISM_NAME
17182 -- MECHANISM_NAME ::=
17186 when Pragma_Export_Procedure => Export_Procedure : declare
17187 Args : Args_List (1 .. 4);
17188 Names : constant Name_List (1 .. 4) := (
17191 Name_Parameter_Types,
17194 Internal : Node_Id renames Args (1);
17195 External : Node_Id renames Args (2);
17196 Parameter_Types : Node_Id renames Args (3);
17197 Mechanism : Node_Id renames Args (4);
17201 Gather_Associations (Names, Args);
17202 Process_Extended_Import_Export_Subprogram_Pragma (
17203 Arg_Internal => Internal,
17204 Arg_External => External,
17205 Arg_Parameter_Types => Parameter_Types,
17206 Arg_Mechanism => Mechanism);
17207 end Export_Procedure;
17209 -----------------------------
17210 -- Export_Valued_Procedure --
17211 -----------------------------
17213 -- pragma Export_Valued_Procedure (
17214 -- [Internal =>] LOCAL_NAME
17215 -- [, [External =>] EXTERNAL_SYMBOL,]
17216 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17217 -- [, [Mechanism =>] MECHANISM]);
17219 -- EXTERNAL_SYMBOL ::=
17221 -- | static_string_EXPRESSION
17223 -- PARAMETER_TYPES ::=
17225 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17227 -- TYPE_DESIGNATOR ::=
17229 -- | subtype_Name ' Access
17233 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17235 -- MECHANISM_ASSOCIATION ::=
17236 -- [formal_parameter_NAME =>] MECHANISM_NAME
17238 -- MECHANISM_NAME ::=
17242 when Pragma_Export_Valued_Procedure =>
17243 Export_Valued_Procedure : declare
17244 Args : Args_List (1 .. 4);
17245 Names : constant Name_List (1 .. 4) := (
17248 Name_Parameter_Types,
17251 Internal : Node_Id renames Args (1);
17252 External : Node_Id renames Args (2);
17253 Parameter_Types : Node_Id renames Args (3);
17254 Mechanism : Node_Id renames Args (4);
17258 Gather_Associations (Names, Args);
17259 Process_Extended_Import_Export_Subprogram_Pragma (
17260 Arg_Internal => Internal,
17261 Arg_External => External,
17262 Arg_Parameter_Types => Parameter_Types,
17263 Arg_Mechanism => Mechanism);
17264 end Export_Valued_Procedure;
17266 -------------------
17267 -- Extend_System --
17268 -------------------
17270 -- pragma Extend_System ([Name =>] Identifier);
17272 when Pragma_Extend_System =>
17274 Check_Valid_Configuration_Pragma;
17275 Check_Arg_Count (1);
17276 Check_Optional_Identifier (Arg1, Name_Name);
17277 Check_Arg_Is_Identifier (Arg1);
17279 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
17282 and then Name_Buffer (1 .. 4) = "aux_"
17284 if Present (System_Extend_Pragma_Arg) then
17285 if Chars (Get_Pragma_Arg (Arg1)) =
17286 Chars (Expression (System_Extend_Pragma_Arg))
17290 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
17291 Error_Pragma ("pragma% conflicts with that #");
17295 System_Extend_Pragma_Arg := Arg1;
17297 if not GNAT_Mode then
17298 System_Extend_Unit := Arg1;
17302 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
17305 ------------------------
17306 -- Extensions_Allowed --
17307 ------------------------
17309 -- pragma Extensions_Allowed (ON | OFF | ALL);
17311 when Pragma_Extensions_Allowed =>
17313 Check_Arg_Count (1);
17314 Check_No_Identifiers;
17315 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off, Name_All);
17317 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
17318 Ada_Version := Ada_With_Core_Extensions;
17319 elsif Chars (Get_Pragma_Arg (Arg1)) = Name_All then
17320 Ada_Version := Ada_With_All_Extensions;
17322 Ada_Version := Ada_Version_Explicit;
17323 Ada_Version_Pragma := Empty;
17326 ------------------------
17327 -- Extensions_Visible --
17328 ------------------------
17330 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
17332 -- Characteristics:
17334 -- * Analysis - The annotation is fully analyzed immediately upon
17335 -- elaboration as its expression must be static.
17337 -- * Expansion - None.
17339 -- * Template - The annotation utilizes the generic template of the
17340 -- related subprogram [body] when it is:
17342 -- aspect on subprogram declaration
17343 -- aspect on stand-alone subprogram body
17344 -- pragma on stand-alone subprogram body
17346 -- The annotation must prepare its own template when it is:
17348 -- pragma on subprogram declaration
17350 -- * Globals - Capture of global references must occur after full
17353 -- * Instance - The annotation is instantiated automatically when
17354 -- the related generic subprogram [body] is instantiated except for
17355 -- the "pragma on subprogram declaration" case. In that scenario
17356 -- the annotation must instantiate itself.
17358 when Pragma_Extensions_Visible => Extensions_Visible : declare
17359 Formal : Entity_Id;
17360 Has_OK_Formal : Boolean := False;
17361 Spec_Id : Entity_Id;
17362 Subp_Decl : Node_Id;
17366 Check_No_Identifiers;
17367 Check_At_Most_N_Arguments (1);
17370 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
17372 -- Abstract subprogram declaration
17374 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
17377 -- Generic subprogram declaration
17379 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
17382 -- Body acts as spec
17384 elsif Nkind (Subp_Decl) = N_Subprogram_Body
17385 and then No (Corresponding_Spec (Subp_Decl))
17389 -- Body stub acts as spec
17391 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
17392 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
17396 -- Subprogram declaration
17398 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
17401 -- Otherwise the pragma is associated with an illegal construct
17404 Error_Pragma ("pragma % must apply to a subprogram");
17407 -- Mark the pragma as Ghost if the related subprogram is also
17408 -- Ghost. This also ensures that any expansion performed further
17409 -- below will produce Ghost nodes.
17411 Spec_Id := Unique_Defining_Entity (Subp_Decl);
17412 Mark_Ghost_Pragma (N, Spec_Id);
17414 -- Chain the pragma on the contract for completeness
17416 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
17418 -- The legality checks of pragma Extension_Visible are affected
17419 -- by the SPARK mode in effect. Analyze all pragmas in specific
17422 Analyze_If_Present (Pragma_SPARK_Mode);
17424 -- Examine the formals of the related subprogram
17426 Formal := First_Formal (Spec_Id);
17427 while Present (Formal) loop
17429 -- At least one of the formals is of a specific tagged type,
17430 -- the pragma is legal.
17432 if Is_Specific_Tagged_Type (Etype (Formal)) then
17433 Has_OK_Formal := True;
17436 -- A generic subprogram with at least one formal of a private
17437 -- type ensures the legality of the pragma because the actual
17438 -- may be specifically tagged. Note that this is verified by
17439 -- the check above at instantiation time.
17441 elsif Is_Private_Type (Etype (Formal))
17442 and then Is_Generic_Type (Etype (Formal))
17444 Has_OK_Formal := True;
17448 Next_Formal (Formal);
17451 if not Has_OK_Formal then
17452 Error_Msg_Name_1 := Pname;
17453 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
17455 ("\subprogram & lacks parameter of specific tagged or "
17456 & "generic private type", N, Spec_Id);
17461 -- Analyze the Boolean expression (if any)
17463 if Present (Arg1) then
17464 Check_Static_Boolean_Expression
17465 (Expression (Get_Argument (N, Spec_Id)));
17467 end Extensions_Visible;
17473 -- pragma External (
17474 -- [ Convention =>] convention_IDENTIFIER,
17475 -- [ Entity =>] LOCAL_NAME
17476 -- [, [External_Name =>] static_string_EXPRESSION ]
17477 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17479 when Pragma_External => External : declare
17482 pragma Warnings (Off, C);
17489 Name_External_Name,
17491 Check_At_Least_N_Arguments (2);
17492 Check_At_Most_N_Arguments (4);
17493 Process_Convention (C, E);
17495 -- A pragma that applies to a Ghost entity becomes Ghost for the
17496 -- purposes of legality checks and removal of ignored Ghost code.
17498 Mark_Ghost_Pragma (N, E);
17500 Note_Possible_Modification
17501 (Get_Pragma_Arg (Arg2), Sure => False);
17502 Process_Interface_Name (E, Arg3, Arg4, N);
17503 Set_Exported (E, Arg2);
17506 --------------------------
17507 -- External_Name_Casing --
17508 --------------------------
17510 -- pragma External_Name_Casing (
17511 -- UPPERCASE | LOWERCASE
17512 -- [, AS_IS | UPPERCASE | LOWERCASE]);
17514 when Pragma_External_Name_Casing =>
17516 Check_No_Identifiers;
17518 if Arg_Count = 2 then
17519 Check_Arg_Is_One_Of
17520 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
17522 case Chars (Get_Pragma_Arg (Arg2)) is
17524 Opt.External_Name_Exp_Casing := As_Is;
17526 when Name_Uppercase =>
17527 Opt.External_Name_Exp_Casing := Uppercase;
17529 when Name_Lowercase =>
17530 Opt.External_Name_Exp_Casing := Lowercase;
17537 Check_Arg_Count (1);
17540 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
17542 case Chars (Get_Pragma_Arg (Arg1)) is
17543 when Name_Uppercase =>
17544 Opt.External_Name_Imp_Casing := Uppercase;
17546 when Name_Lowercase =>
17547 Opt.External_Name_Imp_Casing := Lowercase;
17557 -- pragma Fast_Math;
17559 when Pragma_Fast_Math =>
17561 Check_No_Identifiers;
17562 Check_Valid_Configuration_Pragma;
17565 --------------------------
17566 -- Favor_Top_Level --
17567 --------------------------
17569 -- pragma Favor_Top_Level (type_NAME);
17571 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
17576 Check_No_Identifiers;
17577 Check_Arg_Count (1);
17578 Check_Arg_Is_Local_Name (Arg1);
17579 Typ := Entity (Get_Pragma_Arg (Arg1));
17581 -- A pragma that applies to a Ghost entity becomes Ghost for the
17582 -- purposes of legality checks and removal of ignored Ghost code.
17584 Mark_Ghost_Pragma (N, Typ);
17586 -- If it's an access-to-subprogram type (in particular, not a
17587 -- subtype), set the flag on that type.
17589 if Is_Access_Subprogram_Type (Typ) then
17590 Set_Can_Use_Internal_Rep (Typ, False);
17592 -- Otherwise it's an error (name denotes the wrong sort of entity)
17596 ("access-to-subprogram type expected",
17597 Get_Pragma_Arg (Arg1));
17599 end Favor_Top_Level;
17601 ---------------------------
17602 -- Finalize_Storage_Only --
17603 ---------------------------
17605 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
17607 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
17608 Assoc : constant Node_Id := Arg1;
17609 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
17614 Check_No_Identifiers;
17615 Check_Arg_Count (1);
17616 Check_Arg_Is_Local_Name (Arg1);
17618 Find_Type (Type_Id);
17619 Typ := Entity (Type_Id);
17622 or else Rep_Item_Too_Early (Typ, N)
17626 Typ := Underlying_Type (Typ);
17629 if not Is_Controlled (Typ) then
17630 Error_Pragma ("pragma% must specify controlled type");
17633 Check_First_Subtype (Arg1);
17635 if Finalize_Storage_Only (Typ) then
17636 Error_Pragma ("duplicate pragma%, only one allowed");
17638 elsif not Rep_Item_Too_Late (Typ, N) then
17639 Set_Finalize_Storage_Only (Base_Type (Typ), True);
17641 end Finalize_Storage;
17647 -- pragma Ghost [ (boolean_EXPRESSION) ];
17649 when Pragma_Ghost => Ghost : declare
17653 Orig_Stmt : Node_Id;
17654 Prev_Id : Entity_Id;
17659 Check_No_Identifiers;
17660 Check_At_Most_N_Arguments (1);
17664 while Present (Stmt) loop
17666 -- Skip prior pragmas, but check for duplicates
17668 if Nkind (Stmt) = N_Pragma then
17669 if Pragma_Name (Stmt) = Pname then
17676 -- Task unit declared without a definition cannot be subject to
17677 -- pragma Ghost (SPARK RM 6.9(19)).
17679 elsif Nkind (Stmt) in
17680 N_Single_Task_Declaration | N_Task_Type_Declaration
17682 Error_Pragma ("pragma % cannot apply to a task type");
17684 -- Skip internally generated code
17686 elsif not Comes_From_Source (Stmt) then
17687 Orig_Stmt := Original_Node (Stmt);
17689 -- When pragma Ghost applies to an untagged derivation, the
17690 -- derivation is transformed into a [sub]type declaration.
17693 N_Full_Type_Declaration | N_Subtype_Declaration
17694 and then Comes_From_Source (Orig_Stmt)
17695 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
17696 and then Nkind (Type_Definition (Orig_Stmt)) =
17697 N_Derived_Type_Definition
17699 Id := Defining_Entity (Stmt);
17702 -- When pragma Ghost applies to an object declaration which
17703 -- is initialized by means of a function call that returns
17704 -- on the secondary stack, the object declaration becomes a
17707 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
17708 and then Comes_From_Source (Orig_Stmt)
17709 and then Nkind (Orig_Stmt) = N_Object_Declaration
17711 Id := Defining_Entity (Stmt);
17714 -- When pragma Ghost applies to an expression function, the
17715 -- expression function is transformed into a subprogram.
17717 elsif Nkind (Stmt) = N_Subprogram_Declaration
17718 and then Comes_From_Source (Orig_Stmt)
17719 and then Nkind (Orig_Stmt) = N_Expression_Function
17721 Id := Defining_Entity (Stmt);
17724 -- When pragma Ghost applies to a generic formal type, the
17725 -- type declaration in the instantiation is a generated
17726 -- subtype declaration.
17728 elsif Nkind (Stmt) = N_Subtype_Declaration
17729 and then Present (Generic_Parent_Type (Stmt))
17731 Id := Defining_Entity (Stmt);
17735 -- The pragma applies to a legal construct, stop the traversal
17737 elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
17738 | N_Formal_Object_Declaration
17739 | N_Formal_Subprogram_Declaration
17740 | N_Formal_Type_Declaration
17741 | N_Full_Type_Declaration
17742 | N_Generic_Subprogram_Declaration
17743 | N_Object_Declaration
17744 | N_Private_Extension_Declaration
17745 | N_Private_Type_Declaration
17746 | N_Subprogram_Declaration
17747 | N_Subtype_Declaration
17749 Id := Defining_Entity (Stmt);
17752 -- The pragma does not apply to a legal construct, issue an
17753 -- error and stop the analysis.
17757 ("pragma % must apply to an object, package, subprogram "
17761 Stmt := Prev (Stmt);
17764 Context := Parent (N);
17766 -- Handle compilation units
17768 if Nkind (Context) = N_Compilation_Unit_Aux then
17769 Context := Unit (Parent (Context));
17772 -- Protected and task types cannot be subject to pragma Ghost
17773 -- (SPARK RM 6.9(19)).
17775 if Nkind (Context) in N_Protected_Body | N_Protected_Definition
17777 Error_Pragma ("pragma % cannot apply to a protected type");
17779 elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
17780 Error_Pragma ("pragma % cannot apply to a task type");
17785 -- When pragma Ghost is associated with a [generic] package, it
17786 -- appears in the visible declarations.
17788 if Nkind (Context) = N_Package_Specification
17789 and then Present (Visible_Declarations (Context))
17790 and then List_Containing (N) = Visible_Declarations (Context)
17792 Id := Defining_Entity (Context);
17794 -- Pragma Ghost applies to a stand-alone subprogram body
17796 elsif Nkind (Context) = N_Subprogram_Body
17797 and then No (Corresponding_Spec (Context))
17799 Id := Defining_Entity (Context);
17801 -- Pragma Ghost applies to a subprogram declaration that acts
17802 -- as a compilation unit.
17804 elsif Nkind (Context) = N_Subprogram_Declaration then
17805 Id := Defining_Entity (Context);
17807 -- Pragma Ghost applies to a generic subprogram
17809 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
17810 Id := Defining_Entity (Specification (Context));
17816 ("pragma % must apply to an object, package, subprogram or "
17820 -- Handle completions of types and constants that are subject to
17823 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
17824 Prev_Id := Incomplete_Or_Partial_View (Id);
17826 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
17827 Error_Msg_Name_1 := Pname;
17829 -- The full declaration of a deferred constant cannot be
17830 -- subject to pragma Ghost unless the deferred declaration
17831 -- is also Ghost (SPARK RM 6.9(9)).
17833 if Ekind (Prev_Id) = E_Constant then
17834 Error_Msg_Name_1 := Pname;
17835 Error_Msg_NE (Fix_Error
17836 ("pragma % must apply to declaration of deferred "
17837 & "constant &"), N, Id);
17840 -- Pragma Ghost may appear on the full view of an incomplete
17841 -- type because the incomplete declaration lacks aspects and
17842 -- cannot be subject to pragma Ghost.
17844 elsif Ekind (Prev_Id) = E_Incomplete_Type then
17847 -- The full declaration of a type cannot be subject to
17848 -- pragma Ghost unless the partial view is also Ghost
17849 -- (SPARK RM 6.9(9)).
17852 Error_Msg_NE (Fix_Error
17853 ("pragma % must apply to partial view of type &"),
17859 -- A synchronized object cannot be subject to pragma Ghost
17860 -- (SPARK RM 6.9(19)).
17862 elsif Ekind (Id) = E_Variable then
17863 if Is_Protected_Type (Etype (Id)) then
17864 Error_Pragma ("pragma % cannot apply to a protected object");
17866 elsif Is_Task_Type (Etype (Id)) then
17867 Error_Pragma ("pragma % cannot apply to a task object");
17871 -- Analyze the Boolean expression (if any)
17873 if Present (Arg1) then
17874 Expr := Get_Pragma_Arg (Arg1);
17876 Analyze_And_Resolve (Expr, Standard_Boolean);
17878 if Is_OK_Static_Expression (Expr) then
17880 -- "Ghostness" cannot be turned off once enabled within a
17881 -- region (SPARK RM 6.9(6)).
17883 if Is_False (Expr_Value (Expr))
17884 and then Ghost_Mode > None
17887 ("pragma % with value False cannot appear in enabled "
17891 -- Otherwise the expression is not static
17895 ("expression of pragma % must be static", Expr);
17899 Set_Is_Ghost_Entity (Id);
17906 -- pragma Global (GLOBAL_SPECIFICATION);
17908 -- GLOBAL_SPECIFICATION ::=
17911 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17913 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17915 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17916 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17917 -- GLOBAL_ITEM ::= NAME
17919 -- Characteristics:
17921 -- * Analysis - The annotation undergoes initial checks to verify
17922 -- the legal placement and context. Secondary checks fully analyze
17923 -- the dependency clauses in:
17925 -- Analyze_Global_In_Decl_Part
17927 -- * Expansion - None.
17929 -- * Template - The annotation utilizes the generic template of the
17930 -- related subprogram [body] when it is:
17932 -- aspect on subprogram declaration
17933 -- aspect on stand-alone subprogram body
17934 -- pragma on stand-alone subprogram body
17936 -- The annotation must prepare its own template when it is:
17938 -- pragma on subprogram declaration
17940 -- * Globals - Capture of global references must occur after full
17943 -- * Instance - The annotation is instantiated automatically when
17944 -- the related generic subprogram [body] is instantiated except for
17945 -- the "pragma on subprogram declaration" case. In that scenario
17946 -- the annotation must instantiate itself.
17948 when Pragma_Global => Global : declare
17950 Spec_Id : Entity_Id;
17951 Subp_Decl : Node_Id;
17954 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17958 -- Chain the pragma on the contract for further processing by
17959 -- Analyze_Global_In_Decl_Part.
17961 Add_Contract_Item (N, Spec_Id);
17963 -- Fully analyze the pragma when it appears inside an entry
17964 -- or subprogram body because it cannot benefit from forward
17967 if Nkind (Subp_Decl) in N_Entry_Body
17968 | N_Subprogram_Body
17969 | N_Subprogram_Body_Stub
17971 -- The legality checks of pragmas Depends and Global are
17972 -- affected by the SPARK mode in effect and the volatility
17973 -- of the context. In addition these two pragmas are subject
17974 -- to an inherent order:
17979 -- Analyze all these pragmas in the order outlined above
17981 Analyze_If_Present (Pragma_SPARK_Mode);
17982 Analyze_If_Present (Pragma_Volatile_Function);
17983 Analyze_If_Present (Pragma_Side_Effects);
17984 Analyze_Global_In_Decl_Part (N);
17985 Analyze_If_Present (Pragma_Depends);
17994 -- pragma Ident (static_string_EXPRESSION)
17996 -- Note: pragma Comment shares this processing. Pragma Ident is
17997 -- identical in effect to pragma Commment.
17999 when Pragma_Comment
18007 Check_Arg_Count (1);
18008 Check_No_Identifiers;
18009 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18012 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
18019 GP := Parent (Parent (N));
18022 N_Package_Declaration | N_Generic_Package_Declaration
18027 -- If we have a compilation unit, then record the ident value,
18028 -- checking for improper duplication.
18030 if Nkind (GP) = N_Compilation_Unit then
18031 CS := Ident_String (Current_Sem_Unit);
18033 if Present (CS) then
18035 -- If we have multiple instances, concatenate them.
18037 Start_String (Strval (CS));
18038 Store_String_Char (' ');
18039 Store_String_Chars (Strval (Str));
18040 Set_Strval (CS, End_String);
18043 Set_Ident_String (Current_Sem_Unit, Str);
18046 -- For subunits, we just ignore the Ident, since in GNAT these
18047 -- are not separate object files, and hence not separate units
18048 -- in the unit table.
18050 elsif Nkind (GP) = N_Subunit then
18056 -------------------
18057 -- Ignore_Pragma --
18058 -------------------
18060 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
18062 -- Entirely handled in the parser, nothing to do here
18064 when Pragma_Ignore_Pragma =>
18067 ----------------------------
18068 -- Implementation_Defined --
18069 ----------------------------
18071 -- pragma Implementation_Defined (LOCAL_NAME);
18073 -- Marks previously declared entity as implementation defined. For
18074 -- an overloaded entity, applies to the most recent homonym.
18076 -- pragma Implementation_Defined;
18078 -- The form with no arguments appears anywhere within a scope, most
18079 -- typically a package spec, and indicates that all entities that are
18080 -- defined within the package spec are Implementation_Defined.
18082 when Pragma_Implementation_Defined => Implementation_Defined : declare
18087 Check_No_Identifiers;
18089 -- Form with no arguments
18091 if Arg_Count = 0 then
18092 Set_Is_Implementation_Defined (Current_Scope);
18094 -- Form with one argument
18097 Check_Arg_Count (1);
18098 Check_Arg_Is_Local_Name (Arg1);
18099 Ent := Entity (Get_Pragma_Arg (Arg1));
18100 Set_Is_Implementation_Defined (Ent);
18102 end Implementation_Defined;
18108 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
18110 -- IMPLEMENTATION_KIND ::=
18111 -- By_Entry | By_Protected_Procedure | By_Any | Optional
18113 -- "By_Any" and "Optional" are treated as synonyms in order to
18114 -- support Ada 2012 aspect Synchronization.
18116 when Pragma_Implemented => Implemented : declare
18117 Proc_Id : Entity_Id;
18122 Check_Arg_Count (2);
18123 Check_No_Identifiers;
18124 Check_Arg_Is_Identifier (Arg1);
18125 Check_Arg_Is_Local_Name (Arg1);
18126 Check_Arg_Is_One_Of (Arg2,
18129 Name_By_Protected_Procedure,
18132 -- Extract the name of the local procedure
18134 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
18136 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
18137 -- primitive procedure of a synchronized tagged type.
18139 if Ekind (Proc_Id) = E_Procedure
18140 and then Is_Primitive (Proc_Id)
18141 and then Present (First_Formal (Proc_Id))
18143 Typ := Etype (First_Formal (Proc_Id));
18145 if Is_Tagged_Type (Typ)
18148 -- Check for a protected, a synchronized or a task interface
18150 ((Is_Interface (Typ)
18151 and then Is_Synchronized_Interface (Typ))
18153 -- Check for a protected type or a task type that implements
18157 (Is_Concurrent_Record_Type (Typ)
18158 and then Present (Interfaces (Typ)))
18160 -- In analysis-only mode, examine original protected type
18163 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
18164 and then Present (Interface_List (Parent (Typ))))
18166 -- Check for a private record extension with keyword
18170 (Ekind (Typ) in E_Record_Type_With_Private
18171 | E_Record_Subtype_With_Private
18172 and then Synchronized_Present (Parent (Typ))))
18177 ("controlling formal must be of synchronized tagged type",
18181 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
18182 -- By_Protected_Procedure to the primitive procedure of a task
18185 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
18186 and then Is_Interface (Typ)
18187 and then Is_Task_Interface (Typ)
18190 ("implementation kind By_Protected_Procedure cannot be "
18191 & "applied to a task interface primitive", Arg2);
18194 -- Procedures declared inside a protected type must be accepted
18196 elsif Ekind (Proc_Id) = E_Procedure
18197 and then Is_Protected_Type (Scope (Proc_Id))
18201 -- The first argument is not a primitive procedure
18205 ("pragma % must be applied to a primitive procedure", Arg1);
18208 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
18209 -- By_Protected_Procedure to a procedure that has aspect Yield
18211 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
18212 and then Has_Yield_Aspect (Proc_Id)
18215 ("implementation kind By_Protected_Procedure cannot be "
18216 & "applied to entities with aspect 'Yield", Arg2);
18219 Record_Rep_Item (Proc_Id, N);
18222 ----------------------
18223 -- Implicit_Packing --
18224 ----------------------
18226 -- pragma Implicit_Packing;
18228 when Pragma_Implicit_Packing =>
18230 Check_Arg_Count (0);
18231 Implicit_Packing := True;
18238 -- [Convention =>] convention_IDENTIFIER,
18239 -- [Entity =>] LOCAL_NAME
18240 -- [, [External_Name =>] static_string_EXPRESSION ]
18241 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18243 when Pragma_Import =>
18244 Check_Ada_83_Warning;
18248 Name_External_Name,
18251 Check_At_Least_N_Arguments (2);
18252 Check_At_Most_N_Arguments (4);
18253 Process_Import_Or_Interface;
18255 ---------------------
18256 -- Import_Function --
18257 ---------------------
18259 -- pragma Import_Function (
18260 -- [Internal =>] LOCAL_NAME,
18261 -- [, [External =>] EXTERNAL_SYMBOL]
18262 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18263 -- [, [Result_Type =>] SUBTYPE_MARK]
18264 -- [, [Mechanism =>] MECHANISM]
18265 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
18267 -- EXTERNAL_SYMBOL ::=
18269 -- | static_string_EXPRESSION
18271 -- PARAMETER_TYPES ::=
18273 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18275 -- TYPE_DESIGNATOR ::=
18277 -- | subtype_Name ' Access
18281 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18283 -- MECHANISM_ASSOCIATION ::=
18284 -- [formal_parameter_NAME =>] MECHANISM_NAME
18286 -- MECHANISM_NAME ::=
18290 when Pragma_Import_Function => Import_Function : declare
18291 Args : Args_List (1 .. 6);
18292 Names : constant Name_List (1 .. 6) := (
18295 Name_Parameter_Types,
18298 Name_Result_Mechanism);
18300 Internal : Node_Id renames Args (1);
18301 External : Node_Id renames Args (2);
18302 Parameter_Types : Node_Id renames Args (3);
18303 Result_Type : Node_Id renames Args (4);
18304 Mechanism : Node_Id renames Args (5);
18305 Result_Mechanism : Node_Id renames Args (6);
18309 Gather_Associations (Names, Args);
18310 Process_Extended_Import_Export_Subprogram_Pragma (
18311 Arg_Internal => Internal,
18312 Arg_External => External,
18313 Arg_Parameter_Types => Parameter_Types,
18314 Arg_Result_Type => Result_Type,
18315 Arg_Mechanism => Mechanism,
18316 Arg_Result_Mechanism => Result_Mechanism);
18317 end Import_Function;
18319 -------------------
18320 -- Import_Object --
18321 -------------------
18323 -- pragma Import_Object (
18324 -- [Internal =>] LOCAL_NAME
18325 -- [, [External =>] EXTERNAL_SYMBOL]
18326 -- [, [Size =>] EXTERNAL_SYMBOL]);
18328 -- EXTERNAL_SYMBOL ::=
18330 -- | static_string_EXPRESSION
18332 when Pragma_Import_Object => Import_Object : declare
18333 Args : Args_List (1 .. 3);
18334 Names : constant Name_List (1 .. 3) := (
18339 Internal : Node_Id renames Args (1);
18340 External : Node_Id renames Args (2);
18341 Size : Node_Id renames Args (3);
18345 Gather_Associations (Names, Args);
18346 Process_Extended_Import_Export_Object_Pragma (
18347 Arg_Internal => Internal,
18348 Arg_External => External,
18352 ----------------------
18353 -- Import_Procedure --
18354 ----------------------
18356 -- pragma Import_Procedure (
18357 -- [Internal =>] LOCAL_NAME
18358 -- [, [External =>] EXTERNAL_SYMBOL]
18359 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18360 -- [, [Mechanism =>] MECHANISM]);
18362 -- EXTERNAL_SYMBOL ::=
18364 -- | static_string_EXPRESSION
18366 -- PARAMETER_TYPES ::=
18368 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18370 -- TYPE_DESIGNATOR ::=
18372 -- | subtype_Name ' Access
18376 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18378 -- MECHANISM_ASSOCIATION ::=
18379 -- [formal_parameter_NAME =>] MECHANISM_NAME
18381 -- MECHANISM_NAME ::=
18385 when Pragma_Import_Procedure => Import_Procedure : declare
18386 Args : Args_List (1 .. 4);
18387 Names : constant Name_List (1 .. 4) := (
18390 Name_Parameter_Types,
18393 Internal : Node_Id renames Args (1);
18394 External : Node_Id renames Args (2);
18395 Parameter_Types : Node_Id renames Args (3);
18396 Mechanism : Node_Id renames Args (4);
18400 Gather_Associations (Names, Args);
18401 Process_Extended_Import_Export_Subprogram_Pragma (
18402 Arg_Internal => Internal,
18403 Arg_External => External,
18404 Arg_Parameter_Types => Parameter_Types,
18405 Arg_Mechanism => Mechanism);
18406 end Import_Procedure;
18408 -----------------------------
18409 -- Import_Valued_Procedure --
18410 -----------------------------
18412 -- pragma Import_Valued_Procedure (
18413 -- [Internal =>] LOCAL_NAME
18414 -- [, [External =>] EXTERNAL_SYMBOL]
18415 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18416 -- [, [Mechanism =>] MECHANISM]);
18418 -- EXTERNAL_SYMBOL ::=
18420 -- | static_string_EXPRESSION
18422 -- PARAMETER_TYPES ::=
18424 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18426 -- TYPE_DESIGNATOR ::=
18428 -- | subtype_Name ' Access
18432 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18434 -- MECHANISM_ASSOCIATION ::=
18435 -- [formal_parameter_NAME =>] MECHANISM_NAME
18437 -- MECHANISM_NAME ::=
18441 when Pragma_Import_Valued_Procedure =>
18442 Import_Valued_Procedure : declare
18443 Args : Args_List (1 .. 4);
18444 Names : constant Name_List (1 .. 4) := (
18447 Name_Parameter_Types,
18450 Internal : Node_Id renames Args (1);
18451 External : Node_Id renames Args (2);
18452 Parameter_Types : Node_Id renames Args (3);
18453 Mechanism : Node_Id renames Args (4);
18457 Gather_Associations (Names, Args);
18458 Process_Extended_Import_Export_Subprogram_Pragma (
18459 Arg_Internal => Internal,
18460 Arg_External => External,
18461 Arg_Parameter_Types => Parameter_Types,
18462 Arg_Mechanism => Mechanism);
18463 end Import_Valued_Procedure;
18469 -- pragma Independent (LOCAL_NAME);
18471 when Pragma_Independent =>
18472 Process_Atomic_Independent_Shared_Volatile;
18474 ----------------------------
18475 -- Independent_Components --
18476 ----------------------------
18478 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
18480 when Pragma_Independent_Components => Independent_Components : declare
18487 Check_Ada_83_Warning;
18489 Check_No_Identifiers;
18490 Check_Arg_Count (1);
18491 Check_Arg_Is_Local_Name (Arg1);
18492 E_Id := Get_Pragma_Arg (Arg1);
18494 if Etype (E_Id) = Any_Type then
18498 E := Entity (E_Id);
18500 -- A record type with a self-referential component of anonymous
18501 -- access type is given an incomplete view in order to handle the
18504 -- type Rec is record
18505 -- Self : access Rec;
18511 -- type Ptr is access Rec;
18512 -- type Rec is record
18516 -- Since the incomplete view is now the initial view of the type,
18517 -- the argument of the pragma will reference the incomplete view,
18518 -- but this view is illegal according to the semantics of the
18521 -- Obtain the full view of an internally-generated incomplete type
18522 -- only. This way an attempt to associate the pragma with a source
18523 -- incomplete type is still caught.
18525 if Ekind (E) = E_Incomplete_Type
18526 and then not Comes_From_Source (E)
18527 and then Present (Full_View (E))
18529 E := Full_View (E);
18532 -- A pragma that applies to a Ghost entity becomes Ghost for the
18533 -- purposes of legality checks and removal of ignored Ghost code.
18535 Mark_Ghost_Pragma (N, E);
18537 -- Check duplicate before we chain ourselves
18539 Check_Duplicate_Pragma (E);
18541 -- Check appropriate entity
18543 if Rep_Item_Too_Early (E, N)
18545 Rep_Item_Too_Late (E, N)
18550 D := Declaration_Node (E);
18552 -- The flag is set on the base type, or on the object
18554 if Nkind (D) = N_Full_Type_Declaration
18555 and then (Is_Array_Type (E) or else Is_Record_Type (E))
18557 Set_Has_Independent_Components (Base_Type (E));
18558 Record_Independence_Check (N, Base_Type (E));
18560 -- For record type, set all components independent
18562 if Is_Record_Type (E) then
18563 C := First_Component (E);
18564 while Present (C) loop
18565 Set_Is_Independent (C);
18566 Next_Component (C);
18570 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
18571 and then Nkind (D) = N_Object_Declaration
18572 and then Nkind (Object_Definition (D)) =
18573 N_Constrained_Array_Definition
18575 Set_Has_Independent_Components (E);
18576 Record_Independence_Check (N, E);
18579 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
18581 end Independent_Components;
18583 -----------------------
18584 -- Initial_Condition --
18585 -----------------------
18587 -- pragma Initial_Condition (boolean_EXPRESSION);
18589 -- Characteristics:
18591 -- * Analysis - The annotation undergoes initial checks to verify
18592 -- the legal placement and context. Secondary checks preanalyze the
18595 -- Analyze_Initial_Condition_In_Decl_Part
18597 -- * Expansion - The annotation is expanded during the expansion of
18598 -- the package body whose declaration is subject to the annotation
18601 -- Expand_Pragma_Initial_Condition
18603 -- * Template - The annotation utilizes the generic template of the
18604 -- related package declaration.
18606 -- * Globals - Capture of global references must occur after full
18609 -- * Instance - The annotation is instantiated automatically when
18610 -- the related generic package is instantiated.
18612 when Pragma_Initial_Condition => Initial_Condition : declare
18613 Pack_Decl : Node_Id;
18614 Pack_Id : Entity_Id;
18618 Check_No_Identifiers;
18619 Check_Arg_Count (1);
18621 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18623 if Nkind (Pack_Decl) not in
18624 N_Generic_Package_Declaration | N_Package_Declaration
18629 Pack_Id := Defining_Entity (Pack_Decl);
18631 -- A pragma that applies to a Ghost entity becomes Ghost for the
18632 -- purposes of legality checks and removal of ignored Ghost code.
18634 Mark_Ghost_Pragma (N, Pack_Id);
18636 -- Chain the pragma on the contract for further processing by
18637 -- Analyze_Initial_Condition_In_Decl_Part.
18639 Add_Contract_Item (N, Pack_Id);
18641 -- The legality checks of pragmas Abstract_State, Initializes, and
18642 -- Initial_Condition are affected by the SPARK mode in effect. In
18643 -- addition, these three pragmas are subject to an inherent order:
18645 -- 1) Abstract_State
18647 -- 3) Initial_Condition
18649 -- Analyze all these pragmas in the order outlined above
18651 Analyze_If_Present (Pragma_SPARK_Mode);
18652 Analyze_If_Present (Pragma_Abstract_State);
18653 Analyze_If_Present (Pragma_Initializes);
18654 end Initial_Condition;
18656 ------------------------
18657 -- Initialize_Scalars --
18658 ------------------------
18660 -- pragma Initialize_Scalars
18661 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
18663 -- TYPE_VALUE_PAIR ::=
18664 -- SCALAR_TYPE => static_EXPRESSION
18670 -- | Long_Long_Float
18682 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
18683 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
18684 -- This collection holds the individual pairs which specify the
18685 -- invalid values of their respective scalar types.
18687 procedure Analyze_Float_Value
18688 (Scal_Typ : Float_Scalar_Id;
18689 Val_Expr : Node_Id);
18690 -- Analyze a type value pair associated with float type Scal_Typ
18691 -- and expression Val_Expr.
18693 procedure Analyze_Integer_Value
18694 (Scal_Typ : Integer_Scalar_Id;
18695 Val_Expr : Node_Id);
18696 -- Analyze a type value pair associated with integer type Scal_Typ
18697 -- and expression Val_Expr.
18699 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
18700 -- Analyze type value pair Pair
18702 -------------------------
18703 -- Analyze_Float_Value --
18704 -------------------------
18706 procedure Analyze_Float_Value
18707 (Scal_Typ : Float_Scalar_Id;
18708 Val_Expr : Node_Id)
18711 Analyze_And_Resolve (Val_Expr, Any_Real);
18713 if Is_OK_Static_Expression (Val_Expr) then
18714 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
18717 Error_Msg_Name_1 := Scal_Typ;
18718 Error_Msg_N ("value for type % must be static", Val_Expr);
18720 end Analyze_Float_Value;
18722 ---------------------------
18723 -- Analyze_Integer_Value --
18724 ---------------------------
18726 procedure Analyze_Integer_Value
18727 (Scal_Typ : Integer_Scalar_Id;
18728 Val_Expr : Node_Id)
18731 Analyze_And_Resolve (Val_Expr, Any_Integer);
18733 if (Scal_Typ = Name_Signed_128
18734 or else Scal_Typ = Name_Unsigned_128)
18735 and then Ttypes.System_Max_Integer_Size < 128
18737 Error_Msg_Name_1 := Scal_Typ;
18738 Error_Msg_N ("value cannot be set for type %", Val_Expr);
18740 elsif Is_OK_Static_Expression (Val_Expr) then
18741 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
18744 Error_Msg_Name_1 := Scal_Typ;
18745 Error_Msg_N ("value for type % must be static", Val_Expr);
18747 end Analyze_Integer_Value;
18749 -----------------------------
18750 -- Analyze_Type_Value_Pair --
18751 -----------------------------
18753 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
18754 Scal_Typ : constant Name_Id := Chars (Pair);
18755 Val_Expr : constant Node_Id := Expression (Pair);
18756 Prev_Pair : Node_Id;
18759 if Scal_Typ in Scalar_Id then
18760 Prev_Pair := Seen (Scal_Typ);
18762 -- Prevent multiple attempts to set a value for a scalar
18765 if Present (Prev_Pair) then
18766 Error_Msg_Name_1 := Scal_Typ;
18768 ("cannot specify multiple invalid values for type %",
18771 Error_Msg_Sloc := Sloc (Prev_Pair);
18772 Error_Msg_N ("previous value set #", Pair);
18774 -- Ignore the effects of the pair, but do not halt the
18775 -- analysis of the pragma altogether.
18779 -- Otherwise capture the first pair for this scalar type
18782 Seen (Scal_Typ) := Pair;
18785 if Scal_Typ in Float_Scalar_Id then
18786 Analyze_Float_Value (Scal_Typ, Val_Expr);
18788 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
18789 Analyze_Integer_Value (Scal_Typ, Val_Expr);
18792 -- Otherwise the scalar family is illegal
18795 Error_Msg_Name_1 := Pname;
18797 ("argument of pragma % must denote valid scalar family",
18800 end Analyze_Type_Value_Pair;
18804 Pairs : constant List_Id := Pragma_Argument_Associations (N);
18807 -- Start of processing for Do_Initialize_Scalars
18811 Check_Valid_Configuration_Pragma;
18812 Check_Restriction (No_Initialize_Scalars, N);
18814 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18817 if Restriction_Active (No_Initialize_Scalars) then
18820 -- Initialize_Scalars creates false positives in CodePeer, and
18821 -- incorrect negative results in GNATprove mode, so ignore this
18822 -- pragma in these modes.
18824 elsif CodePeer_Mode or GNATprove_Mode then
18827 -- Otherwise analyze the pragma
18830 if Present (Pairs) then
18832 -- Install Standard in order to provide access to primitive
18833 -- types in case the expressions contain attributes such as
18836 Push_Scope (Standard_Standard);
18838 Pair := First (Pairs);
18839 while Present (Pair) loop
18840 Analyze_Type_Value_Pair (Pair);
18849 Init_Or_Norm_Scalars := True;
18850 Initialize_Scalars := True;
18852 end Do_Initialize_Scalars;
18858 -- pragma Initializes (INITIALIZATION_LIST);
18860 -- INITIALIZATION_LIST ::=
18862 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18864 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18869 -- | (INPUT {, INPUT})
18873 -- Characteristics:
18875 -- * Analysis - The annotation undergoes initial checks to verify
18876 -- the legal placement and context. Secondary checks preanalyze the
18879 -- Analyze_Initializes_In_Decl_Part
18881 -- * Expansion - None.
18883 -- * Template - The annotation utilizes the generic template of the
18884 -- related package declaration.
18886 -- * Globals - Capture of global references must occur after full
18889 -- * Instance - The annotation is instantiated automatically when
18890 -- the related generic package is instantiated.
18892 when Pragma_Initializes => Initializes : declare
18893 Pack_Decl : Node_Id;
18894 Pack_Id : Entity_Id;
18898 Check_No_Identifiers;
18899 Check_Arg_Count (1);
18901 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18903 if Nkind (Pack_Decl) not in
18904 N_Generic_Package_Declaration | N_Package_Declaration
18909 Pack_Id := Defining_Entity (Pack_Decl);
18911 -- A pragma that applies to a Ghost entity becomes Ghost for the
18912 -- purposes of legality checks and removal of ignored Ghost code.
18914 Mark_Ghost_Pragma (N, Pack_Id);
18915 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18917 -- Chain the pragma on the contract for further processing by
18918 -- Analyze_Initializes_In_Decl_Part.
18920 Add_Contract_Item (N, Pack_Id);
18922 -- The legality checks of pragmas Abstract_State, Initializes, and
18923 -- Initial_Condition are affected by the SPARK mode in effect. In
18924 -- addition, these three pragmas are subject to an inherent order:
18926 -- 1) Abstract_State
18928 -- 3) Initial_Condition
18930 -- Analyze all these pragmas in the order outlined above
18932 Analyze_If_Present (Pragma_SPARK_Mode);
18933 Analyze_If_Present (Pragma_Abstract_State);
18934 Analyze_If_Present (Pragma_Initial_Condition);
18941 -- pragma Inline ( NAME {, NAME} );
18943 when Pragma_Inline =>
18945 -- Pragma always active unless in GNATprove mode. It is disabled
18946 -- in GNATprove mode because frontend inlining is applied
18947 -- independently of pragmas Inline and Inline_Always for
18948 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18951 if not GNATprove_Mode then
18953 -- Inline status is Enabled if option -gnatn is specified.
18954 -- However this status determines only the value of the
18955 -- Is_Inlined flag on the subprogram and does not prevent
18956 -- the pragma itself from being recorded for later use,
18957 -- in particular for a later modification of Is_Inlined
18958 -- independently of the -gnatn option.
18960 -- In other words, if -gnatn is specified for a unit, then
18961 -- all Inline pragmas processed for the compilation of this
18962 -- unit, including those in the spec of other units, are
18963 -- activated, so subprograms will be inlined across units.
18965 -- If -gnatn is not specified, no Inline pragma is activated
18966 -- here, which means that subprograms will not be inlined
18967 -- across units. The Is_Inlined flag will nevertheless be
18968 -- set later when bodies are analyzed, so subprograms will
18969 -- be inlined within the unit.
18971 if Inline_Active then
18972 Process_Inline (Enabled);
18974 Process_Inline (Disabled);
18978 -------------------
18979 -- Inline_Always --
18980 -------------------
18982 -- pragma Inline_Always ( NAME {, NAME} );
18984 when Pragma_Inline_Always =>
18987 -- Pragma always active unless in CodePeer mode or GNATprove
18988 -- mode. It is disabled in CodePeer mode because inlining is
18989 -- not helpful, and enabling it caused walk order issues. It
18990 -- is disabled in GNATprove mode because frontend inlining is
18991 -- applied independently of pragmas Inline and Inline_Always for
18992 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18995 if not CodePeer_Mode and not GNATprove_Mode then
18996 Process_Inline (Enabled);
18999 --------------------
19000 -- Inline_Generic --
19001 --------------------
19003 -- pragma Inline_Generic (NAME {, NAME});
19005 when Pragma_Inline_Generic =>
19007 Process_Generic_List;
19009 ----------------------
19010 -- Inspection_Point --
19011 ----------------------
19013 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
19015 when Pragma_Inspection_Point => Inspection_Point : declare
19022 if Arg_Count > 0 then
19025 Exp := Get_Pragma_Arg (Arg);
19028 if not Is_Entity_Name (Exp)
19029 or else not Is_Object (Entity (Exp))
19031 Error_Pragma_Arg ("object name required", Arg);
19035 exit when No (Arg);
19038 end Inspection_Point;
19044 -- pragma Interface (
19045 -- [ Convention =>] convention_IDENTIFIER,
19046 -- [ Entity =>] LOCAL_NAME
19047 -- [, [External_Name =>] static_string_EXPRESSION ]
19048 -- [, [Link_Name =>] static_string_EXPRESSION ]);
19050 when Pragma_Interface =>
19055 Name_External_Name,
19057 Check_At_Least_N_Arguments (2);
19058 Check_At_Most_N_Arguments (4);
19059 Process_Import_Or_Interface;
19061 -- In Ada 2005, the permission to use Interface (a reserved word)
19062 -- as a pragma name is considered an obsolescent feature, and this
19063 -- pragma was already obsolescent in Ada 95.
19065 if Ada_Version >= Ada_95 then
19067 (No_Obsolescent_Features, Pragma_Identifier (N));
19069 if Warn_On_Obsolescent_Feature then
19071 ("pragma Interface is an obsolescent feature?j?", N);
19073 ("|use pragma Import instead?j?", N);
19077 --------------------
19078 -- Interface_Name --
19079 --------------------
19081 -- pragma Interface_Name (
19082 -- [ Entity =>] LOCAL_NAME
19083 -- [,[External_Name =>] static_string_EXPRESSION ]
19084 -- [,[Link_Name =>] static_string_EXPRESSION ]);
19086 when Pragma_Interface_Name => Interface_Name : declare
19088 Def_Id : Entity_Id;
19089 Hom_Id : Entity_Id;
19095 ((Name_Entity, Name_External_Name, Name_Link_Name));
19096 Check_At_Least_N_Arguments (2);
19097 Check_At_Most_N_Arguments (3);
19098 Id := Get_Pragma_Arg (Arg1);
19101 -- This is obsolete from Ada 95 on, but it is an implementation
19102 -- defined pragma, so we do not consider that it violates the
19103 -- restriction (No_Obsolescent_Features).
19105 if Ada_Version >= Ada_95 then
19106 if Warn_On_Obsolescent_Feature then
19108 ("pragma Interface_Name is an obsolescent feature?j?", N);
19110 ("|use pragma Import instead?j?", N);
19114 if not Is_Entity_Name (Id) then
19116 ("first argument for pragma% must be entity name", Arg1);
19117 elsif Etype (Id) = Any_Type then
19120 Def_Id := Entity (Id);
19123 -- Special DEC-compatible processing for the object case, forces
19124 -- object to be imported.
19126 if Ekind (Def_Id) = E_Variable then
19127 Kill_Size_Check_Code (Def_Id);
19128 Note_Possible_Modification (Id, Sure => False);
19130 -- Initialization is not allowed for imported variable
19132 if Present (Expression (Parent (Def_Id)))
19133 and then Comes_From_Source (Expression (Parent (Def_Id)))
19135 Error_Msg_Sloc := Sloc (Def_Id);
19137 ("no initialization allowed for declaration of& #",
19141 -- For compatibility, support VADS usage of providing both
19142 -- pragmas Interface and Interface_Name to obtain the effect
19143 -- of a single Import pragma.
19145 if Is_Imported (Def_Id)
19146 and then Present (First_Rep_Item (Def_Id))
19147 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
19148 and then Pragma_Name (First_Rep_Item (Def_Id)) =
19153 Set_Imported (Def_Id);
19156 Set_Is_Public (Def_Id);
19157 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
19160 -- Otherwise must be subprogram
19162 elsif not Is_Subprogram (Def_Id) then
19164 ("argument of pragma% is not subprogram", Arg1);
19167 Check_At_Most_N_Arguments (3);
19171 -- Loop through homonyms
19174 Def_Id := Get_Base_Subprogram (Hom_Id);
19176 if Is_Imported (Def_Id) then
19177 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
19181 exit when From_Aspect_Specification (N);
19182 Hom_Id := Homonym (Hom_Id);
19184 exit when No (Hom_Id)
19185 or else Scope (Hom_Id) /= Current_Scope;
19190 ("argument of pragma% is not imported subprogram",
19194 end Interface_Name;
19196 -----------------------
19197 -- Interrupt_Handler --
19198 -----------------------
19200 -- pragma Interrupt_Handler (handler_NAME);
19202 when Pragma_Interrupt_Handler =>
19203 Check_Ada_83_Warning;
19204 Check_Arg_Count (1);
19205 Check_No_Identifiers;
19207 if No_Run_Time_Mode then
19208 Error_Msg_CRT ("Interrupt_Handler pragma", N);
19210 Check_Interrupt_Or_Attach_Handler;
19211 Process_Interrupt_Or_Attach_Handler;
19214 ------------------------
19215 -- Interrupt_Priority --
19216 ------------------------
19218 -- pragma Interrupt_Priority [(EXPRESSION)];
19220 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
19221 P : constant Node_Id := Parent (N);
19226 Check_Ada_83_Warning;
19228 if Arg_Count /= 0 then
19229 Arg := Get_Pragma_Arg (Arg1);
19230 Check_Arg_Count (1);
19231 Check_No_Identifiers;
19233 -- The expression must be analyzed in the special manner
19234 -- described in "Handling of Default and Per-Object
19235 -- Expressions" in sem.ads.
19237 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
19240 if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
19244 Ent := Defining_Identifier (Parent (P));
19246 -- Check duplicate pragma before we chain the pragma in the Rep
19247 -- Item chain of Ent.
19249 Check_Duplicate_Pragma (Ent);
19250 Record_Rep_Item (Ent, N);
19252 -- Check the No_Task_At_Interrupt_Priority restriction
19254 if Nkind (P) = N_Task_Definition then
19255 Check_Restriction (No_Task_At_Interrupt_Priority, N);
19258 end Interrupt_Priority;
19260 ---------------------
19261 -- Interrupt_State --
19262 ---------------------
19264 -- pragma Interrupt_State (
19265 -- [Name =>] INTERRUPT_ID,
19266 -- [State =>] INTERRUPT_STATE);
19268 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
19269 -- INTERRUPT_STATE => System | Runtime | User
19271 -- Note: if the interrupt id is given as an identifier, then it must
19272 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
19273 -- given as a static integer expression which must be in the range of
19274 -- Ada.Interrupts.Interrupt_ID.
19276 when Pragma_Interrupt_State => Interrupt_State : declare
19277 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
19278 -- This is the entity Ada.Interrupts.Interrupt_ID;
19280 State_Type : Character;
19281 -- Set to 's'/'r'/'u' for System/Runtime/User
19284 -- Index to entry in Interrupt_States table
19287 -- Value of interrupt
19289 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
19290 -- The first argument to the pragma
19292 Int_Ent : Entity_Id;
19293 -- Interrupt entity in Ada.Interrupts.Names
19297 Check_Arg_Order ((Name_Name, Name_State));
19298 Check_Arg_Count (2);
19300 Check_Optional_Identifier (Arg1, Name_Name);
19301 Check_Optional_Identifier (Arg2, Name_State);
19302 Check_Arg_Is_Identifier (Arg2);
19304 -- First argument is identifier
19306 if Nkind (Arg1X) = N_Identifier then
19308 -- Search list of names in Ada.Interrupts.Names
19310 Int_Ent := First_Entity (RTE (RE_Names));
19312 if No (Int_Ent) then
19313 Error_Pragma_Arg ("invalid interrupt name", Arg1);
19315 elsif Chars (Int_Ent) = Chars (Arg1X) then
19316 Int_Val := Expr_Value (Constant_Value (Int_Ent));
19320 Next_Entity (Int_Ent);
19323 -- First argument is not an identifier, so it must be a static
19324 -- expression of type Ada.Interrupts.Interrupt_ID.
19327 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
19328 Int_Val := Expr_Value (Arg1X);
19330 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
19332 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
19335 ("value not in range of type "
19336 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
19342 case Chars (Get_Pragma_Arg (Arg2)) is
19343 when Name_Runtime => State_Type := 'r';
19344 when Name_System => State_Type := 's';
19345 when Name_User => State_Type := 'u';
19348 Error_Pragma_Arg ("invalid interrupt state", Arg2);
19351 -- Check if entry is already stored
19353 IST_Num := Interrupt_States.First;
19355 -- If entry not found, add it
19357 if IST_Num > Interrupt_States.Last then
19358 Interrupt_States.Append
19359 ((Interrupt_Number => UI_To_Int (Int_Val),
19360 Interrupt_State => State_Type,
19361 Pragma_Loc => Loc));
19364 -- Case of entry for the same entry
19366 elsif Int_Val = Interrupt_States.Table (IST_Num).
19369 -- If state matches, done, no need to make redundant entry
19372 State_Type = Interrupt_States.Table (IST_Num).
19375 -- Otherwise if state does not match, error
19378 Interrupt_States.Table (IST_Num).Pragma_Loc;
19380 ("state conflicts with that given #", Arg2);
19383 IST_Num := IST_Num + 1;
19385 end Interrupt_State;
19391 -- pragma Invariant
19392 -- ([Entity =>] type_LOCAL_NAME,
19393 -- [Check =>] EXPRESSION
19394 -- [,[Message =>] String_Expression]);
19396 when Pragma_Invariant => Invariant : declare
19403 Check_At_Least_N_Arguments (2);
19404 Check_At_Most_N_Arguments (3);
19405 Check_Optional_Identifier (Arg1, Name_Entity);
19406 Check_Optional_Identifier (Arg2, Name_Check);
19408 if Arg_Count = 3 then
19409 Check_Optional_Identifier (Arg3, Name_Message);
19410 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
19413 Check_Arg_Is_Local_Name (Arg1);
19415 Typ_Arg := Get_Pragma_Arg (Arg1);
19416 Find_Type (Typ_Arg);
19417 Typ := Entity (Typ_Arg);
19419 -- Nothing to do of the related type is erroneous in some way
19421 if Typ = Any_Type then
19424 -- AI12-0041: Invariants are allowed in interface types
19426 elsif Is_Interface (Typ) then
19429 -- An invariant must apply to a private type, or appear in the
19430 -- private part of a package spec and apply to a completion.
19431 -- a class-wide invariant can only appear on a private declaration
19432 -- or private extension, not a completion.
19434 -- A [class-wide] invariant may be associated a [limited] private
19435 -- type or a private extension.
19437 elsif Ekind (Typ) in E_Limited_Private_Type
19439 | E_Record_Type_With_Private
19443 -- A non-class-wide invariant may be associated with the full view
19444 -- of a [limited] private type or a private extension.
19446 elsif Has_Private_Declaration (Typ)
19447 and then not Class_Present (N)
19451 -- A class-wide invariant may appear on the partial view only
19453 elsif Class_Present (N) then
19455 ("pragma % only allowed for private type", Arg1);
19457 -- A regular invariant may appear on both views
19461 ("pragma % only allowed for private type or corresponding "
19462 & "full view", Arg1);
19465 -- An invariant associated with an abstract type (this includes
19466 -- interfaces) must be class-wide.
19468 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
19470 ("pragma % not allowed for abstract type", Arg1);
19473 -- A pragma that applies to a Ghost entity becomes Ghost for the
19474 -- purposes of legality checks and removal of ignored Ghost code.
19476 Mark_Ghost_Pragma (N, Typ);
19478 -- The pragma defines a type-specific invariant, the type is said
19479 -- to have invariants of its "own".
19481 Set_Has_Own_Invariants (Base_Type (Typ));
19483 -- If the invariant is class-wide, then it can be inherited by
19484 -- derived or interface implementing types. The type is said to
19485 -- have "inheritable" invariants.
19487 if Class_Present (N) then
19488 Set_Has_Inheritable_Invariants (Typ);
19491 -- Chain the pragma on to the rep item chain, for processing when
19492 -- the type is frozen.
19494 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19496 -- Create the declaration of the invariant procedure that will
19497 -- verify the invariant at run time. Interfaces are treated as the
19498 -- partial view of a private type in order to achieve uniformity
19499 -- with the general case. As a result, an interface receives only
19500 -- a "partial" invariant procedure, which is never called.
19502 Build_Invariant_Procedure_Declaration
19504 Partial_Invariant => Is_Interface (Typ));
19511 -- pragma Keep_Names ([On => ] LOCAL_NAME);
19513 when Pragma_Keep_Names => Keep_Names : declare
19518 Check_Arg_Count (1);
19519 Check_Optional_Identifier (Arg1, Name_On);
19520 Check_Arg_Is_Local_Name (Arg1);
19522 Arg := Get_Pragma_Arg (Arg1);
19525 if Etype (Arg) = Any_Type then
19529 if not Is_Entity_Name (Arg)
19530 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
19533 ("pragma% requires a local enumeration type", Arg1);
19536 Set_Discard_Names (Entity (Arg), False);
19543 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
19545 when Pragma_License =>
19548 -- Do not analyze pragma any further in CodePeer mode, to avoid
19549 -- extraneous errors in this implementation-dependent pragma,
19550 -- which has a different profile on other compilers.
19552 if CodePeer_Mode then
19556 Check_Arg_Count (1);
19557 Check_No_Identifiers;
19558 Check_Valid_Configuration_Pragma;
19559 Check_Arg_Is_Identifier (Arg1);
19562 Sind : constant Source_File_Index :=
19563 Source_Index (Current_Sem_Unit);
19566 case Chars (Get_Pragma_Arg (Arg1)) is
19568 Set_License (Sind, GPL);
19570 when Name_Modified_GPL =>
19571 Set_License (Sind, Modified_GPL);
19573 when Name_Restricted =>
19574 Set_License (Sind, Restricted);
19576 when Name_Unrestricted =>
19577 Set_License (Sind, Unrestricted);
19580 Error_Pragma_Arg ("invalid license name", Arg1);
19588 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
19590 when Pragma_Link_With => Link_With : declare
19596 if Operating_Mode = Generate_Code
19597 and then In_Extended_Main_Source_Unit (N)
19599 Check_At_Least_N_Arguments (1);
19600 Check_No_Identifiers;
19601 Check_Is_In_Decl_Part_Or_Package_Spec;
19602 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19606 while Present (Arg) loop
19607 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19609 -- Store argument, converting sequences of spaces to a
19610 -- single null character (this is one of the differences
19611 -- in processing between Link_With and Linker_Options).
19613 Arg_Store : declare
19614 C : constant Char_Code := Get_Char_Code (' ');
19615 S : constant String_Id :=
19616 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
19617 L : constant Nat := String_Length (S);
19620 procedure Skip_Spaces;
19621 -- Advance F past any spaces
19627 procedure Skip_Spaces is
19629 while F <= L and then Get_String_Char (S, F) = C loop
19634 -- Start of processing for Arg_Store
19637 Skip_Spaces; -- skip leading spaces
19639 -- Loop through characters, changing any embedded
19640 -- sequence of spaces to a single null character (this
19641 -- is how Link_With/Linker_Options differ)
19644 if Get_String_Char (S, F) = C then
19647 Store_String_Char (ASCII.NUL);
19650 Store_String_Char (Get_String_Char (S, F));
19658 if Present (Arg) then
19659 Store_String_Char (ASCII.NUL);
19663 Store_Linker_Option_String (End_String);
19671 -- pragma Linker_Alias (
19672 -- [Entity =>] LOCAL_NAME
19673 -- [Target =>] static_string_EXPRESSION);
19675 when Pragma_Linker_Alias =>
19677 Check_Arg_Order ((Name_Entity, Name_Target));
19678 Check_Arg_Count (2);
19679 Check_Optional_Identifier (Arg1, Name_Entity);
19680 Check_Optional_Identifier (Arg2, Name_Target);
19681 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19682 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19684 -- The only processing required is to link this item on to the
19685 -- list of rep items for the given entity. This is accomplished
19686 -- by the call to Rep_Item_Too_Late (when no error is detected
19687 -- and False is returned).
19689 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
19692 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19695 ------------------------
19696 -- Linker_Constructor --
19697 ------------------------
19699 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19701 -- Code is shared with Linker_Destructor
19703 -----------------------
19704 -- Linker_Destructor --
19705 -----------------------
19707 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19709 when Pragma_Linker_Constructor
19710 | Pragma_Linker_Destructor
19712 Linker_Constructor : declare
19718 Check_Arg_Count (1);
19719 Check_No_Identifiers;
19720 Check_Arg_Is_Local_Name (Arg1);
19721 Arg1_X := Get_Pragma_Arg (Arg1);
19723 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
19725 if not Is_Library_Level_Entity (Proc) then
19727 ("argument for pragma% must be library level entity", Arg1);
19730 -- The only processing required is to link this item on to the
19731 -- list of rep items for the given entity. This is accomplished
19732 -- by the call to Rep_Item_Too_Late (when no error is detected
19733 -- and False is returned).
19735 if Rep_Item_Too_Late (Proc, N) then
19738 Set_Has_Gigi_Rep_Item (Proc);
19740 end Linker_Constructor;
19742 --------------------
19743 -- Linker_Options --
19744 --------------------
19746 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19748 when Pragma_Linker_Options => Linker_Options : declare
19752 Check_Ada_83_Warning;
19753 Check_No_Identifiers;
19754 Check_Arg_Count (1);
19755 Check_Is_In_Decl_Part_Or_Package_Spec;
19756 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19757 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
19760 while Present (Arg) loop
19761 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19762 Store_String_Char (ASCII.NUL);
19764 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
19768 if Operating_Mode = Generate_Code
19769 and then In_Extended_Main_Source_Unit (N)
19771 Store_Linker_Option_String (End_String);
19773 end Linker_Options;
19775 --------------------
19776 -- Linker_Section --
19777 --------------------
19779 -- pragma Linker_Section (
19780 -- [Entity =>] LOCAL_NAME
19781 -- [Section =>] static_string_EXPRESSION);
19783 when Pragma_Linker_Section => Linker_Section : declare
19788 Ghost_Error_Posted : Boolean := False;
19789 -- Flag set when an error concerning the illegal mix of Ghost and
19790 -- non-Ghost subprograms is emitted.
19792 Ghost_Id : Entity_Id := Empty;
19793 -- The entity of the first Ghost subprogram encountered while
19794 -- processing the arguments of the pragma.
19798 Check_Arg_Order ((Name_Entity, Name_Section));
19799 Check_Arg_Count (2);
19800 Check_Optional_Identifier (Arg1, Name_Entity);
19801 Check_Optional_Identifier (Arg2, Name_Section);
19802 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19803 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19805 -- Check kind of entity
19807 Arg := Get_Pragma_Arg (Arg1);
19808 Ent := Entity (Arg);
19810 case Ekind (Ent) is
19812 -- Objects (constants and variables) and types. For these cases
19813 -- all we need to do is to set the Linker_Section_pragma field,
19814 -- checking that we do not have a duplicate.
19820 LPE := Linker_Section_Pragma (Ent);
19822 if Present (LPE) then
19823 Error_Msg_Sloc := Sloc (LPE);
19825 ("Linker_Section already specified for &#", Arg1, Ent);
19828 Set_Linker_Section_Pragma (Ent, N);
19830 -- A pragma that applies to a Ghost entity becomes Ghost for
19831 -- the purposes of legality checks and removal of ignored
19834 Mark_Ghost_Pragma (N, Ent);
19838 when Subprogram_Kind =>
19840 -- Aspect case, entity already set
19842 if From_Aspect_Specification (N) then
19843 Set_Linker_Section_Pragma
19844 (Entity (Corresponding_Aspect (N)), N);
19846 -- Propagate it to its ultimate aliased entity to
19847 -- facilitate the backend processing this attribute
19848 -- in instantiations of generic subprograms.
19850 if Present (Alias (Entity (Corresponding_Aspect (N))))
19852 Set_Linker_Section_Pragma
19854 (Entity (Corresponding_Aspect (N))), N);
19857 -- Pragma case, we must climb the homonym chain, but skip
19858 -- any for which the linker section is already set.
19862 if No (Linker_Section_Pragma (Ent)) then
19863 Set_Linker_Section_Pragma (Ent, N);
19865 -- Propagate it to its ultimate aliased entity to
19866 -- facilitate the backend processing this attribute
19867 -- in instantiations of generic subprograms.
19869 if Present (Alias (Ent)) then
19870 Set_Linker_Section_Pragma
19871 (Ultimate_Alias (Ent), N);
19874 -- A pragma that applies to a Ghost entity becomes
19875 -- Ghost for the purposes of legality checks and
19876 -- removal of ignored Ghost code.
19878 Mark_Ghost_Pragma (N, Ent);
19880 -- Capture the entity of the first Ghost subprogram
19881 -- being processed for error detection purposes.
19883 if Is_Ghost_Entity (Ent) then
19884 if No (Ghost_Id) then
19888 -- Otherwise the subprogram is non-Ghost. It is
19889 -- illegal to mix references to Ghost and non-Ghost
19890 -- entities (SPARK RM 6.9).
19892 elsif Present (Ghost_Id)
19893 and then not Ghost_Error_Posted
19895 Ghost_Error_Posted := True;
19897 Error_Msg_Name_1 := Pname;
19899 ("pragma % cannot mention ghost and "
19900 & "non-ghost subprograms", N);
19902 Error_Msg_Sloc := Sloc (Ghost_Id);
19904 ("\& # declared as ghost", N, Ghost_Id);
19906 Error_Msg_Sloc := Sloc (Ent);
19908 ("\& # declared as non-ghost", N, Ent);
19912 Ent := Homonym (Ent);
19914 or else Scope (Ent) /= Current_Scope;
19918 -- All other cases are illegal
19922 ("pragma% applies only to objects, subprograms, and types",
19925 end Linker_Section;
19931 -- pragma List (On | Off)
19933 -- There is nothing to do here, since we did all the processing for
19934 -- this pragma in Par.Prag (so that it works properly even in syntax
19937 when Pragma_List =>
19944 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19946 when Pragma_Lock_Free => Lock_Free : declare
19947 P : constant Node_Id := Parent (N);
19953 Check_No_Identifiers;
19954 Check_At_Most_N_Arguments (1);
19956 -- Protected definition case
19958 if Nkind (P) = N_Protected_Definition then
19959 Ent := Defining_Identifier (Parent (P));
19963 if Arg_Count = 1 then
19964 Arg := Get_Pragma_Arg (Arg1);
19965 Val := Is_True (Static_Boolean (Arg));
19967 -- No arguments (expression is considered to be True)
19973 -- Check duplicate pragma before we chain the pragma in the Rep
19974 -- Item chain of Ent.
19976 Check_Duplicate_Pragma (Ent);
19977 Record_Rep_Item (Ent, N);
19978 Set_Uses_Lock_Free (Ent, Val);
19980 -- Anything else is incorrect placement
19987 --------------------
19988 -- Locking_Policy --
19989 --------------------
19991 -- pragma Locking_Policy (policy_IDENTIFIER);
19993 when Pragma_Locking_Policy => declare
19994 subtype LP_Range is Name_Id
19995 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
20000 Check_Ada_83_Warning;
20001 Check_Arg_Count (1);
20002 Check_No_Identifiers;
20003 Check_Arg_Is_Locking_Policy (Arg1);
20004 Check_Valid_Configuration_Pragma;
20005 LP_Val := Chars (Get_Pragma_Arg (Arg1));
20008 when Name_Ceiling_Locking => LP := 'C';
20009 when Name_Concurrent_Readers_Locking => LP := 'R';
20010 when Name_Inheritance_Locking => LP := 'I';
20013 if Locking_Policy /= ' '
20014 and then Locking_Policy /= LP
20016 Error_Msg_Sloc := Locking_Policy_Sloc;
20017 Error_Pragma ("locking policy incompatible with policy#");
20019 -- Set new policy, but always preserve System_Location since we
20020 -- like the error message with the run time name.
20023 Locking_Policy := LP;
20025 if Locking_Policy_Sloc /= System_Location then
20026 Locking_Policy_Sloc := Loc;
20031 -------------------
20032 -- Loop_Optimize --
20033 -------------------
20035 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
20037 -- OPTIMIZATION_HINT ::=
20038 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
20040 when Pragma_Loop_Optimize => Loop_Optimize : declare
20045 Check_At_Least_N_Arguments (1);
20046 Check_No_Identifiers;
20048 Hint := First (Pragma_Argument_Associations (N));
20049 while Present (Hint) loop
20050 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
20058 Check_Loop_Pragma_Placement;
20065 -- pragma Loop_Variant
20066 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
20068 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
20070 -- CHANGE_DIRECTION ::= Increases | Decreases
20072 when Pragma_Loop_Variant => Loop_Variant : declare
20077 Check_At_Least_N_Arguments (1);
20078 Check_Loop_Pragma_Placement;
20080 -- Process all increasing / decreasing expressions
20082 Variant := First (Pragma_Argument_Associations (N));
20083 while Present (Variant) loop
20084 if Chars (Variant) = No_Name then
20085 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
20087 elsif Chars (Variant) not in
20088 Name_Decreases | Name_Increases | Name_Structural
20091 Name : String := Get_Name_String (Chars (Variant));
20094 -- It is a common mistake to write "Increasing" for
20095 -- "Increases" or "Decreasing" for "Decreases". Recognize
20096 -- specially names starting with "incr" or "decr" to
20097 -- suggest the corresponding name.
20099 System.Case_Util.To_Lower (Name);
20101 if Name'Length >= 4
20102 and then Name (1 .. 4) = "incr"
20104 Error_Pragma_Arg_Ident
20105 ("expect name `Increases`", Variant);
20107 elsif Name'Length >= 4
20108 and then Name (1 .. 4) = "decr"
20110 Error_Pragma_Arg_Ident
20111 ("expect name `Decreases`", Variant);
20113 elsif Name'Length >= 4
20114 and then Name (1 .. 4) = "stru"
20116 Error_Pragma_Arg_Ident
20117 ("expect name `Structural`", Variant);
20120 Error_Pragma_Arg_Ident
20121 ("expect name `Increases`, `Decreases`,"
20122 & " or `Structural`", Variant);
20126 elsif Chars (Variant) = Name_Structural
20127 and then List_Length (Pragma_Argument_Associations (N)) > 1
20129 Error_Pragma_Arg_Ident
20130 ("Structural variant shall be the only variant", Variant);
20133 -- Preanalyze_Assert_Expression, but without enforcing any of
20134 -- the two acceptable types.
20136 Preanalyze_Assert_Expression (Expression (Variant));
20138 -- Expression of a discrete type is allowed. Nothing to
20139 -- check for structural variants.
20141 if Chars (Variant) = Name_Structural
20142 or else Is_Discrete_Type (Etype (Expression (Variant)))
20146 -- Expression of a Big_Integer type (or its ghost variant) is
20147 -- only allowed in Decreases clause.
20150 Is_RTE (Base_Type (Etype (Expression (Variant))),
20153 Is_RTE (Base_Type (Etype (Expression (Variant))),
20156 if Chars (Variant) = Name_Increases then
20158 ("Loop_Variant with Big_Integer can only decrease",
20159 Expression (Variant));
20162 -- Expression of other types is not allowed
20166 ("expected a discrete or Big_Integer type",
20167 Expression (Variant));
20174 -----------------------
20175 -- Machine_Attribute --
20176 -----------------------
20178 -- pragma Machine_Attribute (
20179 -- [Entity =>] LOCAL_NAME,
20180 -- [Attribute_Name =>] static_string_EXPRESSION
20181 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
20183 when Pragma_Machine_Attribute => Machine_Attribute : declare
20185 Def_Id : Entity_Id;
20189 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
20191 if Arg_Count >= 3 then
20192 Check_Optional_Identifier (Arg3, Name_Info);
20194 while Present (Arg) loop
20195 Check_Arg_Is_OK_Static_Expression (Arg);
20199 Check_Arg_Count (2);
20202 Check_Optional_Identifier (Arg1, Name_Entity);
20203 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
20204 Check_Arg_Is_Local_Name (Arg1);
20205 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
20206 Def_Id := Entity (Get_Pragma_Arg (Arg1));
20208 -- Apply the pragma to the designated type, rather than to the
20209 -- access type, unless it's a strub annotation. We wish to enable
20210 -- objects of access type, as well as access types themselves, to
20211 -- be annotated, so that reading the access objects (as oposed to
20212 -- the designated data) automatically enables stack
20213 -- scrubbing. That said, as in the attribute handler that
20214 -- processes the pragma turned into a compiler attribute, a strub
20215 -- annotation that must be associated with a subprogram type (for
20216 -- holding an explicit strub mode), when applied to an
20217 -- access-to-subprogram, gets promoted to the subprogram type. We
20218 -- might be tempted to leave it alone here, since the C attribute
20219 -- handler will adjust it, but then GNAT would convert the
20220 -- annotated subprogram types to naked ones before using them,
20221 -- cancelling out their intended effects.
20223 if Is_Access_Type (Def_Id)
20224 and then (not Strub_Pragma_P (N)
20228 Ekind (Designated_Type
20229 (Def_Id)) = E_Subprogram_Type))
20231 Def_Id := Designated_Type (Def_Id);
20234 if Rep_Item_Too_Early (Def_Id, N) then
20238 Def_Id := Underlying_Type (Def_Id);
20240 -- The only processing required is to link this item on to the
20241 -- list of rep items for the given entity. This is accomplished
20242 -- by the call to Rep_Item_Too_Late (when no error is detected
20243 -- and False is returned).
20245 if Rep_Item_Too_Late (Def_Id, N) then
20248 Set_Has_Gigi_Rep_Item (Def_Id);
20250 end Machine_Attribute;
20257 -- (MAIN_OPTION [, MAIN_OPTION]);
20260 -- [STACK_SIZE =>] static_integer_EXPRESSION
20261 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
20262 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
20264 when Pragma_Main => Main : declare
20265 Args : Args_List (1 .. 3);
20266 Names : constant Name_List (1 .. 3) := (
20268 Name_Task_Stack_Size_Default,
20269 Name_Time_Slicing_Enabled);
20275 Gather_Associations (Names, Args);
20277 for J in 1 .. 2 loop
20278 if Present (Args (J)) then
20279 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
20283 if Present (Args (3)) then
20284 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
20288 while Present (Nod) loop
20289 if Nkind (Nod) = N_Pragma
20290 and then Pragma_Name (Nod) = Name_Main
20292 Error_Msg_Name_1 := Pname;
20293 Error_Msg_N ("duplicate pragma% not permitted", Nod);
20304 -- pragma Main_Storage
20305 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
20307 -- MAIN_STORAGE_OPTION ::=
20308 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
20309 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
20311 when Pragma_Main_Storage => Main_Storage : declare
20312 Args : Args_List (1 .. 2);
20313 Names : constant Name_List (1 .. 2) := (
20314 Name_Working_Storage,
20321 Gather_Associations (Names, Args);
20323 for J in 1 .. 2 loop
20324 if Present (Args (J)) then
20325 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
20329 Check_In_Main_Program;
20332 while Present (Nod) loop
20333 if Nkind (Nod) = N_Pragma
20334 and then Pragma_Name (Nod) = Name_Main_Storage
20336 Error_Msg_Name_1 := Pname;
20337 Error_Msg_N ("duplicate pragma% not permitted", Nod);
20344 ----------------------------
20345 -- Max_Entry_Queue_Length --
20346 ----------------------------
20348 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
20350 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
20351 -- Pragma_Max_Queue_Length.
20353 when Pragma_Max_Entry_Queue_Length
20354 | Pragma_Max_Entry_Queue_Depth
20355 | Pragma_Max_Queue_Length
20357 Max_Entry_Queue_Length : declare
20359 Entry_Decl : Node_Id;
20360 Entry_Id : Entity_Id;
20364 if Prag_Id = Pragma_Max_Entry_Queue_Depth
20365 or else Prag_Id = Pragma_Max_Queue_Length
20370 Check_Arg_Count (1);
20373 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
20375 -- Entry declaration
20377 if Nkind (Entry_Decl) = N_Entry_Declaration then
20379 -- Entry illegally within a task
20381 if Nkind (Parent (N)) = N_Task_Definition then
20382 Error_Pragma ("pragma % cannot apply to task entries");
20385 Entry_Id := Defining_Entity (Entry_Decl);
20387 -- Otherwise the pragma is associated with an illegal construct
20391 ("pragma % must apply to a protected entry declaration");
20394 -- Mark the pragma as Ghost if the related subprogram is also
20395 -- Ghost. This also ensures that any expansion performed further
20396 -- below will produce Ghost nodes.
20398 Mark_Ghost_Pragma (N, Entry_Id);
20400 -- Analyze the Integer expression
20402 Arg := Get_Pragma_Arg (Arg1);
20403 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
20405 Val := Expr_Value (Arg);
20409 ("argument for pragma% cannot be less than -1", Arg1);
20411 elsif not UI_Is_In_Int_Range (Val) then
20413 ("argument for pragma% out of range of Integer", Arg1);
20417 Record_Rep_Item (Entry_Id, N);
20418 end Max_Entry_Queue_Length;
20424 -- pragma Memory_Size (NUMERIC_LITERAL)
20426 when Pragma_Memory_Size =>
20429 -- Memory size is simply ignored
20431 Check_No_Identifiers;
20432 Check_Arg_Count (1);
20433 Check_Arg_Is_Integer_Literal (Arg1);
20441 -- The only correct use of this pragma is on its own in a file, in
20442 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
20443 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
20444 -- check for a file containing nothing but a No_Body pragma). If we
20445 -- attempt to process it during normal semantics processing, it means
20446 -- it was misplaced.
20448 when Pragma_No_Body =>
20452 -----------------------------
20453 -- No_Elaboration_Code_All --
20454 -----------------------------
20456 -- pragma No_Elaboration_Code_All;
20458 when Pragma_No_Elaboration_Code_All =>
20460 Check_Valid_Library_Unit_Pragma;
20462 -- If N was rewritten as a null statement there is nothing more
20465 if Nkind (N) = N_Null_Statement then
20469 -- Must appear for a spec or generic spec
20471 if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
20472 N_Generic_Package_Declaration |
20473 N_Generic_Subprogram_Declaration |
20474 N_Package_Declaration |
20475 N_Subprogram_Declaration
20479 ("pragma% can only occur for package "
20480 & "or subprogram spec"));
20483 -- Set flag in unit table
20485 Set_No_Elab_Code_All (Current_Sem_Unit);
20487 -- Set restriction No_Elaboration_Code if this is the main unit
20489 if Current_Sem_Unit = Main_Unit then
20490 Set_Restriction (No_Elaboration_Code, N);
20493 -- If we are in the main unit or in an extended main source unit,
20494 -- then we also add it to the configuration restrictions so that
20495 -- it will apply to all units in the extended main source.
20497 if Current_Sem_Unit = Main_Unit
20498 or else In_Extended_Main_Source_Unit (N)
20500 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
20503 -- If in main extended unit, activate transitive with test
20505 if In_Extended_Main_Source_Unit (N) then
20506 Opt.No_Elab_Code_All_Pragma := N;
20509 -----------------------------
20510 -- No_Component_Reordering --
20511 -----------------------------
20513 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
20515 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
20521 Check_At_Most_N_Arguments (1);
20523 if Arg_Count = 0 then
20524 Check_Valid_Configuration_Pragma;
20525 Opt.No_Component_Reordering := True;
20528 Check_Optional_Identifier (Arg2, Name_Entity);
20529 Check_Arg_Is_Local_Name (Arg1);
20530 E_Id := Get_Pragma_Arg (Arg1);
20532 if Etype (E_Id) = Any_Type then
20536 E := Entity (E_Id);
20538 if not Is_Record_Type (E) then
20539 Error_Pragma_Arg ("pragma% requires record type", Arg1);
20542 Set_No_Reordering (Base_Type (E));
20544 end No_Comp_Reordering;
20546 --------------------------
20547 -- No_Heap_Finalization --
20548 --------------------------
20550 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
20552 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
20553 Context : constant Node_Id := Parent (N);
20554 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
20560 Check_No_Identifiers;
20562 -- The pragma appears in a configuration file
20564 if No (Context) then
20565 Check_Arg_Count (0);
20566 Check_Valid_Configuration_Pragma;
20568 -- Detect a duplicate pragma
20570 if Present (No_Heap_Finalization_Pragma) then
20573 Prev => No_Heap_Finalization_Pragma);
20577 No_Heap_Finalization_Pragma := N;
20579 -- Otherwise the pragma should be associated with a library-level
20580 -- named access-to-object type.
20583 Check_Arg_Count (1);
20584 Check_Arg_Is_Local_Name (Arg1);
20586 Find_Type (Typ_Arg);
20587 Typ := Entity (Typ_Arg);
20589 -- The type being subjected to the pragma is erroneous
20591 if Typ = Any_Type then
20592 Error_Pragma ("cannot find type referenced by pragma %");
20594 -- The pragma is applied to an incomplete or generic formal
20595 -- type way too early.
20597 elsif Rep_Item_Too_Early (Typ, N) then
20601 Typ := Underlying_Type (Typ);
20604 -- The pragma must apply to an access-to-object type
20606 if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
20609 -- Give a detailed error message on all other access type kinds
20611 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
20613 ("pragma % cannot apply to access protected subprogram "
20616 elsif Ekind (Typ) = E_Access_Subprogram_Type then
20618 ("pragma % cannot apply to access subprogram type");
20620 elsif Is_Anonymous_Access_Type (Typ) then
20622 ("pragma % cannot apply to anonymous access type");
20624 -- Give a general error message in case the pragma applies to a
20625 -- non-access type.
20629 ("pragma % must apply to library level access type");
20632 -- At this point the argument denotes an access-to-object type.
20633 -- Ensure that the type is declared at the library level.
20635 if Is_Library_Level_Entity (Typ) then
20638 -- Quietly ignore an access-to-object type originally declared
20639 -- at the library level within a generic, but instantiated at
20640 -- a non-library level. As a result the access-to-object type
20641 -- "loses" its No_Heap_Finalization property.
20643 elsif In_Instance then
20648 ("pragma % must apply to library level access type");
20651 -- Detect a duplicate pragma
20653 if Present (No_Heap_Finalization_Pragma) then
20656 Prev => No_Heap_Finalization_Pragma);
20660 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
20662 if Present (Prev) then
20670 Record_Rep_Item (Typ, N);
20672 end No_Heap_Finalization;
20678 -- pragma No_Inline ( NAME {, NAME} );
20680 when Pragma_No_Inline =>
20682 Process_Inline (Suppressed);
20688 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
20690 when Pragma_No_Return => Prag_No_Return : declare
20692 function Check_No_Return
20694 N : Node_Id) return Boolean;
20695 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
20696 -- emit an error message and return False, otherwise return True.
20697 -- 6.5.1 Nonreturning procedures:
20698 -- 4/3 "Aspect No_Return shall not be specified for a null
20699 -- procedure nor an instance of a generic unit."
20701 ---------------------
20702 -- Check_No_Return --
20703 ---------------------
20705 function Check_No_Return
20707 N : Node_Id) return Boolean
20710 if Ekind (E) in E_Function | E_Generic_Function then
20711 Error_Msg_Ada_2022_Feature ("No_Return function", Sloc (N));
20712 return Ada_Version >= Ada_2022;
20714 elsif Ekind (E) = E_Procedure then
20716 -- If E is a generic instance, marking it with No_Return
20717 -- is forbidden, but having it inherit the No_Return of
20718 -- the generic is allowed. We check if E is inheriting its
20719 -- No_Return flag from the generic by checking if No_Return
20722 if Is_Generic_Instance (E) and then not No_Return (E) then
20724 ("generic instance & is marked as No_Return", N, E);
20726 ("\generic procedure & must be marked No_Return",
20728 Generic_Parent (Parent (E)));
20731 elsif Null_Present (Subprogram_Specification (E)) then
20733 ("null procedure & cannot be marked No_Return", N, E);
20739 end Check_No_Return;
20746 Ghost_Error_Posted : Boolean := False;
20747 -- Flag set when an error concerning the illegal mix of Ghost and
20748 -- non-Ghost subprograms is emitted.
20750 Ghost_Id : Entity_Id := Empty;
20751 -- The entity of the first Ghost procedure encountered while
20752 -- processing the arguments of the pragma.
20756 Check_At_Least_N_Arguments (1);
20758 -- Loop through arguments of pragma
20761 while Present (Arg) loop
20762 Check_Arg_Is_Local_Name (Arg);
20763 Id := Get_Pragma_Arg (Arg);
20766 if not Is_Entity_Name (Id) then
20767 Error_Pragma_Arg ("entity name required", Arg);
20770 if Etype (Id) = Any_Type then
20774 -- Loop to find matching procedures or functions (Ada 2022)
20780 and then Scope (E) = Current_Scope
20782 -- Ada 2022 (AI12-0269): A function can be No_Return
20784 if Ekind (E) in E_Generic_Procedure | E_Procedure
20785 | E_Generic_Function | E_Function
20787 -- Check that the pragma is not applied to a body.
20788 -- First check the specless body case, to give a
20789 -- different error message. These checks do not apply
20790 -- if Relaxed_RM_Semantics, to accommodate other Ada
20791 -- compilers. Disable these checks under -gnatd.J.
20793 if not Debug_Flag_Dot_JJ then
20794 if Nkind (Parent (Declaration_Node (E))) =
20796 and then not Relaxed_RM_Semantics
20799 ("pragma% requires separate spec and must come "
20803 -- Now the "specful" body case
20805 if Rep_Item_Too_Late (E, N) then
20810 if Check_No_Return (E, N) then
20814 -- A pragma that applies to a Ghost entity becomes Ghost
20815 -- for the purposes of legality checks and removal of
20816 -- ignored Ghost code.
20818 Mark_Ghost_Pragma (N, E);
20820 -- Capture the entity of the first Ghost procedure being
20821 -- processed for error detection purposes.
20823 if Is_Ghost_Entity (E) then
20824 if No (Ghost_Id) then
20828 -- Otherwise the subprogram is non-Ghost. It is illegal
20829 -- to mix references to Ghost and non-Ghost entities
20832 elsif Present (Ghost_Id)
20833 and then not Ghost_Error_Posted
20835 Ghost_Error_Posted := True;
20837 Error_Msg_Name_1 := Pname;
20839 ("pragma % cannot mention ghost and non-ghost "
20840 & "procedures", N);
20842 Error_Msg_Sloc := Sloc (Ghost_Id);
20843 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
20845 Error_Msg_Sloc := Sloc (E);
20846 Error_Msg_NE ("\& # declared as non-ghost", N, E);
20849 -- Set flag on any alias as well
20851 if Is_Overloadable (E)
20852 and then Present (Alias (E))
20853 and then Check_No_Return (Alias (E), N)
20855 Set_No_Return (Alias (E));
20861 exit when From_Aspect_Specification (N);
20865 -- If entity in not in current scope it may be the enclosing
20866 -- subprogram body to which the aspect applies.
20869 if Entity (Id) = Current_Scope
20870 and then From_Aspect_Specification (N)
20871 and then Check_No_Return (Entity (Id), N)
20873 Set_No_Return (Entity (Id));
20875 elsif Ada_Version >= Ada_2022 then
20877 ("no subprogram& found for pragma%", Arg);
20880 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
20886 end Prag_No_Return;
20892 -- pragma No_Run_Time;
20894 -- Note: this pragma is retained for backwards compatibility. See
20895 -- body of Rtsfind for full details on its handling.
20897 when Pragma_No_Run_Time =>
20899 Check_Valid_Configuration_Pragma;
20900 Check_Arg_Count (0);
20902 -- Remove backward compatibility if Build_Type is FSF or GPL and
20903 -- generate a warning.
20906 Ignore : constant Boolean := Build_Type in FSF .. GPL;
20909 Error_Pragma ("pragma% is ignored, has no effect??");
20911 No_Run_Time_Mode := True;
20912 Configurable_Run_Time_Mode := True;
20914 -- Set Duration to 32 bits if word size is 32
20916 if Ttypes.System_Word_Size = 32 then
20917 Duration_32_Bits_On_Target := True;
20920 -- Set appropriate restrictions
20922 Set_Restriction (No_Finalization, N);
20923 Set_Restriction (No_Exception_Handlers, N);
20924 Set_Restriction (Max_Tasks, N, 0);
20925 Set_Restriction (No_Tasking, N);
20929 -----------------------
20930 -- No_Tagged_Streams --
20931 -----------------------
20933 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20935 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
20941 Check_At_Most_N_Arguments (1);
20943 -- One argument case
20945 if Arg_Count = 1 then
20946 Check_Optional_Identifier (Arg1, Name_Entity);
20947 Check_Arg_Is_Local_Name (Arg1);
20948 E_Id := Get_Pragma_Arg (Arg1);
20950 if Etype (E_Id) = Any_Type then
20954 E := Entity (E_Id);
20956 Check_Duplicate_Pragma (E);
20958 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
20960 ("argument for pragma% must be root tagged type", Arg1);
20963 if Rep_Item_Too_Early (E, N)
20965 Rep_Item_Too_Late (E, N)
20969 Set_No_Tagged_Streams_Pragma (E, N);
20972 -- Zero argument case
20975 Check_Is_In_Decl_Part_Or_Package_Spec;
20976 No_Tagged_Streams := N;
20978 end No_Tagged_Strms;
20980 ------------------------
20981 -- No_Strict_Aliasing --
20982 ------------------------
20984 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20986 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20992 Check_At_Most_N_Arguments (1);
20994 if Arg_Count = 0 then
20995 Check_Valid_Configuration_Pragma;
20996 Opt.No_Strict_Aliasing := True;
20999 Check_Optional_Identifier (Arg2, Name_Entity);
21000 Check_Arg_Is_Local_Name (Arg1);
21001 E_Id := Get_Pragma_Arg (Arg1);
21003 if Etype (E_Id) = Any_Type then
21007 E := Entity (E_Id);
21009 if not Is_Access_Type (E) then
21010 Error_Pragma_Arg ("pragma% requires access type", Arg1);
21013 Set_No_Strict_Aliasing (Base_Type (E));
21015 end No_Strict_Aliasing;
21017 -----------------------
21018 -- Normalize_Scalars --
21019 -----------------------
21021 -- pragma Normalize_Scalars;
21023 when Pragma_Normalize_Scalars =>
21024 Check_Ada_83_Warning;
21025 Check_Arg_Count (0);
21026 Check_Valid_Configuration_Pragma;
21028 -- Normalize_Scalars creates false positives in CodePeer, and
21029 -- incorrect negative results in GNATprove mode, so ignore this
21030 -- pragma in these modes.
21032 if not (CodePeer_Mode or GNATprove_Mode) then
21033 Normalize_Scalars := True;
21034 Init_Or_Norm_Scalars := True;
21041 -- pragma Obsolescent;
21043 -- pragma Obsolescent (
21044 -- [Message =>] static_string_EXPRESSION
21045 -- [,[Version =>] Ada_05]);
21047 -- pragma Obsolescent (
21048 -- [Entity =>] NAME
21049 -- [,[Message =>] static_string_EXPRESSION
21050 -- [,[Version =>] Ada_05]]);
21052 when Pragma_Obsolescent => Obsolescent : declare
21056 procedure Set_Obsolescent (E : Entity_Id);
21057 -- Given an entity Ent, mark it as obsolescent if appropriate
21059 ---------------------
21060 -- Set_Obsolescent --
21061 ---------------------
21063 procedure Set_Obsolescent (E : Entity_Id) is
21072 -- A pragma that applies to a Ghost entity becomes Ghost for
21073 -- the purposes of legality checks and removal of ignored Ghost
21076 Mark_Ghost_Pragma (N, E);
21078 -- Entity name was given
21080 if Present (Ename) then
21082 -- If entity name matches, we are fine.
21084 if Chars (Ename) = Chars (Ent) then
21085 Set_Entity (Ename, Ent);
21086 Generate_Reference (Ent, Ename);
21088 -- If entity name does not match, only possibility is an
21089 -- enumeration literal from an enumeration type declaration.
21091 elsif Ekind (Ent) /= E_Enumeration_Type then
21093 ("pragma % entity name does not match declaration");
21096 Ent := First_Literal (E);
21100 ("pragma % entity name does not match any "
21101 & "enumeration literal");
21103 elsif Chars (Ent) = Chars (Ename) then
21104 Set_Entity (Ename, Ent);
21105 Generate_Reference (Ent, Ename);
21109 Next_Literal (Ent);
21115 -- Ent points to entity to be marked
21117 if Arg_Count >= 1 then
21119 -- Deal with static string argument
21121 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21122 S := Strval (Get_Pragma_Arg (Arg1));
21124 for J in 1 .. String_Length (S) loop
21125 if not In_Character_Range (Get_String_Char (S, J)) then
21127 ("pragma% argument does not allow wide characters",
21132 Obsolescent_Warnings.Append
21133 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
21135 -- Check for Ada_05 parameter
21137 if Arg_Count /= 1 then
21138 Check_Arg_Count (2);
21141 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
21144 Check_Arg_Is_Identifier (Argx);
21146 if Chars (Argx) /= Name_Ada_05 then
21147 Error_Msg_Name_2 := Name_Ada_05;
21149 ("only allowed argument for pragma% is %", Argx);
21152 if Ada_Version_Explicit < Ada_2005
21153 or else not Warn_On_Ada_2005_Compatibility
21161 -- Set flag if pragma active
21164 Set_Is_Obsolescent (Ent);
21168 end Set_Obsolescent;
21170 -- Start of processing for pragma Obsolescent
21175 Check_At_Most_N_Arguments (3);
21177 -- See if first argument specifies an entity name
21181 (Chars (Arg1) = Name_Entity
21183 Nkind (Get_Pragma_Arg (Arg1)) in
21184 N_Character_Literal | N_Identifier | N_Operator_Symbol)
21186 Ename := Get_Pragma_Arg (Arg1);
21188 -- Eliminate first argument, so we can share processing
21192 Arg_Count := Arg_Count - 1;
21194 -- No Entity name argument given
21200 if Arg_Count >= 1 then
21201 Check_Optional_Identifier (Arg1, Name_Message);
21203 if Arg_Count = 2 then
21204 Check_Optional_Identifier (Arg2, Name_Version);
21208 -- Get immediately preceding declaration
21211 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
21215 -- Cases where we do not follow anything other than another pragma
21219 -- Case 0: library level compilation unit declaration with
21220 -- the pragma preceding the declaration.
21222 if Nkind (Parent (N)) = N_Compilation_Unit then
21225 -- Case 1: library level compilation unit declaration with
21226 -- the pragma immediately following the declaration.
21228 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
21230 (Defining_Entity (Unit (Parent (Parent (N)))));
21233 -- Case 2: library unit placement for package
21237 Ent : constant Entity_Id := Find_Lib_Unit_Name;
21239 if Is_Package_Or_Generic_Package (Ent) then
21240 Set_Obsolescent (Ent);
21246 -- Cases where we must follow a declaration, including an
21247 -- abstract subprogram declaration, which is not in the
21248 -- other node subtypes.
21251 if Nkind (Decl) not in N_Declaration
21252 and then Nkind (Decl) not in N_Later_Decl_Item
21253 and then Nkind (Decl) not in N_Generic_Declaration
21254 and then Nkind (Decl) not in N_Renaming_Declaration
21255 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
21258 ("pragma% misplaced, "
21259 & "must immediately follow a declaration");
21262 Set_Obsolescent (Defining_Entity (Decl));
21272 -- pragma Optimize (Time | Space | Off);
21274 -- The actual check for optimize is done in Gigi. Note that this
21275 -- pragma does not actually change the optimization setting, it
21276 -- simply checks that it is consistent with the pragma.
21278 when Pragma_Optimize =>
21279 Check_No_Identifiers;
21280 Check_Arg_Count (1);
21281 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
21283 ------------------------
21284 -- Optimize_Alignment --
21285 ------------------------
21287 -- pragma Optimize_Alignment (Time | Space | Off);
21289 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
21291 Check_No_Identifiers;
21292 Check_Arg_Count (1);
21293 Check_Valid_Configuration_Pragma;
21296 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
21299 when Name_Off => Opt.Optimize_Alignment := 'O';
21300 when Name_Space => Opt.Optimize_Alignment := 'S';
21301 when Name_Time => Opt.Optimize_Alignment := 'T';
21304 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
21308 -- Set indication that mode is set locally. If we are in fact in a
21309 -- configuration pragma file, this setting is harmless since the
21310 -- switch will get reset anyway at the start of each unit.
21312 Optimize_Alignment_Local := True;
21313 end Optimize_Alignment;
21319 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
21321 when Pragma_Ordered => Ordered : declare
21322 Assoc : constant Node_Id := Arg1;
21328 Check_No_Identifiers;
21329 Check_Arg_Count (1);
21330 Check_Arg_Is_Local_Name (Arg1);
21332 Type_Id := Get_Pragma_Arg (Assoc);
21333 Find_Type (Type_Id);
21334 Typ := Entity (Type_Id);
21336 if Typ = Any_Type then
21339 Typ := Underlying_Type (Typ);
21342 if not Is_Enumeration_Type (Typ) then
21343 Error_Pragma ("pragma% must specify enumeration type");
21346 Check_First_Subtype (Arg1);
21347 Set_Has_Pragma_Ordered (Base_Type (Typ));
21350 -------------------
21351 -- Overflow_Mode --
21352 -------------------
21354 -- pragma Overflow_Mode
21355 -- ([General => ] MODE [, [Assertions => ] MODE]);
21357 -- MODE := STRICT | MINIMIZED | ELIMINATED
21359 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
21360 -- since System.Bignums makes this assumption. This is true of nearly
21361 -- all (all?) targets.
21363 when Pragma_Overflow_Mode => Overflow_Mode : declare
21364 function Get_Overflow_Mode
21366 Arg : Node_Id) return Overflow_Mode_Type;
21367 -- Function to process one pragma argument, Arg. If an identifier
21368 -- is present, it must be Name. Mode type is returned if a valid
21369 -- argument exists, otherwise an error is signalled.
21371 -----------------------
21372 -- Get_Overflow_Mode --
21373 -----------------------
21375 function Get_Overflow_Mode
21377 Arg : Node_Id) return Overflow_Mode_Type
21379 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
21382 Check_Optional_Identifier (Arg, Name);
21383 Check_Arg_Is_Identifier (Argx);
21385 if Chars (Argx) = Name_Strict then
21388 elsif Chars (Argx) = Name_Minimized then
21391 elsif Chars (Argx) = Name_Eliminated then
21392 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
21394 ("Eliminated requires Long_Long_Integer'Size = 64",
21401 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
21403 end Get_Overflow_Mode;
21405 -- Start of processing for Overflow_Mode
21409 Check_At_Least_N_Arguments (1);
21410 Check_At_Most_N_Arguments (2);
21412 -- Process first argument
21414 Scope_Suppress.Overflow_Mode_General :=
21415 Get_Overflow_Mode (Name_General, Arg1);
21417 -- Case of only one argument
21419 if Arg_Count = 1 then
21420 Scope_Suppress.Overflow_Mode_Assertions :=
21421 Scope_Suppress.Overflow_Mode_General;
21423 -- Case of two arguments present
21426 Scope_Suppress.Overflow_Mode_Assertions :=
21427 Get_Overflow_Mode (Name_Assertions, Arg2);
21431 --------------------------
21432 -- Overriding Renamings --
21433 --------------------------
21435 -- pragma Overriding_Renamings;
21437 when Pragma_Overriding_Renamings =>
21439 Check_Arg_Count (0);
21440 Check_Valid_Configuration_Pragma;
21441 Overriding_Renamings := True;
21447 -- pragma Pack (first_subtype_LOCAL_NAME);
21449 when Pragma_Pack => Pack : declare
21450 Assoc : constant Node_Id := Arg1;
21452 Ignore : Boolean := False;
21457 Check_No_Identifiers;
21458 Check_Arg_Count (1);
21459 Check_Arg_Is_Local_Name (Arg1);
21460 Type_Id := Get_Pragma_Arg (Assoc);
21462 if not Is_Entity_Name (Type_Id)
21463 or else not Is_Type (Entity (Type_Id))
21466 ("argument for pragma% must be type or subtype", Arg1);
21469 Find_Type (Type_Id);
21470 Typ := Entity (Type_Id);
21473 or else Rep_Item_Too_Early (Typ, N)
21477 Typ := Underlying_Type (Typ);
21480 -- A pragma that applies to a Ghost entity becomes Ghost for the
21481 -- purposes of legality checks and removal of ignored Ghost code.
21483 Mark_Ghost_Pragma (N, Typ);
21485 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
21486 Error_Pragma ("pragma% must specify array or record type");
21489 Check_First_Subtype (Arg1);
21490 Check_Duplicate_Pragma (Typ);
21494 if Is_Array_Type (Typ) then
21495 Ctyp := Component_Type (Typ);
21497 -- Ignore pack that does nothing
21499 if Known_Static_Esize (Ctyp)
21500 and then Known_Static_RM_Size (Ctyp)
21501 and then Esize (Ctyp) = RM_Size (Ctyp)
21502 and then Addressable (Esize (Ctyp))
21507 -- Process OK pragma Pack. Note that if there is a separate
21508 -- component clause present, the Pack will be cancelled. This
21509 -- processing is in Freeze.
21511 if not Rep_Item_Too_Late (Typ, N) then
21513 -- In CodePeer mode, we do not need complex front-end
21514 -- expansions related to pragma Pack, so disable handling
21517 if CodePeer_Mode then
21520 -- Normal case where we do the pack action
21524 Set_Is_Packed (Base_Type (Typ));
21525 Set_Has_Non_Standard_Rep (Base_Type (Typ));
21528 Set_Has_Pragma_Pack (Base_Type (Typ));
21532 -- For record types, the pack is always effective
21534 else pragma Assert (Is_Record_Type (Typ));
21535 if not Rep_Item_Too_Late (Typ, N) then
21536 Set_Is_Packed (Base_Type (Typ));
21537 Set_Has_Pragma_Pack (Base_Type (Typ));
21538 Set_Has_Non_Standard_Rep (Base_Type (Typ));
21549 -- There is nothing to do here, since we did all the processing for
21550 -- this pragma in Par.Prag (so that it works properly even in syntax
21553 when Pragma_Page =>
21560 -- pragma Part_Of (ABSTRACT_STATE);
21562 -- ABSTRACT_STATE ::= NAME
21564 when Pragma_Part_Of => Part_Of : declare
21565 procedure Propagate_Part_Of
21566 (Pack_Id : Entity_Id;
21567 State_Id : Entity_Id;
21568 Instance : Node_Id);
21569 -- Propagate the Part_Of indicator to all abstract states and
21570 -- objects declared in the visible state space of a package
21571 -- denoted by Pack_Id. State_Id is the encapsulating state.
21572 -- Instance is the package instantiation node.
21574 -----------------------
21575 -- Propagate_Part_Of --
21576 -----------------------
21578 procedure Propagate_Part_Of
21579 (Pack_Id : Entity_Id;
21580 State_Id : Entity_Id;
21581 Instance : Node_Id)
21583 Has_Item : Boolean := False;
21584 -- Flag set when the visible state space contains at least one
21585 -- abstract state or variable.
21587 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
21588 -- Propagate the Part_Of indicator to all abstract states and
21589 -- objects declared in the visible state space of a package
21590 -- denoted by Pack_Id.
21592 -----------------------
21593 -- Propagate_Part_Of --
21594 -----------------------
21596 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
21597 Constits : Elist_Id;
21598 Item_Id : Entity_Id;
21601 -- Traverse the entity chain of the package and set relevant
21602 -- attributes of abstract states and objects declared in the
21603 -- visible state space of the package.
21605 Item_Id := First_Entity (Pack_Id);
21606 while Present (Item_Id)
21607 and then not In_Private_Part (Item_Id)
21609 -- Do not consider internally generated items
21611 if not Comes_From_Source (Item_Id) then
21614 -- Do not consider generic formals or their corresponding
21615 -- actuals because they are not part of a visible state.
21616 -- Note that both entities are marked as hidden.
21618 elsif Is_Hidden (Item_Id) then
21621 -- The Part_Of indicator turns an abstract state or an
21622 -- object into a constituent of the encapsulating state.
21623 -- Note that constants are considered here even though
21624 -- they may not depend on variable input. This check is
21625 -- left to the SPARK prover.
21627 elsif Ekind (Item_Id) in
21628 E_Abstract_State | E_Constant | E_Variable
21631 Constits := Part_Of_Constituents (State_Id);
21633 if No (Constits) then
21634 Constits := New_Elmt_List;
21635 Set_Part_Of_Constituents (State_Id, Constits);
21638 Append_Elmt (Item_Id, Constits);
21639 Set_Encapsulating_State (Item_Id, State_Id);
21641 -- Recursively handle nested packages and instantiations
21643 elsif Ekind (Item_Id) = E_Package then
21644 Propagate_Part_Of (Item_Id);
21647 Next_Entity (Item_Id);
21649 end Propagate_Part_Of;
21651 -- Start of processing for Propagate_Part_Of
21654 Propagate_Part_Of (Pack_Id);
21656 -- Detect a package instantiation that is subject to a Part_Of
21657 -- indicator, but has no visible state.
21659 if not Has_Item then
21661 ("package instantiation & has Part_Of indicator but "
21662 & "lacks visible state", Instance, Pack_Id);
21664 end Propagate_Part_Of;
21668 Constits : Elist_Id;
21670 Encap_Id : Entity_Id;
21671 Item_Id : Entity_Id;
21675 -- Start of processing for Part_Of
21679 Check_No_Identifiers;
21680 Check_Arg_Count (1);
21682 Stmt := Find_Related_Context (N, Do_Checks => True);
21684 -- Object declaration
21686 if Nkind (Stmt) = N_Object_Declaration then
21689 -- Package instantiation
21691 elsif Nkind (Stmt) = N_Package_Instantiation then
21694 -- Single concurrent type declaration
21696 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
21699 -- Otherwise the pragma is associated with an illegal construct
21705 -- Extract the entity of the related object declaration or package
21706 -- instantiation. In the case of the instantiation, use the entity
21707 -- of the instance spec.
21709 if Nkind (Stmt) = N_Package_Instantiation then
21710 Stmt := Instance_Spec (Stmt);
21713 Item_Id := Defining_Entity (Stmt);
21715 -- A pragma that applies to a Ghost entity becomes Ghost for the
21716 -- purposes of legality checks and removal of ignored Ghost code.
21718 Mark_Ghost_Pragma (N, Item_Id);
21720 -- Chain the pragma on the contract for further processing by
21721 -- Analyze_Part_Of_In_Decl_Part or for completeness.
21723 Add_Contract_Item (N, Item_Id);
21725 -- A variable may act as constituent of a single concurrent type
21726 -- which in turn could be declared after the variable. Due to this
21727 -- discrepancy, the full analysis of indicator Part_Of is delayed
21728 -- until the end of the enclosing declarative region (see routine
21729 -- Analyze_Part_Of_In_Decl_Part).
21731 if Ekind (Item_Id) = E_Variable then
21734 -- Otherwise indicator Part_Of applies to a constant or a package
21738 Encap := Get_Pragma_Arg (Arg1);
21740 -- Detect any discrepancies between the placement of the
21741 -- constant or package instantiation with respect to state
21742 -- space and the encapsulating state.
21746 Item_Id => Item_Id,
21748 Encap_Id => Encap_Id,
21752 pragma Assert (Present (Encap_Id));
21754 if Ekind (Item_Id) = E_Constant then
21755 Constits := Part_Of_Constituents (Encap_Id);
21757 if No (Constits) then
21758 Constits := New_Elmt_List;
21759 Set_Part_Of_Constituents (Encap_Id, Constits);
21762 Append_Elmt (Item_Id, Constits);
21763 Set_Encapsulating_State (Item_Id, Encap_Id);
21765 -- Propagate the Part_Of indicator to the visible state
21766 -- space of the package instantiation.
21770 (Pack_Id => Item_Id,
21771 State_Id => Encap_Id,
21778 ----------------------------------
21779 -- Partition_Elaboration_Policy --
21780 ----------------------------------
21782 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
21784 when Pragma_Partition_Elaboration_Policy => PEP : declare
21785 subtype PEP_Range is Name_Id
21786 range First_Partition_Elaboration_Policy_Name
21787 .. Last_Partition_Elaboration_Policy_Name;
21788 PEP_Val : PEP_Range;
21793 Check_Arg_Count (1);
21794 Check_No_Identifiers;
21795 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
21796 Check_Valid_Configuration_Pragma;
21797 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
21800 when Name_Concurrent => PEP := 'C';
21801 when Name_Sequential => PEP := 'S';
21804 if Partition_Elaboration_Policy /= ' '
21805 and then Partition_Elaboration_Policy /= PEP
21807 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
21809 ("partition elaboration policy incompatible with policy#");
21811 -- Set new policy, but always preserve System_Location since we
21812 -- like the error message with the run time name.
21815 Partition_Elaboration_Policy := PEP;
21817 if Partition_Elaboration_Policy_Sloc /= System_Location then
21818 Partition_Elaboration_Policy_Sloc := Loc;
21821 if PEP_Val = Name_Sequential
21822 and then not Restriction_Active (No_Task_Hierarchy)
21824 -- RM H.6(6) guarantees that No_Task_Hierarchy will be
21825 -- set eventually, so take advantage of that knowledge now.
21826 -- But we have to do this in a tricky way. If we simply
21827 -- set the No_Task_Hierarchy restriction here, then the
21828 -- assumption that the restriction will be set eventually
21829 -- becomes a self-fulfilling prophecy; the binder can
21830 -- then mistakenly conclude that the H.6(6) rule is
21831 -- satisified in cases where the post-compilation check
21832 -- should fail. So we invent a new restriction,
21833 -- No_Task_Hierarchy_Implicit, which is treated specially
21834 -- in the function Restriction_Active.
21836 Set_Restriction (No_Task_Hierarchy_Implicit, N);
21837 pragma Assert (Restriction_Active (No_Task_Hierarchy));
21846 -- pragma Passive [(PASSIVE_FORM)];
21848 -- PASSIVE_FORM ::= Semaphore | No
21850 when Pragma_Passive =>
21853 if Nkind (Parent (N)) /= N_Task_Definition then
21854 Error_Pragma ("pragma% must be within task definition");
21857 if Arg_Count /= 0 then
21858 Check_Arg_Count (1);
21859 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
21862 ----------------------------------
21863 -- Preelaborable_Initialization --
21864 ----------------------------------
21866 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21868 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
21873 Check_Arg_Count (1);
21874 Check_No_Identifiers;
21875 Check_Arg_Is_Identifier (Arg1);
21876 Check_Arg_Is_Local_Name (Arg1);
21877 Check_First_Subtype (Arg1);
21878 Ent := Entity (Get_Pragma_Arg (Arg1));
21880 -- A pragma that applies to a Ghost entity becomes Ghost for the
21881 -- purposes of legality checks and removal of ignored Ghost code.
21883 Mark_Ghost_Pragma (N, Ent);
21885 -- The pragma may come from an aspect on a private declaration,
21886 -- even if the freeze point at which this is analyzed in the
21887 -- private part after the full view.
21889 if Has_Private_Declaration (Ent)
21890 and then From_Aspect_Specification (N)
21894 -- Check appropriate type argument
21896 elsif Is_Private_Type (Ent)
21897 or else Is_Protected_Type (Ent)
21898 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
21900 -- AI05-0028: The pragma applies to all composite types. Note
21901 -- that we apply this binding interpretation to earlier versions
21902 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21903 -- choice since there are other compilers that do the same.
21905 or else Is_Composite_Type (Ent)
21911 ("pragma % can only be applied to private, formal derived, "
21912 & "protected, or composite type", Arg1);
21915 -- Give an error if the pragma is applied to a protected type that
21916 -- does not qualify (due to having entries, or due to components
21917 -- that do not qualify).
21919 if Is_Protected_Type (Ent)
21920 and then not Has_Preelaborable_Initialization (Ent)
21923 ("protected type & does not have preelaborable "
21924 & "initialization", Ent);
21926 -- Otherwise mark the type as definitely having preelaborable
21930 Set_Known_To_Have_Preelab_Init (Ent);
21933 if Has_Pragma_Preelab_Init (Ent)
21934 and then Warn_On_Redundant_Constructs
21936 Error_Pragma ("?r?duplicate pragma%!");
21938 Set_Has_Pragma_Preelab_Init (Ent);
21942 --------------------
21943 -- Persistent_BSS --
21944 --------------------
21946 -- pragma Persistent_BSS [(object_NAME)];
21948 when Pragma_Persistent_BSS => Persistent_BSS : declare
21955 Check_At_Most_N_Arguments (1);
21957 -- Case of application to specific object (one argument)
21959 if Arg_Count = 1 then
21960 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21962 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
21964 Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
21965 E_Variable | E_Constant
21967 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
21970 Ent := Entity (Get_Pragma_Arg (Arg1));
21972 -- A pragma that applies to a Ghost entity becomes Ghost for
21973 -- the purposes of legality checks and removal of ignored Ghost
21976 Mark_Ghost_Pragma (N, Ent);
21978 -- Check for duplication before inserting in list of
21979 -- representation items.
21981 Check_Duplicate_Pragma (Ent);
21983 if Rep_Item_Too_Late (Ent, N) then
21987 Decl := Parent (Ent);
21989 if Present (Expression (Decl)) then
21990 -- Variables in Persistent_BSS cannot be initialized, so
21991 -- turn off any initialization that might be caused by
21992 -- pragmas Initialize_Scalars or Normalize_Scalars.
21994 if Kill_Range_Check (Expression (Decl)) then
21997 Name_Suppress_Initialization,
21998 Pragma_Argument_Associations => New_List (
21999 Make_Pragma_Argument_Association (Loc,
22000 Expression => New_Occurrence_Of (Ent, Loc))));
22001 Insert_Before (N, Prag);
22006 ("object for pragma% cannot have initialization", Arg1);
22010 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
22012 ("object type for pragma% is not potentially persistent",
22017 Make_Linker_Section_Pragma
22018 (Ent, Loc, ".persistent.bss");
22019 Insert_After (N, Prag);
22022 -- Case of use as configuration pragma with no arguments
22025 Check_Valid_Configuration_Pragma;
22026 Persistent_BSS_Mode := True;
22028 end Persistent_BSS;
22030 --------------------
22031 -- Rename_Pragma --
22032 --------------------
22034 -- pragma Rename_Pragma (
22035 -- [New_Name =>] IDENTIFIER,
22036 -- [Renamed =>] pragma_IDENTIFIER);
22038 when Pragma_Rename_Pragma => Rename_Pragma : declare
22039 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
22040 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
22044 Check_Valid_Configuration_Pragma;
22045 Check_Arg_Count (2);
22046 Check_Optional_Identifier (Arg1, Name_New_Name);
22047 Check_Optional_Identifier (Arg2, Name_Renamed);
22049 if Nkind (New_Name) /= N_Identifier then
22050 Error_Pragma_Arg ("identifier expected", Arg1);
22053 if Nkind (Old_Name) /= N_Identifier then
22054 Error_Pragma_Arg ("identifier expected", Arg2);
22057 -- The New_Name arg should not be an existing pragma (but we allow
22058 -- it; it's just a warning). The Old_Name arg must be an existing
22061 if Is_Pragma_Name (Chars (New_Name)) then
22062 Error_Pragma_Arg ("??pragma is already defined", Arg1);
22065 if not Is_Pragma_Name (Chars (Old_Name)) then
22066 Error_Pragma_Arg ("existing pragma name expected", Arg1);
22069 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
22072 -----------------------------------
22073 -- Post/Post_Class/Postcondition --
22074 -----------------------------------
22076 -- pragma Post (Boolean_EXPRESSION);
22077 -- pragma Post_Class (Boolean_EXPRESSION);
22078 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
22079 -- [,[Message =>] String_EXPRESSION]);
22081 -- Characteristics:
22083 -- * Analysis - The annotation undergoes initial checks to verify
22084 -- the legal placement and context. Secondary checks preanalyze the
22087 -- Analyze_Pre_Post_Condition_In_Decl_Part
22089 -- * Expansion - The annotation is expanded during the expansion of
22090 -- the related subprogram [body] contract as performed in:
22092 -- Expand_Subprogram_Contract
22094 -- * Template - The annotation utilizes the generic template of the
22095 -- related subprogram [body] when it is:
22097 -- aspect on subprogram declaration
22098 -- aspect on stand-alone subprogram body
22099 -- pragma on stand-alone subprogram body
22101 -- The annotation must prepare its own template when it is:
22103 -- pragma on subprogram declaration
22105 -- * Globals - Capture of global references must occur after full
22108 -- * Instance - The annotation is instantiated automatically when
22109 -- the related generic subprogram [body] is instantiated except for
22110 -- the "pragma on subprogram declaration" case. In that scenario
22111 -- the annotation must instantiate itself.
22114 | Pragma_Post_Class
22115 | Pragma_Postcondition
22117 Analyze_Pre_Post_Condition;
22119 --------------------------------
22120 -- Pre/Pre_Class/Precondition --
22121 --------------------------------
22123 -- pragma Pre (Boolean_EXPRESSION);
22124 -- pragma Pre_Class (Boolean_EXPRESSION);
22125 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
22126 -- [,[Message =>] String_EXPRESSION]);
22128 -- Characteristics:
22130 -- * Analysis - The annotation undergoes initial checks to verify
22131 -- the legal placement and context. Secondary checks preanalyze the
22134 -- Analyze_Pre_Post_Condition_In_Decl_Part
22136 -- * Expansion - The annotation is expanded during the expansion of
22137 -- the related subprogram [body] contract as performed in:
22139 -- Expand_Subprogram_Contract
22141 -- * Template - The annotation utilizes the generic template of the
22142 -- related subprogram [body] when it is:
22144 -- aspect on subprogram declaration
22145 -- aspect on stand-alone subprogram body
22146 -- pragma on stand-alone subprogram body
22148 -- The annotation must prepare its own template when it is:
22150 -- pragma on subprogram declaration
22152 -- * Globals - Capture of global references must occur after full
22155 -- * Instance - The annotation is instantiated automatically when
22156 -- the related generic subprogram [body] is instantiated except for
22157 -- the "pragma on subprogram declaration" case. In that scenario
22158 -- the annotation must instantiate itself.
22162 | Pragma_Precondition
22164 Analyze_Pre_Post_Condition;
22170 -- pragma Predicate
22171 -- ([Entity =>] type_LOCAL_NAME,
22172 -- [Check =>] boolean_EXPRESSION);
22174 when Pragma_Predicate => Predicate : declare
22181 Check_Arg_Count (2);
22182 Check_Optional_Identifier (Arg1, Name_Entity);
22183 Check_Optional_Identifier (Arg2, Name_Check);
22185 Check_Arg_Is_Local_Name (Arg1);
22187 Type_Id := Get_Pragma_Arg (Arg1);
22188 Find_Type (Type_Id);
22189 Typ := Entity (Type_Id);
22191 if Typ = Any_Type then
22195 -- A Ghost_Predicate aspect is always Ghost with a mode inherited
22196 -- from the context. A Predicate pragma that applies to a Ghost
22197 -- entity becomes Ghost for the purposes of legality checks and
22198 -- removal of ignored Ghost code.
22200 if From_Aspect_Specification (N)
22201 and then Get_Aspect_Id
22202 (Chars (Identifier (Corresponding_Aspect (N))))
22203 = Aspect_Ghost_Predicate
22206 (N, Name_To_Ghost_Mode (Policy_In_Effect (Name_Ghost)));
22208 Mark_Ghost_Pragma (N, Typ);
22211 -- The remaining processing is simply to link the pragma on to
22212 -- the rep item chain, for processing when the type is frozen.
22213 -- This is accomplished by a call to Rep_Item_Too_Late. We also
22214 -- mark the type as having predicates.
22216 -- If the current policy for predicate checking is Ignore mark the
22217 -- subtype accordingly. In the case of predicates we consider them
22218 -- enabled unless Ignore is specified (either directly or with a
22219 -- general Assertion_Policy pragma) to preserve existing warnings.
22221 Set_Has_Predicates (Typ);
22223 -- Indicate that the pragma must be processed at the point the
22224 -- type is frozen, as is done for the corresponding aspect.
22226 Set_Has_Delayed_Aspects (Typ);
22227 Set_Has_Delayed_Freeze (Typ);
22229 Set_Predicates_Ignored (Typ,
22230 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
22231 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
22234 -----------------------
22235 -- Predicate_Failure --
22236 -----------------------
22238 -- pragma Predicate_Failure
22239 -- ([Entity =>] type_LOCAL_NAME,
22240 -- [Message =>] string_EXPRESSION);
22242 when Pragma_Predicate_Failure => Predicate_Failure : declare
22249 Check_Arg_Count (2);
22250 Check_Optional_Identifier (Arg1, Name_Entity);
22251 Check_Optional_Identifier (Arg2, Name_Message);
22253 Check_Arg_Is_Local_Name (Arg1);
22255 Type_Id := Get_Pragma_Arg (Arg1);
22256 Find_Type (Type_Id);
22257 Typ := Entity (Type_Id);
22259 if Typ = Any_Type then
22263 -- A pragma that applies to a Ghost entity becomes Ghost for the
22264 -- purposes of legality checks and removal of ignored Ghost code.
22266 Mark_Ghost_Pragma (N, Typ);
22268 -- The remaining processing is simply to link the pragma on to
22269 -- the rep item chain, for processing when the type is frozen.
22270 -- This is accomplished by a call to Rep_Item_Too_Late.
22272 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
22273 end Predicate_Failure;
22279 -- pragma Preelaborate [(library_unit_NAME)];
22281 -- Set the flag Is_Preelaborated of program unit name entity
22283 when Pragma_Preelaborate => Preelaborate : declare
22284 Pa : constant Node_Id := Parent (N);
22285 Pk : constant Node_Kind := Nkind (Pa);
22289 Check_Ada_83_Warning;
22290 Check_Valid_Library_Unit_Pragma;
22292 -- If N was rewritten as a null statement there is nothing more
22295 if Nkind (N) = N_Null_Statement then
22299 Ent := Find_Lib_Unit_Name;
22301 -- A pragma that applies to a Ghost entity becomes Ghost for the
22302 -- purposes of legality checks and removal of ignored Ghost code.
22304 Mark_Ghost_Pragma (N, Ent);
22305 Check_Duplicate_Pragma (Ent);
22307 -- This filters out pragmas inside generic parents that show up
22308 -- inside instantiations. Pragmas that come from aspects in the
22309 -- unit are not ignored.
22311 if Present (Ent) then
22312 if Pk = N_Package_Specification
22313 and then Present (Generic_Parent (Pa))
22314 and then not From_Aspect_Specification (N)
22319 if not Debug_Flag_U then
22320 Set_Is_Preelaborated (Ent);
22322 if Legacy_Elaboration_Checks then
22323 Set_Suppress_Elaboration_Warnings (Ent);
22330 -------------------------------
22331 -- Prefix_Exception_Messages --
22332 -------------------------------
22334 -- pragma Prefix_Exception_Messages;
22336 when Pragma_Prefix_Exception_Messages =>
22338 Check_Valid_Configuration_Pragma;
22339 Check_Arg_Count (0);
22340 Prefix_Exception_Messages := True;
22346 -- pragma Priority (EXPRESSION);
22348 when Pragma_Priority => Priority : declare
22349 P : constant Node_Id := Parent (N);
22354 Check_No_Identifiers;
22355 Check_Arg_Count (1);
22359 if Nkind (P) = N_Subprogram_Body then
22360 Check_In_Main_Program;
22362 Ent := Defining_Unit_Name (Specification (P));
22364 if Nkind (Ent) = N_Defining_Program_Unit_Name then
22365 Ent := Defining_Identifier (Ent);
22368 Arg := Get_Pragma_Arg (Arg1);
22369 Analyze_And_Resolve (Arg, Standard_Integer);
22373 if not Is_OK_Static_Expression (Arg) then
22374 Flag_Non_Static_Expr
22375 ("main subprogram priority is not static!", Arg);
22378 -- If constraint error, then we already signalled an error
22380 elsif Raises_Constraint_Error (Arg) then
22383 -- Otherwise check in range except if Relaxed_RM_Semantics
22384 -- where we ignore the value if out of range.
22387 if not Relaxed_RM_Semantics
22388 and then not Is_In_Range (Arg, RTE (RE_Priority))
22391 ("main subprogram priority is out of range", Arg1);
22394 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
22398 -- Load an arbitrary entity from System.Tasking.Stages or
22399 -- System.Tasking.Restricted.Stages (depending on the
22400 -- supported profile) to make sure that one of these packages
22401 -- is implicitly with'ed, since we need to have the tasking
22402 -- run time active for the pragma Priority to have any effect.
22403 -- Previously we with'ed the package System.Tasking, but this
22404 -- package does not trigger the required initialization of the
22405 -- run-time library.
22407 if Restricted_Profile then
22408 Discard_Node (RTE (RE_Activate_Restricted_Tasks));
22410 Discard_Node (RTE (RE_Activate_Tasks));
22413 -- Task or Protected, must be of type Integer
22415 elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
22416 Arg := Get_Pragma_Arg (Arg1);
22417 Ent := Defining_Identifier (Parent (P));
22419 -- The expression must be analyzed in the special manner
22420 -- described in "Handling of Default and Per-Object
22421 -- Expressions" in sem.ads.
22423 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
22425 if not Is_OK_Static_Expression (Arg) then
22426 Check_Restriction (Static_Priorities, Arg);
22429 -- Anything else is incorrect
22435 -- Check duplicate pragma before we chain the pragma in the Rep
22436 -- Item chain of Ent.
22438 Check_Duplicate_Pragma (Ent);
22439 Record_Rep_Item (Ent, N);
22442 -----------------------------------
22443 -- Priority_Specific_Dispatching --
22444 -----------------------------------
22446 -- pragma Priority_Specific_Dispatching (
22447 -- policy_IDENTIFIER,
22448 -- first_priority_EXPRESSION,
22449 -- last_priority_EXPRESSION);
22451 when Pragma_Priority_Specific_Dispatching =>
22452 Priority_Specific_Dispatching : declare
22453 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
22454 -- This is the entity System.Any_Priority;
22457 Lower_Bound : Node_Id;
22458 Upper_Bound : Node_Id;
22464 Check_Arg_Count (3);
22465 Check_No_Identifiers;
22466 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
22467 Check_Valid_Configuration_Pragma;
22468 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22469 DP := Fold_Upper (Name_Buffer (1));
22471 Lower_Bound := Get_Pragma_Arg (Arg2);
22472 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
22473 Lower_Val := Expr_Value (Lower_Bound);
22475 Upper_Bound := Get_Pragma_Arg (Arg3);
22476 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
22477 Upper_Val := Expr_Value (Upper_Bound);
22479 -- It is not allowed to use Task_Dispatching_Policy and
22480 -- Priority_Specific_Dispatching in the same partition.
22482 if Task_Dispatching_Policy /= ' ' then
22483 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
22485 ("pragma% incompatible with Task_Dispatching_Policy#");
22487 -- Check lower bound in range
22489 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
22491 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
22494 ("first_priority is out of range", Arg2);
22496 -- Check upper bound in range
22498 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
22500 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
22503 ("last_priority is out of range", Arg3);
22505 -- Check that the priority range is valid
22507 elsif Lower_Val > Upper_Val then
22509 ("last_priority_expression must be greater than or equal to "
22510 & "first_priority_expression");
22512 -- Store the new policy, but always preserve System_Location since
22513 -- we like the error message with the run-time name.
22516 -- Check overlapping in the priority ranges specified in other
22517 -- Priority_Specific_Dispatching pragmas within the same
22518 -- partition. We can only check those we know about.
22521 Specific_Dispatching.First .. Specific_Dispatching.Last
22523 if Specific_Dispatching.Table (J).First_Priority in
22524 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
22525 or else Specific_Dispatching.Table (J).Last_Priority in
22526 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
22529 Specific_Dispatching.Table (J).Pragma_Loc;
22531 ("priority range overlaps with "
22532 & "Priority_Specific_Dispatching#");
22536 -- The use of Priority_Specific_Dispatching is incompatible
22537 -- with Task_Dispatching_Policy.
22539 if Task_Dispatching_Policy /= ' ' then
22540 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
22542 ("Priority_Specific_Dispatching incompatible "
22543 & "with Task_Dispatching_Policy#");
22546 -- The use of Priority_Specific_Dispatching forces ceiling
22549 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
22550 Error_Msg_Sloc := Locking_Policy_Sloc;
22552 ("Priority_Specific_Dispatching incompatible "
22553 & "with Locking_Policy#");
22555 -- Set the Ceiling_Locking policy, but preserve System_Location
22556 -- since we like the error message with the run time name.
22559 Locking_Policy := 'C';
22561 if Locking_Policy_Sloc /= System_Location then
22562 Locking_Policy_Sloc := Loc;
22566 -- Add entry in the table
22568 Specific_Dispatching.Append
22569 ((Dispatching_Policy => DP,
22570 First_Priority => UI_To_Int (Lower_Val),
22571 Last_Priority => UI_To_Int (Upper_Val),
22572 Pragma_Loc => Loc));
22574 end Priority_Specific_Dispatching;
22580 -- pragma Profile (profile_IDENTIFIER);
22582 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
22584 when Pragma_Profile =>
22586 Check_Arg_Count (1);
22587 Check_Valid_Configuration_Pragma;
22588 Check_No_Identifiers;
22591 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22594 if Nkind (Argx) /= N_Identifier then
22596 ("argument of pragma Profile must be an identifier", N);
22598 elsif Chars (Argx) = Name_Ravenscar then
22599 Set_Ravenscar_Profile (Ravenscar, N);
22601 elsif Chars (Argx) = Name_Jorvik then
22602 Set_Ravenscar_Profile (Jorvik, N);
22604 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
22605 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
22607 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
22608 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
22610 elsif Chars (Argx) = Name_Restricted then
22611 Set_Profile_Restrictions
22613 N, Warn => Treat_Restrictions_As_Warnings);
22615 elsif Chars (Argx) = Name_Rational then
22616 Set_Rational_Profile;
22618 elsif Chars (Argx) = Name_No_Implementation_Extensions then
22619 Set_Profile_Restrictions
22620 (No_Implementation_Extensions,
22621 N, Warn => Treat_Restrictions_As_Warnings);
22624 Error_Pragma_Arg ("& is not a valid profile", Argx);
22628 ----------------------
22629 -- Profile_Warnings --
22630 ----------------------
22632 -- pragma Profile_Warnings (profile_IDENTIFIER);
22634 -- profile_IDENTIFIER => Restricted | Ravenscar
22636 when Pragma_Profile_Warnings =>
22638 Check_Arg_Count (1);
22639 Check_Valid_Configuration_Pragma;
22640 Check_No_Identifiers;
22643 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22646 if Chars (Argx) = Name_Ravenscar then
22647 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
22649 elsif Chars (Argx) = Name_Restricted then
22650 Set_Profile_Restrictions (Restricted, N, Warn => True);
22652 elsif Chars (Argx) = Name_No_Implementation_Extensions then
22653 Set_Profile_Restrictions
22654 (No_Implementation_Extensions, N, Warn => True);
22657 Error_Pragma_Arg ("& is not a valid profile", Argx);
22661 --------------------------
22662 -- Propagate_Exceptions --
22663 --------------------------
22665 -- pragma Propagate_Exceptions;
22667 -- Note: this pragma is obsolete and has no effect
22669 when Pragma_Propagate_Exceptions =>
22671 Check_Arg_Count (0);
22673 if Warn_On_Obsolescent_Feature then
22675 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
22676 "and has no effect?j?", N);
22679 -----------------------------
22680 -- Provide_Shift_Operators --
22681 -----------------------------
22683 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
22685 when Pragma_Provide_Shift_Operators =>
22686 Provide_Shift_Operators : declare
22689 procedure Declare_Shift_Operator (Nam : Name_Id);
22690 -- Insert declaration and pragma Instrinsic for named shift op
22692 ----------------------------
22693 -- Declare_Shift_Operator --
22694 ----------------------------
22696 procedure Declare_Shift_Operator (Nam : Name_Id) is
22702 Make_Subprogram_Declaration (Loc,
22703 Make_Function_Specification (Loc,
22704 Defining_Unit_Name =>
22705 Make_Defining_Identifier (Loc, Chars => Nam),
22707 Result_Definition =>
22708 Make_Identifier (Loc, Chars => Chars (Ent)),
22710 Parameter_Specifications => New_List (
22711 Make_Parameter_Specification (Loc,
22712 Defining_Identifier =>
22713 Make_Defining_Identifier (Loc, Name_Value),
22715 Make_Identifier (Loc, Chars => Chars (Ent))),
22717 Make_Parameter_Specification (Loc,
22718 Defining_Identifier =>
22719 Make_Defining_Identifier (Loc, Name_Amount),
22721 New_Occurrence_Of (Standard_Natural, Loc)))));
22725 Chars => Name_Import,
22726 Pragma_Argument_Associations => New_List (
22727 Make_Pragma_Argument_Association (Loc,
22728 Expression => Make_Identifier (Loc, Name_Intrinsic)),
22729 Make_Pragma_Argument_Association (Loc,
22730 Expression => Make_Identifier (Loc, Nam))));
22732 Insert_After (N, Import);
22733 Insert_After (N, Func);
22734 end Declare_Shift_Operator;
22736 -- Start of processing for Provide_Shift_Operators
22740 Check_Arg_Count (1);
22741 Check_Arg_Is_Local_Name (Arg1);
22743 Arg1 := Get_Pragma_Arg (Arg1);
22745 -- We must have an entity name
22747 if not Is_Entity_Name (Arg1) then
22749 ("pragma % must apply to integer first subtype", Arg1);
22752 -- If no Entity, means there was a prior error so ignore
22754 if Present (Entity (Arg1)) then
22755 Ent := Entity (Arg1);
22757 -- Apply error checks
22759 if not Is_First_Subtype (Ent) then
22761 ("cannot apply pragma %",
22762 "\& is not a first subtype",
22765 elsif not Is_Integer_Type (Ent) then
22767 ("cannot apply pragma %",
22768 "\& is not an integer type",
22771 elsif Has_Shift_Operator (Ent) then
22773 ("cannot apply pragma %",
22774 "\& already has declared shift operators",
22777 elsif Is_Frozen (Ent) then
22779 ("pragma % appears too late",
22780 "\& is already frozen",
22784 -- Now declare the operators. We do this during analysis rather
22785 -- than expansion, since we want the operators available if we
22786 -- are operating in -gnatc mode.
22788 Declare_Shift_Operator (Name_Rotate_Left);
22789 Declare_Shift_Operator (Name_Rotate_Right);
22790 Declare_Shift_Operator (Name_Shift_Left);
22791 Declare_Shift_Operator (Name_Shift_Right);
22792 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
22794 end Provide_Shift_Operators;
22800 -- pragma Psect_Object (
22801 -- [Internal =>] LOCAL_NAME,
22802 -- [, [External =>] EXTERNAL_SYMBOL]
22803 -- [, [Size =>] EXTERNAL_SYMBOL]);
22805 when Pragma_Common_Object
22806 | Pragma_Psect_Object
22808 Psect_Object : declare
22809 Args : Args_List (1 .. 3);
22810 Names : constant Name_List (1 .. 3) := (
22815 Internal : Node_Id renames Args (1);
22816 External : Node_Id renames Args (2);
22817 Size : Node_Id renames Args (3);
22819 Def_Id : Entity_Id;
22821 procedure Check_Arg (Arg : Node_Id);
22822 -- Checks that argument is either a string literal or an
22823 -- identifier, and posts error message if not.
22829 procedure Check_Arg (Arg : Node_Id) is
22831 if Nkind (Original_Node (Arg)) not in
22832 N_String_Literal | N_Identifier
22835 ("inappropriate argument for pragma %", Arg);
22839 -- Start of processing for Common_Object/Psect_Object
22843 Gather_Associations (Names, Args);
22844 Process_Extended_Import_Export_Internal_Arg (Internal);
22846 Def_Id := Entity (Internal);
22848 if Ekind (Def_Id) not in E_Constant | E_Variable then
22850 ("pragma% must designate an object", Internal);
22853 Check_Arg (Internal);
22855 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
22857 ("cannot use pragma% for imported/exported object",
22861 if Is_Concurrent_Type (Etype (Internal)) then
22863 ("cannot specify pragma % for task/protected object",
22867 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
22869 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
22871 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
22874 if Ekind (Def_Id) = E_Constant then
22876 ("cannot specify pragma % for a constant", Internal);
22879 if Is_Record_Type (Etype (Internal)) then
22885 Ent := First_Entity (Etype (Internal));
22886 while Present (Ent) loop
22887 Decl := Declaration_Node (Ent);
22889 if Ekind (Ent) = E_Component
22890 and then Nkind (Decl) = N_Component_Declaration
22891 and then Present (Expression (Decl))
22892 and then Warn_On_Export_Import
22895 ("?x?object for pragma % has defaults", Internal);
22905 if Present (Size) then
22909 if Present (External) then
22910 Check_Arg_Is_External_Name (External);
22913 -- If all error tests pass, link pragma on to the rep item chain
22915 Record_Rep_Item (Def_Id, N);
22922 -- pragma Pure [(library_unit_NAME)];
22924 when Pragma_Pure => Pure : declare
22928 Check_Ada_83_Warning;
22930 -- If the pragma comes from a subprogram instantiation, nothing to
22931 -- check, this can happen at any level of nesting.
22933 if Is_Wrapper_Package (Current_Scope) then
22937 Check_Valid_Library_Unit_Pragma;
22939 -- If N was rewritten as a null statement there is nothing more
22942 if Nkind (N) = N_Null_Statement then
22946 Ent := Find_Lib_Unit_Name;
22948 -- A pragma that applies to a Ghost entity becomes Ghost for the
22949 -- purposes of legality checks and removal of ignored Ghost code.
22951 Mark_Ghost_Pragma (N, Ent);
22953 if not Debug_Flag_U then
22955 Set_Has_Pragma_Pure (Ent);
22957 if Legacy_Elaboration_Checks then
22958 Set_Suppress_Elaboration_Warnings (Ent);
22963 -------------------
22964 -- Pure_Function --
22965 -------------------
22967 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22969 when Pragma_Pure_Function => Pure_Function : declare
22970 Def_Id : Entity_Id;
22973 Effective : Boolean := False;
22974 Orig_Def : Entity_Id;
22975 Same_Decl : Boolean := False;
22979 Check_Arg_Count (1);
22980 Check_Optional_Identifier (Arg1, Name_Entity);
22981 Check_Arg_Is_Local_Name (Arg1);
22982 E_Id := Get_Pragma_Arg (Arg1);
22984 if Etype (E_Id) = Any_Type then
22988 -- Loop through homonyms (overloadings) of referenced entity
22990 E := Entity (E_Id);
22992 Analyze_If_Present (Pragma_Side_Effects);
22994 -- A function with side effects shall not have a Pure_Function
22995 -- aspect or pragma (SPARK RM 6.1.11(5)).
22997 if Is_Function_With_Side_Effects (E) then
22999 ("pragma % incompatible with ""Side_Effects""");
23002 -- A pragma that applies to a Ghost entity becomes Ghost for the
23003 -- purposes of legality checks and removal of ignored Ghost code.
23005 Mark_Ghost_Pragma (N, E);
23007 if Present (E) then
23009 Def_Id := Get_Base_Subprogram (E);
23011 if Ekind (Def_Id) not in
23012 E_Function | E_Generic_Function | E_Operator
23015 ("pragma% requires a function name", Arg1);
23018 -- When we have a generic function we must jump up a level
23019 -- to the declaration of the wrapper package itself.
23021 Orig_Def := Def_Id;
23023 if Is_Generic_Instance (Def_Id) then
23024 while Nkind (Orig_Def) /= N_Package_Declaration loop
23025 Orig_Def := Parent (Orig_Def);
23029 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
23031 Set_Is_Pure (Def_Id);
23033 if not Has_Pragma_Pure_Function (Def_Id) then
23034 Set_Has_Pragma_Pure_Function (Def_Id);
23039 exit when From_Aspect_Specification (N);
23041 exit when No (E) or else Scope (E) /= Current_Scope;
23045 and then Warn_On_Redundant_Constructs
23048 ("pragma Pure_Function on& is redundant?r?",
23051 elsif not Same_Decl then
23053 ("pragma% argument must be in same declarative part",
23059 --------------------
23060 -- Queuing_Policy --
23061 --------------------
23063 -- pragma Queuing_Policy (policy_IDENTIFIER);
23065 when Pragma_Queuing_Policy => declare
23069 Check_Ada_83_Warning;
23070 Check_Arg_Count (1);
23071 Check_No_Identifiers;
23072 Check_Arg_Is_Queuing_Policy (Arg1);
23073 Check_Valid_Configuration_Pragma;
23074 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
23075 QP := Fold_Upper (Name_Buffer (1));
23077 if Queuing_Policy /= ' '
23078 and then Queuing_Policy /= QP
23080 Error_Msg_Sloc := Queuing_Policy_Sloc;
23081 Error_Pragma ("queuing policy incompatible with policy#");
23083 -- Set new policy, but always preserve System_Location since we
23084 -- like the error message with the run time name.
23087 Queuing_Policy := QP;
23089 if Queuing_Policy_Sloc /= System_Location then
23090 Queuing_Policy_Sloc := Loc;
23099 -- pragma Rational, for compatibility with foreign compiler
23101 when Pragma_Rational =>
23102 Set_Rational_Profile;
23104 ---------------------
23105 -- Refined_Depends --
23106 ---------------------
23108 -- pragma Refined_Depends (DEPENDENCY_RELATION);
23110 -- DEPENDENCY_RELATION ::=
23112 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
23114 -- DEPENDENCY_CLAUSE ::=
23115 -- OUTPUT_LIST =>[+] INPUT_LIST
23116 -- | NULL_DEPENDENCY_CLAUSE
23118 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
23120 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
23122 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
23124 -- OUTPUT ::= NAME | FUNCTION_RESULT
23127 -- where FUNCTION_RESULT is a function Result attribute_reference
23129 -- Characteristics:
23131 -- * Analysis - The annotation undergoes initial checks to verify
23132 -- the legal placement and context. Secondary checks fully analyze
23133 -- the dependency clauses/global list in:
23135 -- Analyze_Refined_Depends_In_Decl_Part
23137 -- * Expansion - None.
23139 -- * Template - The annotation utilizes the generic template of the
23140 -- related subprogram body.
23142 -- * Globals - Capture of global references must occur after full
23145 -- * Instance - The annotation is instantiated automatically when
23146 -- the related generic subprogram body is instantiated.
23148 when Pragma_Refined_Depends => Refined_Depends : declare
23149 Body_Id : Entity_Id;
23151 Spec_Id : Entity_Id;
23154 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
23158 -- Chain the pragma on the contract for further processing by
23159 -- Analyze_Refined_Depends_In_Decl_Part.
23161 Add_Contract_Item (N, Body_Id);
23163 -- The legality checks of pragmas Refined_Depends and
23164 -- Refined_Global are affected by the SPARK mode in effect and
23165 -- the volatility of the context. In addition these two pragmas
23166 -- are subject to an inherent order:
23168 -- 1) Refined_Global
23169 -- 2) Refined_Depends
23171 -- Analyze all these pragmas in the order outlined above
23173 Analyze_If_Present (Pragma_SPARK_Mode);
23174 Analyze_If_Present (Pragma_Volatile_Function);
23175 Analyze_If_Present (Pragma_Side_Effects);
23176 Analyze_If_Present (Pragma_Refined_Global);
23177 Analyze_Refined_Depends_In_Decl_Part (N);
23179 end Refined_Depends;
23181 --------------------
23182 -- Refined_Global --
23183 --------------------
23185 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
23187 -- GLOBAL_SPECIFICATION ::=
23190 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
23192 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
23194 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
23195 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
23196 -- GLOBAL_ITEM ::= NAME
23198 -- Characteristics:
23200 -- * Analysis - The annotation undergoes initial checks to verify
23201 -- the legal placement and context. Secondary checks fully analyze
23202 -- the dependency clauses/global list in:
23204 -- Analyze_Refined_Global_In_Decl_Part
23206 -- * Expansion - None.
23208 -- * Template - The annotation utilizes the generic template of the
23209 -- related subprogram body.
23211 -- * Globals - Capture of global references must occur after full
23214 -- * Instance - The annotation is instantiated automatically when
23215 -- the related generic subprogram body is instantiated.
23217 when Pragma_Refined_Global => Refined_Global : declare
23218 Body_Id : Entity_Id;
23220 Spec_Id : Entity_Id;
23223 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
23227 -- Chain the pragma on the contract for further processing by
23228 -- Analyze_Refined_Global_In_Decl_Part.
23230 Add_Contract_Item (N, Body_Id);
23232 -- The legality checks of pragmas Refined_Depends and
23233 -- Refined_Global are affected by the SPARK mode in effect and
23234 -- the volatility of the context. In addition these two pragmas
23235 -- are subject to an inherent order:
23237 -- 1) Refined_Global
23238 -- 2) Refined_Depends
23240 -- Analyze all these pragmas in the order outlined above
23242 Analyze_If_Present (Pragma_SPARK_Mode);
23243 Analyze_If_Present (Pragma_Volatile_Function);
23244 Analyze_If_Present (Pragma_Side_Effects);
23245 Analyze_Refined_Global_In_Decl_Part (N);
23246 Analyze_If_Present (Pragma_Refined_Depends);
23248 end Refined_Global;
23254 -- pragma Refined_Post (boolean_EXPRESSION);
23256 -- Characteristics:
23258 -- * Analysis - The annotation is fully analyzed immediately upon
23259 -- elaboration as it cannot forward reference entities.
23261 -- * Expansion - The annotation is expanded during the expansion of
23262 -- the related subprogram body contract as performed in:
23264 -- Expand_Subprogram_Contract
23266 -- * Template - The annotation utilizes the generic template of the
23267 -- related subprogram body.
23269 -- * Globals - Capture of global references must occur after full
23272 -- * Instance - The annotation is instantiated automatically when
23273 -- the related generic subprogram body is instantiated.
23275 when Pragma_Refined_Post => Refined_Post : declare
23276 Body_Id : Entity_Id;
23278 Spec_Id : Entity_Id;
23281 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
23283 -- Fully analyze the pragma when it appears inside a subprogram
23284 -- body because it cannot benefit from forward references.
23288 -- Chain the pragma on the contract for completeness
23290 Add_Contract_Item (N, Body_Id);
23292 -- The legality checks of pragma Refined_Post are affected by
23293 -- the SPARK mode in effect and the volatility of the context.
23294 -- Analyze all pragmas in a specific order.
23296 Analyze_If_Present (Pragma_SPARK_Mode);
23297 Analyze_If_Present (Pragma_Volatile_Function);
23298 Analyze_Pre_Post_Condition_In_Decl_Part (N);
23300 -- Currently it is not possible to inline pre/postconditions on
23301 -- a subprogram subject to pragma Inline_Always.
23303 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23307 -------------------
23308 -- Refined_State --
23309 -------------------
23311 -- pragma Refined_State (REFINEMENT_LIST);
23313 -- REFINEMENT_LIST ::=
23314 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
23316 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
23318 -- CONSTITUENT_LIST ::=
23321 -- | (CONSTITUENT {, CONSTITUENT})
23323 -- CONSTITUENT ::= object_NAME | state_NAME
23325 -- Characteristics:
23327 -- * Analysis - The annotation undergoes initial checks to verify
23328 -- the legal placement and context. Secondary checks preanalyze the
23329 -- refinement clauses in:
23331 -- Analyze_Refined_State_In_Decl_Part
23333 -- * Expansion - None.
23335 -- * Template - The annotation utilizes the template of the related
23338 -- * Globals - Capture of global references must occur after full
23341 -- * Instance - The annotation is instantiated automatically when
23342 -- the related generic package body is instantiated.
23344 when Pragma_Refined_State => Refined_State : declare
23345 Pack_Decl : Node_Id;
23346 Spec_Id : Entity_Id;
23350 Check_No_Identifiers;
23351 Check_Arg_Count (1);
23353 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
23355 if Nkind (Pack_Decl) /= N_Package_Body then
23359 Spec_Id := Corresponding_Spec (Pack_Decl);
23361 -- A pragma that applies to a Ghost entity becomes Ghost for the
23362 -- purposes of legality checks and removal of ignored Ghost code.
23364 Mark_Ghost_Pragma (N, Spec_Id);
23366 -- Chain the pragma on the contract for further processing by
23367 -- Analyze_Refined_State_In_Decl_Part.
23369 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
23371 -- The legality checks of pragma Refined_State are affected by the
23372 -- SPARK mode in effect. Analyze all pragmas in a specific order.
23374 Analyze_If_Present (Pragma_SPARK_Mode);
23376 -- State refinement is allowed only when the corresponding package
23377 -- declaration has non-null pragma Abstract_State (SPARK RM
23380 if No (Abstract_States (Spec_Id))
23381 or else Has_Null_Abstract_State (Spec_Id)
23384 ("useless refinement, package & does not define abstract "
23385 & "states", N, Spec_Id);
23390 -----------------------
23391 -- Relative_Deadline --
23392 -----------------------
23394 -- pragma Relative_Deadline (time_span_EXPRESSION);
23396 when Pragma_Relative_Deadline => Relative_Deadline : declare
23397 P : constant Node_Id := Parent (N);
23402 Check_No_Identifiers;
23403 Check_Arg_Count (1);
23405 Arg := Get_Pragma_Arg (Arg1);
23407 -- The expression must be analyzed in the special manner described
23408 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
23410 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
23414 if Nkind (P) = N_Subprogram_Body then
23415 Check_In_Main_Program;
23417 -- Only Task and subprogram cases allowed
23419 elsif Nkind (P) /= N_Task_Definition then
23423 -- Check duplicate pragma before we set the corresponding flag
23425 if Has_Relative_Deadline_Pragma (P) then
23426 Error_Pragma ("duplicate pragma% not allowed");
23429 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
23430 -- Relative_Deadline pragma node cannot be inserted in the Rep
23431 -- Item chain of Ent since it is rewritten by the expander as a
23432 -- procedure call statement that will break the chain.
23434 Set_Has_Relative_Deadline_Pragma (P);
23435 end Relative_Deadline;
23437 ------------------------
23438 -- Remote_Access_Type --
23439 ------------------------
23441 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
23443 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
23448 Check_Arg_Count (1);
23449 Check_Optional_Identifier (Arg1, Name_Entity);
23450 Check_Arg_Is_Local_Name (Arg1);
23452 E := Entity (Get_Pragma_Arg (Arg1));
23454 -- A pragma that applies to a Ghost entity becomes Ghost for the
23455 -- purposes of legality checks and removal of ignored Ghost code.
23457 Mark_Ghost_Pragma (N, E);
23459 if Nkind (Parent (E)) = N_Formal_Type_Declaration
23460 and then Ekind (E) = E_General_Access_Type
23461 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
23462 and then Scope (Root_Type (Directly_Designated_Type (E)))
23464 and then Is_Valid_Remote_Object_Type
23465 (Root_Type (Directly_Designated_Type (E)))
23467 Set_Is_Remote_Types (E);
23471 ("pragma% applies only to formal access-to-class-wide types",
23474 end Remote_Access_Type;
23476 ---------------------------
23477 -- Remote_Call_Interface --
23478 ---------------------------
23480 -- pragma Remote_Call_Interface [(library_unit_NAME)];
23482 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
23483 Cunit_Node : Node_Id;
23484 Cunit_Ent : Entity_Id;
23488 Check_Ada_83_Warning;
23489 Check_Valid_Library_Unit_Pragma;
23491 -- If N was rewritten as a null statement there is nothing more
23494 if Nkind (N) = N_Null_Statement then
23498 Cunit_Node := Cunit (Current_Sem_Unit);
23499 K := Nkind (Unit (Cunit_Node));
23500 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
23502 -- A pragma that applies to a Ghost entity becomes Ghost for the
23503 -- purposes of legality checks and removal of ignored Ghost code.
23505 Mark_Ghost_Pragma (N, Cunit_Ent);
23507 if K = N_Package_Declaration
23508 or else K = N_Generic_Package_Declaration
23509 or else K = N_Subprogram_Declaration
23510 or else K = N_Generic_Subprogram_Declaration
23511 or else (K = N_Subprogram_Body
23512 and then Acts_As_Spec (Unit (Cunit_Node)))
23517 "pragma% must apply to package or subprogram declaration");
23520 Set_Is_Remote_Call_Interface (Cunit_Ent);
23521 end Remote_Call_Interface;
23527 -- pragma Remote_Types [(library_unit_NAME)];
23529 when Pragma_Remote_Types => Remote_Types : declare
23530 Cunit_Node : Node_Id;
23531 Cunit_Ent : Entity_Id;
23534 Check_Ada_83_Warning;
23535 Check_Valid_Library_Unit_Pragma;
23537 -- If N was rewritten as a null statement there is nothing more
23540 if Nkind (N) = N_Null_Statement then
23544 Cunit_Node := Cunit (Current_Sem_Unit);
23545 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
23547 -- A pragma that applies to a Ghost entity becomes Ghost for the
23548 -- purposes of legality checks and removal of ignored Ghost code.
23550 Mark_Ghost_Pragma (N, Cunit_Ent);
23552 if Nkind (Unit (Cunit_Node)) not in
23553 N_Package_Declaration | N_Generic_Package_Declaration
23556 ("pragma% can only apply to a package declaration");
23559 Set_Is_Remote_Types (Cunit_Ent);
23566 -- pragma Ravenscar;
23568 when Pragma_Ravenscar =>
23570 Check_Arg_Count (0);
23571 Check_Valid_Configuration_Pragma;
23572 Set_Ravenscar_Profile (Ravenscar, N);
23574 if Warn_On_Obsolescent_Feature then
23576 ("pragma Ravenscar is an obsolescent feature?j?", N);
23578 ("|use pragma Profile (Ravenscar) instead?j?", N);
23581 -------------------------
23582 -- Restricted_Run_Time --
23583 -------------------------
23585 -- pragma Restricted_Run_Time;
23587 when Pragma_Restricted_Run_Time =>
23589 Check_Arg_Count (0);
23590 Check_Valid_Configuration_Pragma;
23591 Set_Profile_Restrictions
23592 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
23594 if Warn_On_Obsolescent_Feature then
23596 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
23599 ("|use pragma Profile (Restricted) instead?j?", N);
23606 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
23609 -- restriction_IDENTIFIER
23610 -- | restriction_parameter_IDENTIFIER => EXPRESSION
23612 when Pragma_Restrictions =>
23613 Process_Restrictions_Or_Restriction_Warnings
23614 (Warn => Treat_Restrictions_As_Warnings);
23616 --------------------------
23617 -- Restriction_Warnings --
23618 --------------------------
23620 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
23623 -- restriction_IDENTIFIER
23624 -- | restriction_parameter_IDENTIFIER => EXPRESSION
23626 when Pragma_Restriction_Warnings =>
23628 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
23634 -- pragma Reviewable;
23636 when Pragma_Reviewable =>
23637 Check_Ada_83_Warning;
23638 Check_Arg_Count (0);
23640 -- Call dummy debugging function rv. This is done to assist front
23641 -- end debugging. By placing a Reviewable pragma in the source
23642 -- program, a breakpoint on rv catches this place in the source,
23643 -- allowing convenient stepping to the point of interest.
23647 --------------------------
23648 -- Secondary_Stack_Size --
23649 --------------------------
23651 -- pragma Secondary_Stack_Size (EXPRESSION);
23653 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
23654 P : constant Node_Id := Parent (N);
23660 Check_No_Identifiers;
23661 Check_Arg_Count (1);
23663 if Nkind (P) = N_Task_Definition then
23664 Arg := Get_Pragma_Arg (Arg1);
23665 Ent := Defining_Identifier (Parent (P));
23667 -- The expression must be analyzed in the special manner
23668 -- described in "Handling of Default Expressions" in sem.ads.
23670 Preanalyze_Spec_Expression (Arg, Any_Integer);
23672 -- The pragma cannot appear if the No_Secondary_Stack
23673 -- restriction is in effect.
23675 Check_Restriction (No_Secondary_Stack, Arg);
23677 -- Anything else is incorrect
23683 -- Check duplicate pragma before we chain the pragma in the Rep
23684 -- Item chain of Ent.
23686 Check_Duplicate_Pragma (Ent);
23687 Record_Rep_Item (Ent, N);
23688 end Secondary_Stack_Size;
23690 --------------------------
23691 -- Short_Circuit_And_Or --
23692 --------------------------
23694 -- pragma Short_Circuit_And_Or;
23696 when Pragma_Short_Circuit_And_Or =>
23698 Check_Arg_Count (0);
23699 Check_Valid_Configuration_Pragma;
23700 Short_Circuit_And_Or := True;
23702 -------------------
23703 -- Share_Generic --
23704 -------------------
23706 -- pragma Share_Generic (GNAME {, GNAME});
23708 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
23710 when Pragma_Share_Generic =>
23712 Process_Generic_List;
23718 -- pragma Shared (LOCAL_NAME);
23720 when Pragma_Shared =>
23722 Process_Atomic_Independent_Shared_Volatile;
23724 --------------------
23725 -- Shared_Passive --
23726 --------------------
23728 -- pragma Shared_Passive [(library_unit_NAME)];
23730 -- Set the flag Is_Shared_Passive of program unit name entity
23732 when Pragma_Shared_Passive => Shared_Passive : declare
23733 Cunit_Node : Node_Id;
23734 Cunit_Ent : Entity_Id;
23737 Check_Ada_83_Warning;
23738 Check_Valid_Library_Unit_Pragma;
23740 -- If N was rewritten as a null statement there is nothing more
23743 if Nkind (N) = N_Null_Statement then
23747 Cunit_Node := Cunit (Current_Sem_Unit);
23748 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
23750 -- A pragma that applies to a Ghost entity becomes Ghost for the
23751 -- purposes of legality checks and removal of ignored Ghost code.
23753 Mark_Ghost_Pragma (N, Cunit_Ent);
23755 if Nkind (Unit (Cunit_Node)) not in
23756 N_Package_Declaration | N_Generic_Package_Declaration
23759 ("pragma% can only apply to a package declaration");
23762 Set_Is_Shared_Passive (Cunit_Ent);
23763 end Shared_Passive;
23765 -----------------------
23766 -- Short_Descriptors --
23767 -----------------------
23769 -- pragma Short_Descriptors;
23771 -- Recognize and validate, but otherwise ignore
23773 when Pragma_Short_Descriptors =>
23775 Check_Arg_Count (0);
23776 Check_Valid_Configuration_Pragma;
23782 -- pragma Side_Effects [ (boolean_EXPRESSION) ];
23784 -- Characteristics:
23786 -- * Analysis - The annotation is fully analyzed immediately upon
23787 -- elaboration as its expression must be static.
23789 -- * Expansion - None.
23791 -- * Template - The annotation utilizes the generic template of the
23792 -- related subprogram [body] when it is:
23794 -- aspect on subprogram declaration
23795 -- aspect on stand-alone subprogram body
23796 -- pragma on stand-alone subprogram body
23798 -- The annotation must prepare its own template when it is:
23800 -- pragma on subprogram declaration
23802 -- * Globals - Capture of global references must occur after full
23805 -- * Instance - The annotation is instantiated automatically when
23806 -- the related generic subprogram [body] is instantiated except for
23807 -- the "pragma on subprogram declaration" case. In that scenario
23808 -- the annotation must instantiate itself.
23810 when Pragma_Side_Effects => Side_Effects : declare
23811 Subp_Decl : Node_Id;
23812 Spec_Id : Entity_Id;
23813 Over_Id : Entity_Id;
23817 Check_No_Identifiers;
23818 Check_At_Most_N_Arguments (1);
23821 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23823 -- Abstract subprogram declaration
23825 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
23828 -- Generic subprogram declaration
23830 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23833 -- Body acts as spec
23835 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23836 and then No (Corresponding_Spec (Subp_Decl))
23840 -- Body stub acts as spec
23842 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23843 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23847 -- Subprogram declaration
23849 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23852 -- Otherwise the pragma is associated with an illegal construct
23855 Error_Pragma ("pragma % must apply to a subprogram");
23858 if Nkind (Specification (Subp_Decl)) /= N_Function_Specification
23860 Error_Pragma ("pragma % must apply to a function");
23863 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23865 -- Chain the pragma on the contract for completeness
23867 Add_Contract_Item (N, Spec_Id);
23869 -- A function with side effects cannot override a function without
23870 -- side effects (SPARK RM 7.1.2(16)). Overriding checks are
23871 -- usually performed in New_Overloaded_Entity, however at
23872 -- that point the pragma has not been processed yet.
23874 Over_Id := Overridden_Operation (Spec_Id);
23876 if Present (Over_Id)
23877 and then not Is_Function_With_Side_Effects (Over_Id)
23880 ("incompatible declaration of side effects for function",
23883 Error_Msg_Sloc := Sloc (Over_Id);
23885 ("\& declared # with Side_Effects value False",
23888 Error_Msg_Sloc := Sloc (Spec_Id);
23890 ("\overridden # with Side_Effects value True",
23894 -- Analyze the Boolean expression (if any)
23896 if Present (Arg1) then
23897 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
23901 ------------------------------
23902 -- Simple_Storage_Pool_Type --
23903 ------------------------------
23905 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
23907 when Pragma_Simple_Storage_Pool_Type =>
23908 Simple_Storage_Pool_Type : declare
23914 Check_Arg_Count (1);
23915 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23917 Type_Id := Get_Pragma_Arg (Arg1);
23918 Find_Type (Type_Id);
23919 Typ := Entity (Type_Id);
23921 if Typ = Any_Type then
23925 -- A pragma that applies to a Ghost entity becomes Ghost for the
23926 -- purposes of legality checks and removal of ignored Ghost code.
23928 Mark_Ghost_Pragma (N, Typ);
23930 -- We require the pragma to apply to a type declared in a package
23931 -- declaration, but not (immediately) within a package body.
23933 if Ekind (Current_Scope) /= E_Package
23934 or else In_Package_Body (Current_Scope)
23937 ("pragma% can only apply to type declared immediately "
23938 & "within a package declaration");
23941 -- A simple storage pool type must be an immutably limited record
23942 -- or private type. If the pragma is given for a private type,
23943 -- the full type is similarly restricted (which is checked later
23944 -- in Freeze_Entity).
23946 if Is_Record_Type (Typ)
23947 and then not Is_Inherently_Limited_Type (Typ)
23950 ("pragma% can only apply to explicitly limited record type");
23952 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
23954 ("pragma% can only apply to a private type that is limited");
23956 elsif not Is_Record_Type (Typ)
23957 and then not Is_Private_Type (Typ)
23960 ("pragma% can only apply to limited record or private type");
23963 Record_Rep_Item (Typ, N);
23964 end Simple_Storage_Pool_Type;
23966 ----------------------
23967 -- Source_File_Name --
23968 ----------------------
23970 -- There are five forms for this pragma:
23972 -- pragma Source_File_Name (
23973 -- [UNIT_NAME =>] unit_NAME,
23974 -- BODY_FILE_NAME => STRING_LITERAL
23975 -- [, [INDEX =>] INTEGER_LITERAL]);
23977 -- pragma Source_File_Name (
23978 -- [UNIT_NAME =>] unit_NAME,
23979 -- SPEC_FILE_NAME => STRING_LITERAL
23980 -- [, [INDEX =>] INTEGER_LITERAL]);
23982 -- pragma Source_File_Name (
23983 -- BODY_FILE_NAME => STRING_LITERAL
23984 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23985 -- [, CASING => CASING_SPEC]);
23987 -- pragma Source_File_Name (
23988 -- SPEC_FILE_NAME => STRING_LITERAL
23989 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23990 -- [, CASING => CASING_SPEC]);
23992 -- pragma Source_File_Name (
23993 -- SUBUNIT_FILE_NAME => STRING_LITERAL
23994 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23995 -- [, CASING => CASING_SPEC]);
23997 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
23999 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
24000 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
24001 -- only be used when no project file is used, while SFNP can only be
24002 -- used when a project file is used.
24004 -- No processing here. Processing was completed during parsing, since
24005 -- we need to have file names set as early as possible. Units are
24006 -- loaded well before semantic processing starts.
24008 -- The only processing we defer to this point is the check for
24009 -- correct placement.
24011 when Pragma_Source_File_Name =>
24013 Check_Valid_Configuration_Pragma;
24015 ------------------------------
24016 -- Source_File_Name_Project --
24017 ------------------------------
24019 -- See Source_File_Name for syntax
24021 -- No processing here. Processing was completed during parsing, since
24022 -- we need to have file names set as early as possible. Units are
24023 -- loaded well before semantic processing starts.
24025 -- The only processing we defer to this point is the check for
24026 -- correct placement.
24028 when Pragma_Source_File_Name_Project =>
24030 Check_Valid_Configuration_Pragma;
24032 -- Check that a pragma Source_File_Name_Project is used only in a
24033 -- configuration pragmas file.
24035 -- Pragmas Source_File_Name_Project should only be generated by
24036 -- the Project Manager in configuration pragmas files.
24038 -- This is really an ugly test. It seems to depend on some
24039 -- accidental and undocumented property. At the very least it
24040 -- needs to be documented, but it would be better to have a
24041 -- clean way of testing if we are in a configuration file???
24043 if Present (Parent (N)) then
24045 ("pragma% can only appear in a configuration pragmas file");
24048 ----------------------
24049 -- Source_Reference --
24050 ----------------------
24052 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
24054 -- Nothing to do, all processing completed in Par.Prag, since we need
24055 -- the information for possible parser messages that are output.
24057 when Pragma_Source_Reference =>
24064 -- pragma SPARK_Mode [(Auto | On | Off)];
24066 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
24067 Mode_Id : SPARK_Mode_Type;
24069 procedure Check_Pragma_Conformance
24070 (Context_Pragma : Node_Id;
24071 Entity : Entity_Id;
24072 Entity_Pragma : Node_Id);
24073 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
24074 -- conformance of pragma N depending the following scenarios:
24076 -- If pragma Context_Pragma is not Empty, verify that pragma N is
24077 -- compatible with the pragma Context_Pragma that was inherited
24078 -- from the context:
24079 -- * If the mode of Context_Pragma is ON, then the new mode can
24081 -- * If the mode of Context_Pragma is OFF, then the only allowed
24082 -- new mode is also OFF. Emit error if this is not the case.
24084 -- If Entity is not Empty, verify that pragma N is compatible with
24085 -- pragma Entity_Pragma that belongs to Entity.
24086 -- * If Entity_Pragma is Empty, always issue an error as this
24087 -- corresponds to the case where a previous section of Entity
24088 -- has no SPARK_Mode set.
24089 -- * If the mode of Entity_Pragma is ON, then the new mode can
24091 -- * If the mode of Entity_Pragma is OFF, then the only allowed
24092 -- new mode is also OFF. Emit error if this is not the case.
24094 procedure Check_Library_Level_Entity (E : Entity_Id);
24095 -- Subsidiary to routines Process_xxx. Verify that the related
24096 -- entity E subject to pragma SPARK_Mode is library-level.
24098 procedure Process_Body (Decl : Node_Id);
24099 -- Verify the legality of pragma SPARK_Mode when it appears as the
24100 -- top of the body declarations of entry, package, protected unit,
24101 -- subprogram or task unit body denoted by Decl.
24103 procedure Process_Overloadable (Decl : Node_Id);
24104 -- Verify the legality of pragma SPARK_Mode when it applies to an
24105 -- entry or [generic] subprogram declaration denoted by Decl.
24107 procedure Process_Private_Part (Decl : Node_Id);
24108 -- Verify the legality of pragma SPARK_Mode when it appears at the
24109 -- top of the private declarations of a package spec, protected or
24110 -- task unit declaration denoted by Decl.
24112 procedure Process_Statement_Part (Decl : Node_Id);
24113 -- Verify the legality of pragma SPARK_Mode when it appears at the
24114 -- top of the statement sequence of a package body denoted by node
24117 procedure Process_Visible_Part (Decl : Node_Id);
24118 -- Verify the legality of pragma SPARK_Mode when it appears at the
24119 -- top of the visible declarations of a package spec, protected or
24120 -- task unit declaration denoted by Decl. The routine is also used
24121 -- on protected or task units declared without a definition.
24123 procedure Set_SPARK_Context;
24124 -- Subsidiary to routines Process_xxx. Set the global variables
24125 -- which represent the mode of the context from pragma N. Ensure
24126 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
24128 ------------------------------
24129 -- Check_Pragma_Conformance --
24130 ------------------------------
24132 procedure Check_Pragma_Conformance
24133 (Context_Pragma : Node_Id;
24134 Entity : Entity_Id;
24135 Entity_Pragma : Node_Id)
24137 Err_Id : Entity_Id;
24141 -- The current pragma may appear without an argument. If this
24142 -- is the case, associate all error messages with the pragma
24145 if Present (Arg1) then
24151 -- The mode of the current pragma is compared against that of
24152 -- an enclosing context.
24154 if Present (Context_Pragma) then
24155 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
24157 -- Issue an error if the new mode is less restrictive than
24158 -- that of the context.
24160 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
24161 and then Get_SPARK_Mode_From_Annotation (N) = On
24164 ("cannot change SPARK_Mode from Off to On", Err_N);
24165 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
24166 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
24171 -- The mode of the current pragma is compared against that of
24172 -- an initial package, protected type, subprogram or task type
24175 if Present (Entity) then
24177 -- A simple protected or task type is transformed into an
24178 -- anonymous type whose name cannot be used to issue error
24179 -- messages. Recover the original entity of the type.
24181 if Ekind (Entity) in E_Protected_Type | E_Task_Type then
24184 (Original_Node (Unit_Declaration_Node (Entity)));
24189 -- Both the initial declaration and the completion carry
24190 -- SPARK_Mode pragmas.
24192 if Present (Entity_Pragma) then
24193 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
24195 -- Issue an error if the new mode is less restrictive
24196 -- than that of the initial declaration.
24198 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
24199 and then Get_SPARK_Mode_From_Annotation (N) = On
24201 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
24202 Error_Msg_Sloc := Sloc (Entity_Pragma);
24204 ("\value Off was set for SPARK_Mode on&#",
24209 -- Otherwise the initial declaration lacks a SPARK_Mode
24210 -- pragma in which case the current pragma is illegal as
24211 -- it cannot "complete".
24213 elsif Get_SPARK_Mode_From_Annotation (N) = Off
24214 and then (Is_Generic_Unit (Entity) or else In_Instance)
24219 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
24220 Error_Msg_Sloc := Sloc (Err_Id);
24222 ("\no value was set for SPARK_Mode on&#",
24227 end Check_Pragma_Conformance;
24229 --------------------------------
24230 -- Check_Library_Level_Entity --
24231 --------------------------------
24233 procedure Check_Library_Level_Entity (E : Entity_Id) is
24234 procedure Add_Entity_To_Name_Buffer;
24235 -- Add the E_Kind of entity E to the name buffer
24237 -------------------------------
24238 -- Add_Entity_To_Name_Buffer --
24239 -------------------------------
24241 procedure Add_Entity_To_Name_Buffer is
24243 if Ekind (E) in E_Entry | E_Entry_Family then
24244 Add_Str_To_Name_Buffer ("entry");
24246 elsif Ekind (E) in E_Generic_Package
24250 Add_Str_To_Name_Buffer ("package");
24252 elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
24253 Add_Str_To_Name_Buffer ("protected type");
24255 elsif Ekind (E) in E_Function
24256 | E_Generic_Function
24257 | E_Generic_Procedure
24259 | E_Subprogram_Body
24261 Add_Str_To_Name_Buffer ("subprogram");
24264 pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
24265 Add_Str_To_Name_Buffer ("task type");
24267 end Add_Entity_To_Name_Buffer;
24271 Msg_1 : constant String :=
24272 "incorrect placement of pragma% with value ""On"" '[[]']";
24275 -- Start of processing for Check_Library_Level_Entity
24278 -- A SPARK_Mode of On shall only apply to library-level
24279 -- entities, except for those in generic instances, which are
24280 -- ignored (even if the entity gets SPARK_Mode pragma attached
24281 -- in the AST, its effect is not taken into account unless the
24282 -- context already provides SPARK_Mode of On in GNATprove).
24284 if Get_SPARK_Mode_From_Annotation (N) = On
24285 and then not Is_Library_Level_Entity (E)
24286 and then Instantiation_Location (Sloc (N)) = No_Location
24288 Error_Msg_Name_1 := Pname;
24289 Error_Msg_Code := GEC_SPARK_Mode_On_Not_Library_Level;
24290 Error_Msg_N (Fix_Error (Msg_1), N);
24293 Add_Str_To_Name_Buffer ("\& is not a library-level ");
24294 Add_Entity_To_Name_Buffer;
24296 Msg_2 := Name_Find;
24297 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
24301 end Check_Library_Level_Entity;
24307 procedure Process_Body (Decl : Node_Id) is
24308 Body_Id : constant Entity_Id := Defining_Entity (Decl);
24309 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
24312 -- Ignore pragma when applied to the special body created
24313 -- for inlining, recognized by its internal name _Parent; or
24314 -- when applied to the special body created for contracts,
24315 -- recognized by its internal name _Wrapped_Statements.
24317 if Chars (Body_Id) in Name_uParent
24318 | Name_uWrapped_Statements
24323 Check_Library_Level_Entity (Body_Id);
24325 -- For entry bodies, verify the legality against:
24326 -- * The mode of the context
24327 -- * The mode of the spec (if any)
24329 if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
24331 -- A stand-alone subprogram body
24333 if Body_Id = Spec_Id then
24334 Check_Pragma_Conformance
24335 (Context_Pragma => SPARK_Pragma (Body_Id),
24337 Entity_Pragma => Empty);
24339 -- An entry or subprogram body that completes a previous
24343 Check_Pragma_Conformance
24344 (Context_Pragma => SPARK_Pragma (Body_Id),
24346 Entity_Pragma => SPARK_Pragma (Spec_Id));
24350 Set_SPARK_Pragma (Body_Id, N);
24351 Set_SPARK_Pragma_Inherited (Body_Id, False);
24353 -- For package bodies, verify the legality against:
24354 -- * The mode of the context
24355 -- * The mode of the private part
24357 -- This case is separated from protected and task bodies
24358 -- because the statement part of the package body inherits
24359 -- the mode of the body declarations.
24361 elsif Nkind (Decl) = N_Package_Body then
24362 Check_Pragma_Conformance
24363 (Context_Pragma => SPARK_Pragma (Body_Id),
24365 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
24368 Set_SPARK_Pragma (Body_Id, N);
24369 Set_SPARK_Pragma_Inherited (Body_Id, False);
24370 Set_SPARK_Aux_Pragma (Body_Id, N);
24371 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
24373 -- For protected and task bodies, verify the legality against:
24374 -- * The mode of the context
24375 -- * The mode of the private part
24379 (Nkind (Decl) in N_Protected_Body | N_Task_Body);
24381 Check_Pragma_Conformance
24382 (Context_Pragma => SPARK_Pragma (Body_Id),
24384 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
24387 Set_SPARK_Pragma (Body_Id, N);
24388 Set_SPARK_Pragma_Inherited (Body_Id, False);
24392 --------------------------
24393 -- Process_Overloadable --
24394 --------------------------
24396 procedure Process_Overloadable (Decl : Node_Id) is
24397 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
24398 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
24401 Check_Library_Level_Entity (Spec_Id);
24403 -- Verify the legality against:
24404 -- * The mode of the context
24406 Check_Pragma_Conformance
24407 (Context_Pragma => SPARK_Pragma (Spec_Id),
24409 Entity_Pragma => Empty);
24411 Set_SPARK_Pragma (Spec_Id, N);
24412 Set_SPARK_Pragma_Inherited (Spec_Id, False);
24414 -- When the pragma applies to the anonymous object created for
24415 -- a single task type, decorate the type as well. This scenario
24416 -- arises when the single task type lacks a task definition,
24417 -- therefore there is no issue with respect to a potential
24418 -- pragma SPARK_Mode in the private part.
24420 -- task type Anon_Task_Typ;
24421 -- Obj : Anon_Task_Typ;
24422 -- pragma SPARK_Mode ...;
24424 if Is_Single_Task_Object (Spec_Id) then
24425 Set_SPARK_Pragma (Spec_Typ, N);
24426 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
24427 Set_SPARK_Aux_Pragma (Spec_Typ, N);
24428 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
24430 end Process_Overloadable;
24432 --------------------------
24433 -- Process_Private_Part --
24434 --------------------------
24436 procedure Process_Private_Part (Decl : Node_Id) is
24437 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
24440 Check_Library_Level_Entity (Spec_Id);
24442 -- Verify the legality against:
24443 -- * The mode of the visible declarations
24445 Check_Pragma_Conformance
24446 (Context_Pragma => Empty,
24448 Entity_Pragma => SPARK_Pragma (Spec_Id));
24451 Set_SPARK_Aux_Pragma (Spec_Id, N);
24452 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
24453 end Process_Private_Part;
24455 ----------------------------
24456 -- Process_Statement_Part --
24457 ----------------------------
24459 procedure Process_Statement_Part (Decl : Node_Id) is
24460 Body_Id : constant Entity_Id := Defining_Entity (Decl);
24463 Check_Library_Level_Entity (Body_Id);
24465 -- Verify the legality against:
24466 -- * The mode of the body declarations
24468 Check_Pragma_Conformance
24469 (Context_Pragma => Empty,
24471 Entity_Pragma => SPARK_Pragma (Body_Id));
24474 Set_SPARK_Aux_Pragma (Body_Id, N);
24475 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
24476 end Process_Statement_Part;
24478 --------------------------
24479 -- Process_Visible_Part --
24480 --------------------------
24482 procedure Process_Visible_Part (Decl : Node_Id) is
24483 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
24484 Obj_Id : Entity_Id;
24487 Check_Library_Level_Entity (Spec_Id);
24489 -- Verify the legality against:
24490 -- * The mode of the context
24492 Check_Pragma_Conformance
24493 (Context_Pragma => SPARK_Pragma (Spec_Id),
24495 Entity_Pragma => Empty);
24497 -- A task unit declared without a definition does not set the
24498 -- SPARK_Mode of the context because the task does not have any
24499 -- entries that could inherit the mode.
24501 if Nkind (Decl) not in
24502 N_Single_Task_Declaration | N_Task_Type_Declaration
24507 Set_SPARK_Pragma (Spec_Id, N);
24508 Set_SPARK_Pragma_Inherited (Spec_Id, False);
24509 Set_SPARK_Aux_Pragma (Spec_Id, N);
24510 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
24512 -- When the pragma applies to a single protected or task type,
24513 -- decorate the corresponding anonymous object as well.
24515 -- protected Anon_Prot_Typ is
24516 -- pragma SPARK_Mode ...;
24518 -- end Anon_Prot_Typ;
24520 -- Obj : Anon_Prot_Typ;
24522 if Is_Single_Concurrent_Type (Spec_Id) then
24523 Obj_Id := Anonymous_Object (Spec_Id);
24525 Set_SPARK_Pragma (Obj_Id, N);
24526 Set_SPARK_Pragma_Inherited (Obj_Id, False);
24528 end Process_Visible_Part;
24530 -----------------------
24531 -- Set_SPARK_Context --
24532 -----------------------
24534 procedure Set_SPARK_Context is
24536 SPARK_Mode := Mode_Id;
24537 SPARK_Mode_Pragma := N;
24538 end Set_SPARK_Context;
24546 -- Start of processing for Do_SPARK_Mode
24550 Check_No_Identifiers;
24551 Check_At_Most_N_Arguments (1);
24553 -- Check the legality of the mode (no argument = ON)
24555 if Arg_Count = 1 then
24556 Check_Arg_Is_One_Of (Arg1, Name_Auto, Name_On, Name_Off);
24557 Mode := Chars (Get_Pragma_Arg (Arg1));
24562 Mode_Id := Get_SPARK_Mode_Type (Mode);
24563 Context := Parent (N);
24565 -- When a SPARK_Mode pragma appears inside an instantiation whose
24566 -- enclosing context has SPARK_Mode set to "off", the pragma has
24567 -- no semantic effect.
24569 if Ignore_SPARK_Mode_Pragmas_In_Instance
24570 and then Mode_Id /= Off
24572 Rewrite (N, Make_Null_Statement (Loc));
24577 -- The pragma appears in a configuration file
24579 if No (Context) then
24580 Check_Valid_Configuration_Pragma;
24582 if Present (SPARK_Mode_Pragma) then
24585 Prev => SPARK_Mode_Pragma);
24591 -- The pragma acts as a configuration pragma in a compilation unit
24593 -- pragma SPARK_Mode ...;
24594 -- package Pack is ...;
24596 elsif Nkind (Context) = N_Compilation_Unit
24597 and then List_Containing (N) = Context_Items (Context)
24599 Check_Valid_Configuration_Pragma;
24602 -- Otherwise the placement of the pragma within the tree dictates
24603 -- its associated construct. Inspect the declarative list where
24604 -- the pragma resides to find a potential construct.
24607 -- An explicit mode of Auto is only allowed as a configuration
24608 -- pragma. Escape "pragma" to avoid replacement with "aspect".
24610 if Mode_Id = None then
24612 ("only configuration 'p'r'a'g'm'a% can have value &",
24617 while Present (Stmt) loop
24619 -- Skip prior pragmas, but check for duplicates. Note that
24620 -- this also takes care of pragmas generated for aspects.
24622 if Nkind (Stmt) = N_Pragma then
24623 if Pragma_Name (Stmt) = Pname then
24630 -- The pragma applies to an expression function that has
24631 -- already been rewritten into a subprogram declaration.
24633 -- function Expr_Func return ... is (...);
24634 -- pragma SPARK_Mode ...;
24636 elsif Nkind (Stmt) = N_Subprogram_Declaration
24637 and then Nkind (Original_Node (Stmt)) =
24638 N_Expression_Function
24640 Process_Overloadable (Stmt);
24643 -- The pragma applies to the anonymous object created for a
24644 -- single concurrent type.
24646 -- protected type Anon_Prot_Typ ...;
24647 -- Obj : Anon_Prot_Typ;
24648 -- pragma SPARK_Mode ...;
24650 elsif Nkind (Stmt) = N_Object_Declaration
24651 and then Is_Single_Concurrent_Object
24652 (Defining_Entity (Stmt))
24654 Process_Overloadable (Stmt);
24657 -- Skip internally generated code
24659 elsif not Comes_From_Source (Stmt) then
24662 -- The pragma applies to an entry or [generic] subprogram
24666 -- pragma SPARK_Mode ...;
24669 -- procedure Proc ...;
24670 -- pragma SPARK_Mode ...;
24672 elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
24673 | N_Subprogram_Declaration
24674 or else (Nkind (Stmt) = N_Entry_Declaration
24675 and then Is_Protected_Type
24676 (Scope (Defining_Entity (Stmt))))
24678 Process_Overloadable (Stmt);
24681 -- Otherwise the pragma does not apply to a legal construct
24682 -- or it does not appear at the top of a declarative or a
24683 -- statement list. Issue an error and stop the analysis.
24692 -- The pragma applies to a package or a subprogram that acts as
24693 -- a compilation unit.
24695 -- procedure Proc ...;
24696 -- pragma SPARK_Mode ...;
24698 if Nkind (Context) = N_Compilation_Unit_Aux then
24699 Context := Unit (Parent (Context));
24702 -- The pragma appears at the top of entry, package, protected
24703 -- unit, subprogram or task unit body declarations.
24705 -- entry Ent when ... is
24706 -- pragma SPARK_Mode ...;
24708 -- package body Pack is
24709 -- pragma SPARK_Mode ...;
24711 -- procedure Proc ... is
24712 -- pragma SPARK_Mode;
24714 -- protected body Prot is
24715 -- pragma SPARK_Mode ...;
24717 if Nkind (Context) in N_Entry_Body
24720 | N_Subprogram_Body
24723 Process_Body (Context);
24725 -- The pragma appears at the top of the visible or private
24726 -- declaration of a package spec, protected or task unit.
24729 -- pragma SPARK_Mode ...;
24731 -- pragma SPARK_Mode ...;
24733 -- protected [type] Prot is
24734 -- pragma SPARK_Mode ...;
24736 -- pragma SPARK_Mode ...;
24738 elsif Nkind (Context) in N_Package_Specification
24739 | N_Protected_Definition
24740 | N_Task_Definition
24742 if List_Containing (N) = Visible_Declarations (Context) then
24743 Process_Visible_Part (Parent (Context));
24745 Process_Private_Part (Parent (Context));
24748 -- The pragma appears at the top of package body statements
24750 -- package body Pack is
24752 -- pragma SPARK_Mode;
24754 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
24755 and then Nkind (Parent (Context)) = N_Package_Body
24757 Process_Statement_Part (Parent (Context));
24759 -- The pragma appeared as an aspect of a [generic] subprogram
24760 -- declaration that acts as a compilation unit.
24763 -- procedure Proc ...;
24764 -- pragma SPARK_Mode ...;
24766 elsif Nkind (Context) in N_Generic_Subprogram_Declaration
24767 | N_Subprogram_Declaration
24769 Process_Overloadable (Context);
24771 -- The pragma does not apply to a legal construct, issue error
24779 --------------------------------
24780 -- Static_Elaboration_Desired --
24781 --------------------------------
24783 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
24785 when Pragma_Static_Elaboration_Desired =>
24787 Check_At_Most_N_Arguments (1);
24789 if Is_Compilation_Unit (Current_Scope)
24790 and then Ekind (Current_Scope) = E_Package
24792 Set_Static_Elaboration_Desired (Current_Scope, True);
24794 Error_Pragma ("pragma% must apply to a library-level package");
24801 -- pragma Storage_Size (EXPRESSION);
24803 when Pragma_Storage_Size => Storage_Size : declare
24804 P : constant Node_Id := Parent (N);
24808 Check_No_Identifiers;
24809 Check_Arg_Count (1);
24811 -- The expression must be analyzed in the special manner described
24812 -- in "Handling of Default Expressions" in sem.ads.
24814 Arg := Get_Pragma_Arg (Arg1);
24815 Preanalyze_Spec_Expression (Arg, Any_Integer);
24817 if not Is_OK_Static_Expression (Arg) then
24818 Check_Restriction (Static_Storage_Size, Arg);
24821 if Nkind (P) /= N_Task_Definition then
24825 if Has_Storage_Size_Pragma (P) then
24826 Error_Pragma ("duplicate pragma% not allowed");
24828 Set_Has_Storage_Size_Pragma (P, True);
24831 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
24839 -- pragma Storage_Unit (NUMERIC_LITERAL);
24841 -- Only permitted argument is System'Storage_Unit value
24843 when Pragma_Storage_Unit =>
24844 Check_No_Identifiers;
24845 Check_Arg_Count (1);
24846 Check_Arg_Is_Integer_Literal (Arg1);
24848 if Intval (Get_Pragma_Arg (Arg1)) /=
24849 UI_From_Int (Ttypes.System_Storage_Unit)
24851 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
24853 ("the only allowed argument for pragma% is ^", Arg1);
24856 --------------------
24857 -- Stream_Convert --
24858 --------------------
24860 -- pragma Stream_Convert (
24861 -- [Entity =>] type_LOCAL_NAME,
24862 -- [Read =>] function_NAME,
24863 -- [Write =>] function NAME);
24865 when Pragma_Stream_Convert => Stream_Convert : declare
24866 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
24867 -- Check that the given argument is the name of a local function
24868 -- of one argument that is not overloaded earlier in the current
24869 -- local scope. A check is also made that the argument is a
24870 -- function with one parameter.
24872 --------------------------------------
24873 -- Check_OK_Stream_Convert_Function --
24874 --------------------------------------
24876 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
24880 Check_Arg_Is_Local_Name (Arg);
24881 Ent := Entity (Get_Pragma_Arg (Arg));
24883 if Has_Homonym (Ent) then
24885 ("argument for pragma% may not be overloaded", Arg);
24888 if Ekind (Ent) /= E_Function
24889 or else No (First_Formal (Ent))
24890 or else Present (Next_Formal (First_Formal (Ent)))
24893 ("argument for pragma% must be function of one argument",
24895 elsif Is_Abstract_Subprogram (Ent) then
24897 ("argument for pragma% cannot be abstract", Arg);
24899 end Check_OK_Stream_Convert_Function;
24901 -- Start of processing for Stream_Convert
24905 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
24906 Check_Arg_Count (3);
24907 Check_Optional_Identifier (Arg1, Name_Entity);
24908 Check_Optional_Identifier (Arg2, Name_Read);
24909 Check_Optional_Identifier (Arg3, Name_Write);
24910 Check_Arg_Is_Local_Name (Arg1);
24911 Check_OK_Stream_Convert_Function (Arg2);
24912 Check_OK_Stream_Convert_Function (Arg3);
24915 Typ : constant Entity_Id :=
24916 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
24917 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
24918 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
24921 Check_First_Subtype (Arg1);
24923 -- Check for too early or too late. Note that we don't enforce
24924 -- the rule about primitive operations in this case, since, as
24925 -- is the case for explicit stream attributes themselves, these
24926 -- restrictions are not appropriate. Note that the chaining of
24927 -- the pragma by Rep_Item_Too_Late is actually the critical
24928 -- processing done for this pragma.
24930 if Rep_Item_Too_Early (Typ, N)
24932 Rep_Item_Too_Late (Typ, N, FOnly => True)
24937 -- Return if previous error
24939 if Etype (Typ) = Any_Type
24941 Etype (Read) = Any_Type
24943 Etype (Write) = Any_Type
24950 if Underlying_Type (Etype (Read)) /= Typ then
24952 ("incorrect return type for function&", Arg2);
24955 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
24957 ("incorrect parameter type for function&", Arg3);
24960 if Underlying_Type (Etype (First_Formal (Read))) /=
24961 Underlying_Type (Etype (Write))
24964 ("result type of & does not match Read parameter type",
24968 end Stream_Convert;
24974 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24976 -- This is processed by the parser since some of the style checks
24977 -- take place during source scanning and parsing. This means that
24978 -- we don't need to issue error messages here.
24980 when Pragma_Style_Checks => Style_Checks : declare
24981 A : constant Node_Id := Get_Pragma_Arg (Arg1);
24987 Check_No_Identifiers;
24989 -- Two argument form
24991 if Arg_Count = 2 then
24992 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24999 E_Id := Get_Pragma_Arg (Arg2);
25002 if not Is_Entity_Name (E_Id) then
25004 ("second argument of pragma% must be entity name",
25008 E := Entity (E_Id);
25010 if not Ignore_Style_Checks_Pragmas then
25015 Set_Suppress_Style_Checks
25016 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
25017 exit when No (Homonym (E));
25024 -- One argument form
25027 Check_Arg_Count (1);
25029 if Ignore_Style_Checks_Pragmas then
25033 if Nkind (A) = N_String_Literal then
25037 Slen : constant Natural := Natural (String_Length (S));
25038 Options : String (1 .. Slen);
25044 C := Get_String_Char (S, Pos (J));
25045 exit when not In_Character_Range (C);
25046 Options (J) := Get_Character (C);
25048 -- If at end of string, set options. As per discussion
25049 -- above, no need to check for errors, since we issued
25050 -- them in the parser.
25053 Set_Style_Check_Options (Options);
25062 elsif Nkind (A) = N_Identifier then
25063 if Chars (A) = Name_All_Checks then
25065 Set_GNAT_Style_Check_Options;
25067 Set_Default_Style_Check_Options;
25070 elsif Chars (A) = Name_On then
25071 Style_Check := True;
25073 elsif Chars (A) = Name_Off then
25074 Style_Check := False;
25080 ------------------------
25081 -- Subprogram_Variant --
25082 ------------------------
25084 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_LIST );
25086 -- SUBPROGRAM_VARIANT_LIST ::= STRUCTURAL_SUBPROGRAM_VARIANT_ITEM
25087 -- | NUMERIC_SUBPROGRAM_VARIANT_ITEMS
25088 -- NUMERIC_SUBPROGRAM_VARIANT_ITEMS ::=
25089 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM
25090 -- {, NUMERIC_SUBPROGRAM_VARIANT_ITEM}
25091 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM ::= CHANGE_DIRECTION => EXPRESSION
25092 -- STRUCTURAL_SUBPROGRAM_VARIANT_ITEM ::= Structural => EXPRESSION
25093 -- CHANGE_DIRECTION ::= Increases | Decreases
25095 -- Characteristics:
25097 -- * Analysis - The annotation undergoes initial checks to verify
25098 -- the legal placement and context. Secondary checks preanalyze the
25101 -- Analyze_Subprogram_Variant_In_Decl_Part
25103 -- * Expansion - The annotation is expanded during the expansion of
25104 -- the related subprogram [body] contract as performed in:
25106 -- Expand_Subprogram_Contract
25108 -- * Template - The annotation utilizes the generic template of the
25109 -- related subprogram [body] when it is:
25111 -- aspect on subprogram declaration
25112 -- aspect on stand-alone subprogram body
25113 -- pragma on stand-alone subprogram body
25115 -- The annotation must prepare its own template when it is:
25117 -- pragma on subprogram declaration
25119 -- * Globals - Capture of global references must occur after full
25122 -- * Instance - The annotation is instantiated automatically when
25123 -- the related generic subprogram [body] is instantiated except for
25124 -- the "pragma on subprogram declaration" case. In that scenario
25125 -- the annotation must instantiate itself.
25127 when Pragma_Subprogram_Variant => Subprogram_Variant : declare
25128 Spec_Id : Entity_Id;
25129 Subp_Decl : Node_Id;
25130 Subp_Spec : Node_Id;
25134 Check_No_Identifiers;
25135 Check_Arg_Count (1);
25137 -- Ensure the proper placement of the pragma. Subprogram_Variant
25138 -- must be associated with a subprogram declaration or a body that
25142 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25144 -- Generic subprogram
25146 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25149 -- Body acts as spec
25151 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25152 and then No (Corresponding_Spec (Subp_Decl))
25156 -- Body stub acts as spec
25158 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25159 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25165 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25166 Subp_Spec := Specification (Subp_Decl);
25168 -- Pragma Subprogram_Variant is forbidden on null procedures,
25169 -- as this may lead to potential ambiguities in behavior when
25170 -- interface null procedures are involved. Also, it just
25171 -- wouldn't make sense, because null procedure is not
25174 if Nkind (Subp_Spec) = N_Procedure_Specification
25175 and then Null_Present (Subp_Spec)
25177 Error_Msg_N (Fix_Error
25178 ("pragma % cannot apply to null procedure"), N);
25186 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25188 -- A pragma that applies to a Ghost entity becomes Ghost for the
25189 -- purposes of legality checks and removal of ignored Ghost code.
25191 Mark_Ghost_Pragma (N, Spec_Id);
25192 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
25194 -- Chain the pragma on the contract for further processing by
25195 -- Analyze_Subprogram_Variant_In_Decl_Part.
25197 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
25199 -- Fully analyze the pragma when it appears inside a subprogram
25200 -- body because it cannot benefit from forward references.
25202 if Nkind (Subp_Decl) in N_Subprogram_Body
25203 | N_Subprogram_Body_Stub
25205 -- The legality checks of pragma Subprogram_Variant are
25206 -- affected by the SPARK mode in effect and the volatility
25207 -- of the context. Analyze all pragmas in a specific order.
25209 Analyze_If_Present (Pragma_SPARK_Mode);
25210 Analyze_If_Present (Pragma_Volatile_Function);
25211 Analyze_Subprogram_Variant_In_Decl_Part (N);
25213 end Subprogram_Variant;
25219 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
25221 when Pragma_Subtitle =>
25223 Check_Arg_Count (1);
25224 Check_Optional_Identifier (Arg1, Name_Subtitle);
25225 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
25232 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
25234 when Pragma_Suppress =>
25235 Process_Suppress_Unsuppress (Suppress_Case => True);
25241 -- pragma Suppress_All;
25243 -- The only check made here is that the pragma has no arguments.
25244 -- There are no placement rules, and the processing required (setting
25245 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
25246 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
25247 -- then creates and inserts a pragma Suppress (All_Checks).
25249 when Pragma_Suppress_All =>
25251 Check_Arg_Count (0);
25253 -------------------------
25254 -- Suppress_Debug_Info --
25255 -------------------------
25257 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
25259 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
25260 Nam_Id : Entity_Id;
25264 Check_Arg_Count (1);
25265 Check_Optional_Identifier (Arg1, Name_Entity);
25266 Check_Arg_Is_Local_Name (Arg1);
25268 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
25270 -- A pragma that applies to a Ghost entity becomes Ghost for the
25271 -- purposes of legality checks and removal of ignored Ghost code.
25273 Mark_Ghost_Pragma (N, Nam_Id);
25274 Set_Debug_Info_Off (Nam_Id);
25275 end Suppress_Debug_Info;
25277 ----------------------------------
25278 -- Suppress_Exception_Locations --
25279 ----------------------------------
25281 -- pragma Suppress_Exception_Locations;
25283 when Pragma_Suppress_Exception_Locations =>
25285 Check_Arg_Count (0);
25286 Check_Valid_Configuration_Pragma;
25287 Exception_Locations_Suppressed := True;
25289 -----------------------------
25290 -- Suppress_Initialization --
25291 -----------------------------
25293 -- pragma Suppress_Initialization ([Entity =>] type_Name);
25295 when Pragma_Suppress_Initialization => Suppress_Init : declare
25301 Check_Arg_Count (1);
25302 Check_Optional_Identifier (Arg1, Name_Entity);
25303 Check_Arg_Is_Local_Name (Arg1);
25305 E_Id := Get_Pragma_Arg (Arg1);
25307 if Etype (E_Id) = Any_Type then
25311 E := Entity (E_Id);
25313 -- A pragma that applies to a Ghost entity becomes Ghost for the
25314 -- purposes of legality checks and removal of ignored Ghost code.
25316 Mark_Ghost_Pragma (N, E);
25318 if not Is_Type (E) and then Ekind (E) /= E_Variable then
25320 ("pragma% requires variable, type or subtype", Arg1);
25323 if Rep_Item_Too_Early (E, N)
25325 Rep_Item_Too_Late (E, N, FOnly => True)
25330 -- For incomplete/private type, set flag on full view
25332 if Is_Incomplete_Or_Private_Type (E) then
25333 if No (Full_View (Base_Type (E))) then
25335 ("argument of pragma% cannot be an incomplete type", Arg1);
25337 Set_Suppress_Initialization (Full_View (E));
25340 -- For first subtype, set flag on base type
25342 elsif Is_First_Subtype (E) then
25343 Set_Suppress_Initialization (Base_Type (E));
25345 -- For other than first subtype, set flag on subtype or variable
25348 Set_Suppress_Initialization (E);
25356 -- pragma System_Name (DIRECT_NAME);
25358 -- Syntax check: one argument, which must be the identifier GNAT or
25359 -- the identifier GCC, no other identifiers are acceptable.
25361 when Pragma_System_Name =>
25363 Check_No_Identifiers;
25364 Check_Arg_Count (1);
25365 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
25367 -----------------------------
25368 -- Task_Dispatching_Policy --
25369 -----------------------------
25371 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
25373 when Pragma_Task_Dispatching_Policy => declare
25377 Check_Ada_83_Warning;
25378 Check_Arg_Count (1);
25379 Check_No_Identifiers;
25380 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
25381 Check_Valid_Configuration_Pragma;
25382 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
25383 DP := Fold_Upper (Name_Buffer (1));
25385 if Task_Dispatching_Policy /= ' '
25386 and then Task_Dispatching_Policy /= DP
25388 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
25390 ("task dispatching policy incompatible with policy#");
25392 -- Set new policy, but always preserve System_Location since we
25393 -- like the error message with the run time name.
25396 Task_Dispatching_Policy := DP;
25398 if Task_Dispatching_Policy_Sloc /= System_Location then
25399 Task_Dispatching_Policy_Sloc := Loc;
25408 -- pragma Task_Info (EXPRESSION);
25410 when Pragma_Task_Info => Task_Info : declare
25411 P : constant Node_Id := Parent (N);
25417 if Warn_On_Obsolescent_Feature then
25419 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
25420 & "instead?j?", N);
25423 if Nkind (P) /= N_Task_Definition then
25424 Error_Pragma ("pragma% must appear in task definition");
25427 Check_No_Identifiers;
25428 Check_Arg_Count (1);
25430 Analyze_And_Resolve
25431 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
25433 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
25437 Ent := Defining_Identifier (Parent (P));
25439 -- Check duplicate pragma before we chain the pragma in the Rep
25440 -- Item chain of Ent.
25443 (Ent, Name_Task_Info, Check_Parents => False)
25445 Error_Pragma ("duplicate pragma% not allowed");
25448 Record_Rep_Item (Ent, N);
25455 -- pragma Task_Name (string_EXPRESSION);
25457 when Pragma_Task_Name => Task_Name : declare
25458 P : constant Node_Id := Parent (N);
25463 Check_No_Identifiers;
25464 Check_Arg_Count (1);
25466 Arg := Get_Pragma_Arg (Arg1);
25468 -- The expression is used in the call to Create_Task, and must be
25469 -- expanded there, not in the context of the current spec. It must
25470 -- however be analyzed to capture global references, in case it
25471 -- appears in a generic context.
25473 Preanalyze_And_Resolve (Arg, Standard_String);
25475 if Nkind (P) /= N_Task_Definition then
25479 Ent := Defining_Identifier (Parent (P));
25481 -- Check duplicate pragma before we chain the pragma in the Rep
25482 -- Item chain of Ent.
25485 (Ent, Name_Task_Name, Check_Parents => False)
25487 Error_Pragma ("duplicate pragma% not allowed");
25490 Record_Rep_Item (Ent, N);
25497 -- pragma Task_Storage (
25498 -- [Task_Type =>] LOCAL_NAME,
25499 -- [Top_Guard =>] static_integer_EXPRESSION);
25501 when Pragma_Task_Storage => Task_Storage : declare
25502 Args : Args_List (1 .. 2);
25503 Names : constant Name_List (1 .. 2) := (
25507 Task_Type : Node_Id renames Args (1);
25508 Top_Guard : Node_Id renames Args (2);
25514 Gather_Associations (Names, Args);
25516 if No (Task_Type) then
25518 ("missing task_type argument for pragma%");
25521 Check_Arg_Is_Local_Name (Task_Type);
25523 Ent := Entity (Task_Type);
25525 if not Is_Task_Type (Ent) then
25527 ("argument for pragma% must be task type", Task_Type);
25530 if No (Top_Guard) then
25532 ("pragma% takes two arguments", Task_Type);
25534 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
25537 Check_First_Subtype (Task_Type);
25539 if Rep_Item_Too_Late (Ent, N) then
25548 -- pragma Test_Case
25549 -- ([Name =>] Static_String_EXPRESSION
25550 -- ,[Mode =>] MODE_TYPE
25551 -- [, Requires => Boolean_EXPRESSION]
25552 -- [, Ensures => Boolean_EXPRESSION]);
25554 -- MODE_TYPE ::= Nominal | Robustness
25556 -- Characteristics:
25558 -- * Analysis - The annotation undergoes initial checks to verify
25559 -- the legal placement and context. Secondary checks preanalyze the
25562 -- Analyze_Test_Case_In_Decl_Part
25564 -- * Expansion - None.
25566 -- * Template - The annotation utilizes the generic template of the
25567 -- related subprogram when it is:
25569 -- aspect on subprogram declaration
25571 -- The annotation must prepare its own template when it is:
25573 -- pragma on subprogram declaration
25575 -- * Globals - Capture of global references must occur after full
25578 -- * Instance - The annotation is instantiated automatically when
25579 -- the related generic subprogram is instantiated except for the
25580 -- "pragma on subprogram declaration" case. In that scenario the
25581 -- annotation must instantiate itself.
25583 when Pragma_Test_Case => Test_Case : declare
25584 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
25585 -- Ensure that the contract of subprogram Subp_Id does not contain
25586 -- another Test_Case pragma with the same Name as the current one.
25588 -------------------------
25589 -- Check_Distinct_Name --
25590 -------------------------
25592 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
25593 Items : constant Node_Id := Contract (Subp_Id);
25594 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
25598 -- Inspect all Test_Case pragma of the related subprogram
25599 -- looking for one with a duplicate "Name" argument.
25601 if Present (Items) then
25602 Prag := Contract_Test_Cases (Items);
25603 while Present (Prag) loop
25604 if Pragma_Name (Prag) = Name_Test_Case
25606 and then String_Equal
25607 (Name, Get_Name_From_CTC_Pragma (Prag))
25609 Error_Msg_Sloc := Sloc (Prag);
25610 Error_Pragma ("name for pragma % is already used #");
25613 Prag := Next_Pragma (Prag);
25616 end Check_Distinct_Name;
25620 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
25623 Subp_Decl : Node_Id;
25624 Subp_Id : Entity_Id;
25626 -- Start of processing for Test_Case
25630 Check_At_Least_N_Arguments (2);
25631 Check_At_Most_N_Arguments (4);
25633 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
25637 Check_Optional_Identifier (Arg1, Name_Name);
25638 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
25642 Check_Optional_Identifier (Arg2, Name_Mode);
25643 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
25645 -- Arguments "Requires" and "Ensures"
25647 if Present (Arg3) then
25648 if Present (Arg4) then
25649 Check_Identifier (Arg3, Name_Requires);
25650 Check_Identifier (Arg4, Name_Ensures);
25652 Check_Identifier_Is_One_Of
25653 (Arg3, Name_Requires, Name_Ensures);
25657 -- Pragma Test_Case must be associated with a subprogram declared
25658 -- in a library-level package. First determine whether the current
25659 -- compilation unit is a legal context.
25661 if Nkind (Pack_Decl) in N_Package_Declaration
25662 | N_Generic_Package_Declaration
25666 -- Otherwise the placement is illegal
25670 ("pragma % must be specified within a package declaration");
25673 Subp_Decl := Find_Related_Declaration_Or_Body (N);
25675 -- Find the enclosing context
25677 Context := Parent (Subp_Decl);
25679 if Present (Context) then
25680 Context := Parent (Context);
25683 -- Verify the placement of the pragma
25685 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
25687 ("pragma % cannot be applied to abstract subprogram");
25689 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
25690 Error_Pragma ("pragma % cannot be applied to entry");
25692 -- The context is a [generic] subprogram declared at the top level
25693 -- of the [generic] package unit.
25695 elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
25696 | N_Subprogram_Declaration
25697 and then Present (Context)
25698 and then Nkind (Context) in N_Generic_Package_Declaration
25699 | N_Package_Declaration
25703 -- Otherwise the placement is illegal
25707 ("pragma % must be applied to a library-level subprogram "
25711 Subp_Id := Defining_Entity (Subp_Decl);
25713 -- A pragma that applies to a Ghost entity becomes Ghost for the
25714 -- purposes of legality checks and removal of ignored Ghost code.
25716 Mark_Ghost_Pragma (N, Subp_Id);
25718 -- Chain the pragma on the contract for further processing by
25719 -- Analyze_Test_Case_In_Decl_Part.
25721 Add_Contract_Item (N, Subp_Id);
25723 -- Preanalyze the original aspect argument "Name" for a generic
25724 -- subprogram to properly capture global references.
25726 if Is_Generic_Subprogram (Subp_Id) then
25727 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
25729 if Present (Asp_Arg) then
25731 -- The argument appears with an identifier in association
25734 if Nkind (Asp_Arg) = N_Component_Association then
25735 Asp_Arg := Expression (Asp_Arg);
25738 Check_Expr_Is_OK_Static_Expression
25739 (Asp_Arg, Standard_String);
25743 -- Ensure that the all Test_Case pragmas of the related subprogram
25744 -- have distinct names.
25746 Check_Distinct_Name (Subp_Id);
25748 -- Fully analyze the pragma when it appears inside an entry
25749 -- or subprogram body because it cannot benefit from forward
25752 if Nkind (Subp_Decl) in N_Entry_Body
25753 | N_Subprogram_Body
25754 | N_Subprogram_Body_Stub
25756 -- The legality checks of pragma Test_Case are affected by the
25757 -- SPARK mode in effect and the volatility of the context.
25758 -- Analyze all pragmas in a specific order.
25760 Analyze_If_Present (Pragma_SPARK_Mode);
25761 Analyze_If_Present (Pragma_Volatile_Function);
25762 Analyze_Test_Case_In_Decl_Part (N);
25766 --------------------------
25767 -- Thread_Local_Storage --
25768 --------------------------
25770 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
25772 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
25778 Check_Arg_Count (1);
25779 Check_Optional_Identifier (Arg1, Name_Entity);
25780 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25782 Id := Get_Pragma_Arg (Arg1);
25784 if not Is_Entity_Name (Id)
25785 or else Ekind (Entity (Id)) /= E_Variable
25787 Error_Pragma_Arg ("local variable name required", Arg1);
25792 -- A pragma that applies to a Ghost entity becomes Ghost for the
25793 -- purposes of legality checks and removal of ignored Ghost code.
25795 Mark_Ghost_Pragma (N, E);
25797 if Rep_Item_Too_Early (E, N)
25799 Rep_Item_Too_Late (E, N)
25804 Set_Has_Pragma_Thread_Local_Storage (E);
25805 Set_Has_Gigi_Rep_Item (E);
25806 end Thread_Local_Storage;
25812 -- pragma Time_Slice (static_duration_EXPRESSION);
25814 when Pragma_Time_Slice => Time_Slice : declare
25820 Check_Arg_Count (1);
25821 Check_No_Identifiers;
25822 Check_In_Main_Program;
25823 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
25825 if not Error_Posted (Arg1) then
25827 while Present (Nod) loop
25828 if Nkind (Nod) = N_Pragma
25829 and then Pragma_Name (Nod) = Name_Time_Slice
25831 Error_Msg_Name_1 := Pname;
25832 Error_Msg_N ("duplicate pragma% not permitted", Nod);
25839 -- Process only if in main unit
25841 if Get_Source_Unit (Loc) = Main_Unit then
25842 Opt.Time_Slice_Set := True;
25843 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
25845 if Val <= Ureal_0 then
25846 Opt.Time_Slice_Value := 0;
25848 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
25849 Opt.Time_Slice_Value := 1_000_000_000;
25852 Opt.Time_Slice_Value :=
25853 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
25862 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
25864 -- TITLING_OPTION ::=
25865 -- [Title =>] STRING_LITERAL
25866 -- | [Subtitle =>] STRING_LITERAL
25868 when Pragma_Title => Title : declare
25869 Args : Args_List (1 .. 2);
25870 Names : constant Name_List (1 .. 2) := (
25876 Gather_Associations (Names, Args);
25879 for J in 1 .. 2 loop
25880 if Present (Args (J)) then
25881 Check_Arg_Is_OK_Static_Expression
25882 (Args (J), Standard_String);
25887 ----------------------------
25888 -- Type_Invariant[_Class] --
25889 ----------------------------
25891 -- pragma Type_Invariant[_Class]
25892 -- ([Entity =>] type_LOCAL_NAME,
25893 -- [Check =>] EXPRESSION);
25895 when Pragma_Type_Invariant
25896 | Pragma_Type_Invariant_Class
25898 Type_Invariant : declare
25899 I_Pragma : Node_Id;
25902 Check_Arg_Count (2);
25904 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
25905 -- setting Class_Present for the Type_Invariant_Class case.
25907 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
25908 I_Pragma := New_Copy (N);
25909 Set_Pragma_Identifier
25910 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
25911 Rewrite (N, I_Pragma);
25912 Set_Analyzed (N, False);
25914 end Type_Invariant;
25916 ---------------------
25917 -- Unchecked_Union --
25918 ---------------------
25920 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
25922 when Pragma_Unchecked_Union => Unchecked_Union : declare
25923 Assoc : constant Node_Id := Arg1;
25924 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
25934 Check_No_Identifiers;
25935 Check_Arg_Count (1);
25936 Check_Arg_Is_Local_Name (Arg1);
25938 Find_Type (Type_Id);
25940 Typ := Entity (Type_Id);
25942 -- A pragma that applies to a Ghost entity becomes Ghost for the
25943 -- purposes of legality checks and removal of ignored Ghost code.
25945 Mark_Ghost_Pragma (N, Typ);
25948 or else Rep_Item_Too_Early (Typ, N)
25952 Typ := Underlying_Type (Typ);
25955 if Rep_Item_Too_Late (Typ, N) then
25959 Check_First_Subtype (Arg1);
25961 -- Note remaining cases are references to a type in the current
25962 -- declarative part. If we find an error, we post the error on
25963 -- the relevant type declaration at an appropriate point.
25965 if not Is_Record_Type (Typ) then
25966 Error_Msg_N ("unchecked union must be record type", Typ);
25969 elsif Is_Tagged_Type (Typ) then
25970 Error_Msg_N ("unchecked union must not be tagged", Typ);
25973 elsif not Has_Discriminants (Typ) then
25975 ("unchecked union must have one discriminant", Typ);
25978 -- Note: in previous versions of GNAT we used to check for limited
25979 -- types and give an error, but in fact the standard does allow
25980 -- Unchecked_Union on limited types, so this check was removed.
25982 -- Similarly, GNAT used to require that all discriminants have
25983 -- default values, but this is not mandated by the RM.
25985 -- Proceed with basic error checks completed
25988 Tdef := Type_Definition (Declaration_Node (Typ));
25989 Clist := Component_List (Tdef);
25991 -- Check presence of component list and variant part
25993 if No (Clist) or else No (Variant_Part (Clist)) then
25995 ("unchecked union must have variant part", Tdef);
25999 -- Check components
26001 Comp := First_Non_Pragma (Component_Items (Clist));
26002 while Present (Comp) loop
26003 Check_Component (Comp, Typ);
26004 Next_Non_Pragma (Comp);
26007 -- Check variant part
26009 Vpart := Variant_Part (Clist);
26011 Variant := First_Non_Pragma (Variants (Vpart));
26012 while Present (Variant) loop
26013 Check_Variant (Variant, Typ);
26014 Next_Non_Pragma (Variant);
26018 Set_Is_Unchecked_Union (Typ);
26019 Set_Convention (Typ, Convention_C);
26020 Set_Has_Unchecked_Union (Base_Type (Typ));
26021 Set_Is_Unchecked_Union (Base_Type (Typ));
26022 end Unchecked_Union;
26024 ----------------------------
26025 -- Unevaluated_Use_Of_Old --
26026 ----------------------------
26028 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
26030 when Pragma_Unevaluated_Use_Of_Old =>
26032 Check_Arg_Count (1);
26033 Check_No_Identifiers;
26034 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
26036 -- Suppress/Unsuppress can appear as a configuration pragma, or in
26037 -- a declarative part or a package spec.
26039 if not Is_Configuration_Pragma then
26040 Check_Is_In_Decl_Part_Or_Package_Spec;
26043 -- Store proper setting of Uneval_Old
26045 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
26046 Uneval_Old := Fold_Upper (Name_Buffer (1));
26048 ------------------------
26049 -- Unimplemented_Unit --
26050 ------------------------
26052 -- pragma Unimplemented_Unit;
26054 -- Note: this only gives an error if we are generating code, or if
26055 -- we are in a generic library unit (where the pragma appears in the
26056 -- body, not in the spec).
26058 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
26059 Cunitent : constant Entity_Id :=
26060 Cunit_Entity (Get_Source_Unit (Loc));
26064 Check_Arg_Count (0);
26066 if Operating_Mode = Generate_Code
26067 or else Is_Generic_Unit (Cunitent)
26069 Get_Name_String (Chars (Cunitent));
26070 Set_Casing (Mixed_Case);
26071 Write_Str (Name_Buffer (1 .. Name_Len));
26072 Write_Str (" is not supported in this configuration");
26074 raise Unrecoverable_Error;
26076 end Unimplemented_Unit;
26078 ------------------------
26079 -- Universal_Aliasing --
26080 ------------------------
26082 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
26084 when Pragma_Universal_Aliasing => Universal_Alias : declare
26090 Check_Arg_Count (1);
26091 Check_Optional_Identifier (Arg2, Name_Entity);
26092 Check_Arg_Is_Local_Name (Arg1);
26093 E_Id := Get_Pragma_Arg (Arg1);
26095 if Etype (E_Id) = Any_Type then
26099 E := Entity (E_Id);
26101 if not Is_Type (E) then
26102 Error_Pragma_Arg ("pragma% requires type", Arg1);
26105 -- A pragma that applies to a Ghost entity becomes Ghost for the
26106 -- purposes of legality checks and removal of ignored Ghost code.
26108 Mark_Ghost_Pragma (N, E);
26109 Set_Universal_Aliasing (Base_Type (E));
26110 Record_Rep_Item (E, N);
26111 end Universal_Alias;
26117 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
26119 when Pragma_Unmodified =>
26120 Analyze_Unmodified_Or_Unused;
26126 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
26128 -- or when used in a context clause:
26130 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
26132 when Pragma_Unreferenced =>
26133 Analyze_Unreferenced_Or_Unused;
26135 --------------------------
26136 -- Unreferenced_Objects --
26137 --------------------------
26139 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
26141 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
26143 Arg_Expr : Node_Id;
26144 Arg_Id : Entity_Id;
26146 Ghost_Error_Posted : Boolean := False;
26147 -- Flag set when an error concerning the illegal mix of Ghost and
26148 -- non-Ghost types is emitted.
26150 Ghost_Id : Entity_Id := Empty;
26151 -- The entity of the first Ghost type encountered while processing
26152 -- the arguments of the pragma.
26156 Check_At_Least_N_Arguments (1);
26159 while Present (Arg) loop
26160 Check_No_Identifier (Arg);
26161 Check_Arg_Is_Local_Name (Arg);
26162 Arg_Expr := Get_Pragma_Arg (Arg);
26164 if Is_Entity_Name (Arg_Expr) then
26165 Arg_Id := Entity (Arg_Expr);
26167 if Is_Type (Arg_Id) then
26168 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
26170 -- A pragma that applies to a Ghost entity becomes Ghost
26171 -- for the purposes of legality checks and removal of
26172 -- ignored Ghost code.
26174 Mark_Ghost_Pragma (N, Arg_Id);
26176 -- Capture the entity of the first Ghost type being
26177 -- processed for error detection purposes.
26179 if Is_Ghost_Entity (Arg_Id) then
26180 if No (Ghost_Id) then
26181 Ghost_Id := Arg_Id;
26184 -- Otherwise the type is non-Ghost. It is illegal to mix
26185 -- references to Ghost and non-Ghost entities
26188 elsif Present (Ghost_Id)
26189 and then not Ghost_Error_Posted
26191 Ghost_Error_Posted := True;
26193 Error_Msg_Name_1 := Pname;
26195 ("pragma % cannot mention ghost and non-ghost types",
26198 Error_Msg_Sloc := Sloc (Ghost_Id);
26199 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
26201 Error_Msg_Sloc := Sloc (Arg_Id);
26202 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
26206 ("argument for pragma% must be type or subtype", Arg);
26210 ("argument for pragma% must be type or subtype", Arg);
26215 end Unreferenced_Objects;
26217 ------------------------------
26218 -- Unreserve_All_Interrupts --
26219 ------------------------------
26221 -- pragma Unreserve_All_Interrupts;
26223 when Pragma_Unreserve_All_Interrupts =>
26225 Check_Arg_Count (0);
26227 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
26228 Unreserve_All_Interrupts := True;
26235 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
26237 when Pragma_Unsuppress =>
26239 Process_Suppress_Unsuppress (Suppress_Case => False);
26245 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
26247 when Pragma_Unused =>
26248 Analyze_Unmodified_Or_Unused (Is_Unused => True);
26249 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
26251 -------------------
26252 -- Use_VADS_Size --
26253 -------------------
26255 -- pragma Use_VADS_Size;
26257 when Pragma_Use_VADS_Size =>
26259 Check_Arg_Count (0);
26260 Check_Valid_Configuration_Pragma;
26261 Use_VADS_Size := True;
26263 ----------------------------
26264 -- User_Aspect_Definition --
26265 ----------------------------
26267 -- pragma User_Aspect_Definition
26268 -- (Identifier, {, Identifier [(Identifier {, Identifier})]});
26270 when Pragma_User_Aspect_Definition =>
26272 Check_Valid_Configuration_Pragma;
26275 First (Pragma_Argument_Associations (N));
26276 User_Aspect_Name : constant Name_Id := Chars (Expression (Arg));
26278 Aspect : Aspect_Id;
26280 if Get_Aspect_Id (User_Aspect_Name) /= No_Aspect then
26282 ("User-defined aspect name for pragma% is the name " &
26283 "of an existing aspect", Arg);
26286 Next (Arg); -- skip first argument, the name of the aspect
26288 while Present (Arg) loop
26289 Expr := Expression (Arg);
26290 case Nkind (Expr) is
26291 when N_Identifier =>
26292 Aspect := Get_Aspect_Id (Chars (Expr));
26293 if Aspect in Boolean_Aspects
26294 and not Is_Representation_Aspect (Aspect)
26296 -- If we allowed representation aspects such as
26297 -- Pack here, then User_Aspect itself would need
26298 -- to be a representation aspect.
26301 elsif Aspect = No_Aspect and then
26302 Present (User_Aspect_Support.Registered_UAD_Pragma
26303 (User_Aspect_Name))
26308 ("unparameterized argument for pragma% must be " &
26309 "either a Boolean-valued non-representation " &
26310 "aspect or user-defined", Arg);
26312 when N_Indexed_Component =>
26313 Aspect := Get_Aspect_Id (Chars (Prefix (Expr)));
26315 -- Aspect should be an aspect that takes
26316 -- identifier arguments that do not refer to
26317 -- declarations, but rather to undeclared entities
26318 -- such as GNATProve or No_Secondary_Stack for
26319 -- which the notion of visibility does not apply.
26322 when Aspect_Annotate =>
26323 if List_Length (Expressions (Expr)) /= 2 then
26325 ("Annotate argument for pragma% takes " &
26326 "two parameters", Arg);
26329 when Aspect_Local_Restrictions =>
26334 ("parameterized argument for pragma% must be " &
26335 "Annotate or Local_Restrictions aspect", Arg);
26338 raise Program_Error; -- parsing error
26344 Registered : constant Node_Id :=
26345 User_Aspect_Support.Registered_UAD_Pragma
26346 (User_Aspect_Name);
26348 -- Given two User_Aspect_Definition pragmas with
26349 -- matching names for the first argument, check that
26350 -- subsequent arguments also match; complain if they differ.
26351 procedure Check_UAD_Conformance
26352 (New_Pragma, Old_Pragma : Node_Id);
26354 ---------------------------
26355 -- Check_UAD_Conformance --
26356 ---------------------------
26358 procedure Check_UAD_Conformance
26359 (New_Pragma, Old_Pragma : Node_Id)
26361 Old_Arg : Node_Id :=
26362 First (Pragma_Argument_Associations (Old_Pragma));
26363 New_Arg : Node_Id :=
26364 First (Pragma_Argument_Associations (New_Pragma));
26365 OK : Boolean := True;
26367 function Same_Chars (Id1, Id2 : Node_Id) return Boolean
26368 is (Chars (Id1) = Chars (Id2));
26370 function Same_Identifier_List (Id1, Id2 : Node_Id)
26372 is (if No (Id1) and No (Id2) then True
26373 elsif No (Id1) or No (Id2) then False
26374 else (Same_Chars (Id1, Id2) and then
26375 Same_Identifier_List (Next (Id1), Next (Id2))));
26377 -- We could skip the first argument pair since those
26378 -- are already known to match (or we wouldn't be
26379 -- calling this procedure).
26381 while Present (Old_Arg) or Present (New_Arg) loop
26382 if Present (Old_Arg) /= Present (New_Arg) then
26384 elsif Nkind (Expression (Old_Arg)) /=
26385 Nkind (Expression (New_Arg))
26389 case Nkind (Expression (Old_Arg)) is
26390 when N_Identifier =>
26391 OK := Same_Chars (Expression (Old_Arg),
26392 Expression (New_Arg));
26394 when N_Indexed_Component =>
26396 (Prefix (Expression (Old_Arg)),
26397 Prefix (Expression (New_Arg)))
26398 and then Same_Identifier_List
26399 (First (Expressions
26400 (Expression (Old_Arg))),
26402 (Expression (New_Arg))));
26406 pragma Assert (False);
26411 Error_Msg_Sloc := Sloc (Old_Pragma);
26413 ("Nonconforming definitions for user-defined " &
26414 "aspect #", New_Pragma);
26421 end Check_UAD_Conformance;
26423 if Present (Registered) then
26424 -- If we have already seen a UAD pragma with this name,
26425 -- then check that the two pragmas conform (which means
26426 -- that the new pragma is redundant and can be ignored).
26428 -- ??? We could also perform a similar bind-time check,
26429 -- since it is possible that an incompatible pair of
26430 -- UAD pragmas might not be detected by this check.
26431 -- This could arise if no unit's compilation closure
26432 -- includes both of the two. The major downside of
26433 -- failing to detect this case is possible confusion
26434 -- for human readers.
26436 Check_UAD_Conformance (New_Pragma => N,
26437 Old_Pragma => Registered);
26439 User_Aspect_Support.Register_UAD_Pragma (N);
26444 ---------------------
26445 -- Validity_Checks --
26446 ---------------------
26448 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
26450 when Pragma_Validity_Checks => Validity_Checks : declare
26451 A : constant Node_Id := Get_Pragma_Arg (Arg1);
26457 Check_Arg_Count (1);
26458 Check_No_Identifiers;
26460 -- Pragma always active unless in CodePeer or GNATprove modes,
26461 -- which use a fixed configuration of validity checks.
26463 if not (CodePeer_Mode or GNATprove_Mode) then
26464 if Nkind (A) = N_String_Literal then
26468 Slen : constant Natural := Natural (String_Length (S));
26469 Options : String (1 .. Slen);
26473 -- Couldn't we use a for loop here over Options'Range???
26477 C := Get_String_Char (S, Pos (J));
26479 -- This is a weird test, it skips setting validity
26480 -- checks entirely if any element of S is out of
26481 -- range of Character, what is that about ???
26483 exit when not In_Character_Range (C);
26484 Options (J) := Get_Character (C);
26487 Set_Validity_Check_Options (Options);
26495 elsif Nkind (A) = N_Identifier then
26496 if Chars (A) = Name_All_Checks then
26497 Set_Validity_Check_Options ("a");
26498 elsif Chars (A) = Name_On then
26499 Validity_Checks_On := True;
26500 elsif Chars (A) = Name_Off then
26501 Validity_Checks_On := False;
26505 end Validity_Checks;
26511 -- pragma Volatile (LOCAL_NAME);
26513 when Pragma_Volatile =>
26514 Process_Atomic_Independent_Shared_Volatile;
26516 -------------------------
26517 -- Volatile_Components --
26518 -------------------------
26520 -- pragma Volatile_Components (array_LOCAL_NAME);
26522 -- Volatile is handled by the same circuit as Atomic_Components
26524 --------------------------
26525 -- Volatile_Full_Access --
26526 --------------------------
26528 -- pragma Volatile_Full_Access (LOCAL_NAME);
26530 when Pragma_Volatile_Full_Access =>
26532 Process_Atomic_Independent_Shared_Volatile;
26534 -----------------------
26535 -- Volatile_Function --
26536 -----------------------
26538 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
26540 when Pragma_Volatile_Function => Volatile_Function : declare
26541 Over_Id : Entity_Id;
26542 Spec_Id : Entity_Id;
26543 Subp_Decl : Node_Id;
26547 Check_No_Identifiers;
26548 Check_At_Most_N_Arguments (1);
26551 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
26553 -- Generic subprogram
26555 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
26558 -- Body acts as spec
26560 elsif Nkind (Subp_Decl) = N_Subprogram_Body
26561 and then No (Corresponding_Spec (Subp_Decl))
26565 -- Body stub acts as spec
26567 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
26568 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
26574 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
26581 Spec_Id := Unique_Defining_Entity (Subp_Decl);
26583 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
26587 -- A pragma that applies to a Ghost entity becomes Ghost for the
26588 -- purposes of legality checks and removal of ignored Ghost code.
26590 Mark_Ghost_Pragma (N, Spec_Id);
26592 -- Chain the pragma on the contract for completeness
26594 Add_Contract_Item (N, Spec_Id);
26596 -- The legality checks of pragma Volatile_Function are affected by
26597 -- the SPARK mode in effect. Analyze all pragmas in a specific
26600 Analyze_If_Present (Pragma_SPARK_Mode);
26602 -- A volatile function cannot override a non-volatile function
26603 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
26604 -- in New_Overloaded_Entity, however at that point the pragma has
26605 -- not been processed yet.
26607 Over_Id := Overridden_Operation (Spec_Id);
26609 if Present (Over_Id)
26610 and then not Is_Volatile_Function (Over_Id)
26613 ("incompatible volatile function values in effect", Spec_Id);
26615 Error_Msg_Sloc := Sloc (Over_Id);
26617 ("\& declared # with Volatile_Function value False",
26620 Error_Msg_Sloc := Sloc (Spec_Id);
26622 ("\overridden # with Volatile_Function value True",
26626 -- Analyze the Boolean expression (if any)
26628 if Present (Arg1) then
26629 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
26631 end Volatile_Function;
26633 ----------------------
26634 -- Warning_As_Error --
26635 ----------------------
26637 -- pragma Warning_As_Error (static_string_EXPRESSION);
26639 when Pragma_Warning_As_Error =>
26641 Check_Arg_Count (1);
26642 Check_No_Identifiers;
26643 Check_Valid_Configuration_Pragma;
26645 if not Is_Static_String_Expression (Arg1) then
26647 ("argument of pragma% must be static string expression",
26650 -- OK static string expression
26653 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
26654 Warnings_As_Errors (Warnings_As_Errors_Count) :=
26655 new String'(Acquire_Warning_Match_String
26656 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
26663 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
26665 -- DETAILS ::= On | Off
26666 -- DETAILS ::= On | Off, local_NAME
26667 -- DETAILS ::= static_string_EXPRESSION
26668 -- DETAILS ::= On | Off, static_string_EXPRESSION
26670 -- TOOL_NAME ::= GNAT | GNATprove
26672 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
26674 -- Note: If the first argument matches an allowed tool name, it is
26675 -- always considered to be a tool name, even if there is a string
26676 -- variable of that name.
26678 -- Note if the second argument of DETAILS is a local_NAME then the
26679 -- second form is always understood. If the intention is to use
26680 -- the fourth form, then you can write NAME & "" to force the
26681 -- intepretation as a static_string_EXPRESSION.
26683 when Pragma_Warnings => Warnings : declare
26684 Reason : String_Id;
26688 Check_At_Least_N_Arguments (1);
26690 -- See if last argument is labeled Reason. If so, make sure we
26691 -- have a string literal or a concatenation of string literals,
26692 -- and acquire the REASON string. Then remove the REASON argument
26693 -- by decreasing Num_Args by one; Remaining processing looks only
26694 -- at first Num_Args arguments).
26697 Last_Arg : constant Node_Id :=
26698 Last (Pragma_Argument_Associations (N));
26701 if Nkind (Last_Arg) = N_Pragma_Argument_Association
26702 and then Chars (Last_Arg) = Name_Reason
26705 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
26706 Reason := End_String;
26707 Arg_Count := Arg_Count - 1;
26709 -- No REASON string, set null string as reason
26712 Reason := Null_String_Id;
26716 -- Now proceed with REASON taken care of and eliminated
26718 Check_No_Identifiers;
26720 -- If debug flag -gnatd.i is set, pragma is ignored
26722 if Debug_Flag_Dot_I then
26726 -- Process various forms of the pragma
26729 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
26730 Shifted_Args : List_Id;
26733 -- See if first argument is a tool name, currently either
26734 -- GNAT or GNATprove. If so, either ignore the pragma if the
26735 -- tool used does not match, or continue as if no tool name
26736 -- was given otherwise, by shifting the arguments.
26738 if Nkind (Argx) = N_Identifier
26739 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
26741 if Chars (Argx) = Name_Gnat then
26742 if CodePeer_Mode or GNATprove_Mode then
26743 Rewrite (N, Make_Null_Statement (Loc));
26748 elsif Chars (Argx) = Name_Gnatprove then
26749 if not GNATprove_Mode then
26750 Rewrite (N, Make_Null_Statement (Loc));
26755 raise Program_Error;
26758 -- At this point, the pragma Warnings applies to the tool,
26759 -- so continue with shifted arguments.
26761 Arg_Count := Arg_Count - 1;
26763 if Arg_Count = 1 then
26764 Shifted_Args := New_List (New_Copy (Arg2));
26765 elsif Arg_Count = 2 then
26766 Shifted_Args := New_List (New_Copy (Arg2),
26768 elsif Arg_Count = 3 then
26769 Shifted_Args := New_List (New_Copy (Arg2),
26773 raise Program_Error;
26778 Chars => Name_Warnings,
26779 Pragma_Argument_Associations => Shifted_Args));
26784 -- One argument case
26786 if Arg_Count = 1 then
26788 -- On/Off one argument case was processed by parser
26790 if Nkind (Argx) = N_Identifier
26791 and then Chars (Argx) in Name_On | Name_Off
26795 -- One argument case must be ON/OFF or static string expr
26797 elsif not Is_Static_String_Expression (Arg1) then
26799 ("argument of pragma% must be On/Off or static string "
26800 & "expression", Arg1);
26802 -- Use of pragma Warnings to set warning switches is
26803 -- ignored in GNATprove mode, as these switches apply to
26804 -- the compiler only.
26806 elsif GNATprove_Mode then
26809 -- One argument string expression case
26813 Lit : constant Node_Id := Expr_Value_S (Argx);
26814 Str : constant String_Id := Strval (Lit);
26815 Len : constant Nat := String_Length (Str);
26823 while J <= Len loop
26824 C := Get_String_Char (Str, J);
26825 OK := In_Character_Range (C);
26828 Chr := Get_Character (C);
26830 -- Dash case: only -Wxxx is accepted
26837 C := Get_String_Char (Str, J);
26838 Chr := Get_Character (C);
26839 exit when Chr = 'W';
26844 elsif J < Len and then Chr = '.' then
26846 C := Get_String_Char (Str, J);
26847 Chr := Get_Character (C);
26849 if not Set_Warning_Switch ('.', Chr) then
26851 ("invalid warning switch character "
26852 & '.' & Chr, Arg1);
26858 OK := Set_Warning_Switch (Plain, Chr);
26863 ("invalid warning switch character " & Chr,
26869 ("invalid wide character in warning switch ",
26878 -- Two or more arguments (must be two)
26881 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
26882 Check_Arg_Count (2);
26890 E_Id := Get_Pragma_Arg (Arg2);
26893 -- In the expansion of an inlined body, a reference to
26894 -- the formal may be wrapped in a conversion if the
26895 -- actual is a conversion. Retrieve the real entity name.
26897 if (In_Instance_Body or In_Inlined_Body)
26898 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
26900 E_Id := Expression (E_Id);
26903 -- Entity name case
26905 if Is_Entity_Name (E_Id) then
26906 E := Entity (E_Id);
26913 (E, (Chars (Get_Pragma_Arg (Arg1)) =
26916 -- Suppress elaboration warnings if the entity
26917 -- denotes an elaboration target.
26919 if Is_Elaboration_Target (E) then
26920 Set_Is_Elaboration_Warnings_OK_Id (E, False);
26923 -- For OFF case, make entry in warnings off
26924 -- pragma table for later processing. But we do
26925 -- not do that within an instance, since these
26926 -- warnings are about what is needed in the
26927 -- template, not an instance of it.
26929 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
26930 and then Warn_On_Warnings_Off
26931 and then not In_Instance
26933 Warnings_Off_Pragmas.Append ((N, E, Reason));
26936 if Is_Enumeration_Type (E) then
26940 Lit := First_Literal (E);
26941 while Present (Lit) loop
26942 Set_Warnings_Off (Lit);
26943 Next_Literal (Lit);
26948 exit when No (Homonym (E));
26953 -- Error if not entity or static string expression case
26955 elsif not Is_Static_String_Expression (Arg2) then
26957 ("second argument of pragma% must be entity name "
26958 & "or static string expression", Arg2);
26960 -- Static string expression case
26963 -- Note on configuration pragma case: If this is a
26964 -- configuration pragma, then for an OFF pragma, we
26965 -- just set Config True in the call, which is all
26966 -- that needs to be done. For the case of ON, this
26967 -- is normally an error, unless it is canceling the
26968 -- effect of a previous OFF pragma in the same file.
26969 -- In any other case, an error will be signalled (ON
26970 -- with no matching OFF).
26972 -- Note: We set Used if we are inside a generic to
26973 -- disable the test that the non-config case actually
26974 -- cancels a warning. That's because we can't be sure
26975 -- there isn't an instantiation in some other unit
26976 -- where a warning is suppressed.
26978 -- We could do a little better here by checking if the
26979 -- generic unit we are inside is public, but for now
26980 -- we don't bother with that refinement.
26983 Message : constant String :=
26984 Acquire_Warning_Match_String
26985 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
26987 if Chars (Argx) = Name_Off then
26988 Set_Specific_Warning_Off
26989 (Loc, Message, Reason,
26990 Config => Is_Configuration_Pragma,
26991 Used => Inside_A_Generic or else In_Instance);
26993 elsif Chars (Argx) = Name_On then
26994 Set_Specific_Warning_On (Loc, Message, Err);
26998 ("??pragma Warnings On with no matching "
26999 & "Warnings Off", N);
27009 -------------------
27010 -- Weak_External --
27011 -------------------
27013 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
27015 when Pragma_Weak_External => Weak_External : declare
27020 Check_Arg_Count (1);
27021 Check_Optional_Identifier (Arg1, Name_Entity);
27022 Check_Arg_Is_Library_Level_Local_Name (Arg1);
27023 Ent := Entity (Get_Pragma_Arg (Arg1));
27025 if Rep_Item_Too_Early (Ent, N) then
27028 Ent := Underlying_Type (Ent);
27031 -- The pragma applies to entities with addresses
27033 if Is_Type (Ent) then
27034 Error_Pragma ("pragma applies to objects and subprograms");
27037 -- The only processing required is to link this item on to the
27038 -- list of rep items for the given entity. This is accomplished
27039 -- by the call to Rep_Item_Too_Late (when no error is detected
27040 -- and False is returned).
27042 if Rep_Item_Too_Late (Ent, N) then
27045 Set_Has_Gigi_Rep_Item (Ent);
27049 -----------------------------
27050 -- Wide_Character_Encoding --
27051 -----------------------------
27053 -- pragma Wide_Character_Encoding (IDENTIFIER);
27055 when Pragma_Wide_Character_Encoding =>
27058 -- Nothing to do, handled in parser. Note that we do not enforce
27059 -- configuration pragma placement, this pragma can appear at any
27060 -- place in the source, allowing mixed encodings within a single
27065 --------------------
27066 -- Unknown_Pragma --
27067 --------------------
27069 -- Should be impossible, since the case of an unknown pragma is
27070 -- separately processed before the case statement is entered.
27072 when Unknown_Pragma =>
27073 raise Program_Error;
27076 -- AI05-0144: detect dangerous order dependence. Disabled for now,
27077 -- until AI is formally approved.
27079 -- Check_Order_Dependence;
27082 when Pragma_Exit => null;
27083 end Analyze_Pragma;
27085 --------------------------------
27086 -- Analyze_Pragmas_If_Present --
27087 --------------------------------
27089 procedure Analyze_Pragmas_If_Present (Decl : Node_Id; Id : Pragma_Id) is
27092 if Nkind (Parent (Decl)) = N_Compilation_Unit then
27093 Prag := First (Pragmas_After (Aux_Decls_Node (Parent (Decl))));
27095 pragma Assert (Is_List_Member (Decl));
27096 Prag := Next (Decl);
27099 if Present (Prag) then
27100 Analyze_If_Present_Internal (Prag, Id, Included => True);
27102 end Analyze_Pragmas_If_Present;
27104 ---------------------------------------------
27105 -- Analyze_Pre_Post_Condition_In_Decl_Part --
27106 ---------------------------------------------
27108 -- WARNING: This routine manages Ghost regions. Return statements must be
27109 -- replaced by gotos which jump to the end of the routine and restore the
27112 procedure Analyze_Pre_Post_Condition_In_Decl_Part
27114 Freeze_Id : Entity_Id := Empty)
27116 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27117 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
27119 Disp_Typ : Entity_Id;
27120 -- The dispatching type of the subprogram subject to the pre- or
27123 function Check_References (Nod : Node_Id) return Traverse_Result;
27124 -- Check that expression Nod does not mention non-primitives of the
27125 -- type, global objects of the type, or other illegalities described
27126 -- and implied by AI12-0113.
27128 ----------------------
27129 -- Check_References --
27130 ----------------------
27132 function Check_References (Nod : Node_Id) return Traverse_Result is
27134 if Nkind (Nod) = N_Function_Call
27135 and then Is_Entity_Name (Name (Nod))
27138 Func : constant Entity_Id := Entity (Name (Nod));
27142 -- An operation of the type must be a primitive
27144 if No (Find_Dispatching_Type (Func)) then
27145 Form := First_Formal (Func);
27146 while Present (Form) loop
27147 if Etype (Form) = Disp_Typ then
27149 ("operation in class-wide condition must be "
27150 & "primitive of &", Nod, Disp_Typ);
27153 Next_Formal (Form);
27156 -- A return object of the type is illegal as well
27158 if Etype (Func) = Disp_Typ
27159 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
27162 ("operation in class-wide condition must be primitive "
27163 & "of &", Nod, Disp_Typ);
27168 elsif Is_Entity_Name (Nod)
27170 (Etype (Nod) = Disp_Typ
27171 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
27172 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
27175 ("object in class-wide condition must be formal of type &",
27178 elsif Nkind (Nod) = N_Explicit_Dereference
27179 and then (Etype (Nod) = Disp_Typ
27180 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
27181 and then (not Is_Entity_Name (Prefix (Nod))
27182 or else not Is_Formal (Entity (Prefix (Nod))))
27185 ("operation in class-wide condition must be primitive of &",
27190 end Check_References;
27192 procedure Check_Class_Wide_Condition is
27193 new Traverse_Proc (Check_References);
27197 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
27199 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
27200 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
27201 -- Save the Ghost-related attributes to restore on exit
27204 Restore_Scope : Boolean := False;
27206 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
27209 -- Do not analyze the pragma multiple times
27211 if Is_Analyzed_Pragma (N) then
27215 -- Set the Ghost mode in effect from the pragma. Due to the delayed
27216 -- analysis of the pragma, the Ghost mode at point of declaration and
27217 -- point of analysis may not necessarily be the same. Use the mode in
27218 -- effect at the point of declaration.
27220 Set_Ghost_Mode (N);
27222 -- Ensure that the subprogram and its formals are visible when analyzing
27223 -- the expression of the pragma.
27225 if not In_Open_Scopes (Spec_Id) then
27226 Restore_Scope := True;
27228 if Is_Generic_Subprogram (Spec_Id) then
27229 Push_Scope (Spec_Id);
27230 Install_Generic_Formals (Spec_Id);
27231 elsif Is_Access_Subprogram_Type (Spec_Id) then
27232 Push_Scope (Designated_Type (Spec_Id));
27233 Install_Formals (Designated_Type (Spec_Id));
27235 Push_Scope (Spec_Id);
27236 Install_Formals (Spec_Id);
27240 Errors := Serious_Errors_Detected;
27241 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
27243 -- Emit a clarification message when the expression contains at least
27244 -- one undefined reference, possibly due to contract freezing.
27246 if Errors /= Serious_Errors_Detected
27247 and then Present (Freeze_Id)
27248 and then Has_Undefined_Reference (Expr)
27250 Contract_Freeze_Error (Spec_Id, Freeze_Id);
27253 if Class_Present (N) then
27255 -- Verify that a class-wide condition is legal, i.e. the operation is
27256 -- a primitive of a tagged type.
27258 if not Is_Dispatching_Operation (Spec_Id) then
27259 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
27261 if From_Aspect_Specification (N) then
27263 ("aspect % can only be specified for a primitive operation "
27264 & "of a tagged type", Corresponding_Aspect (N));
27266 -- The pragma is a source construct
27270 ("pragma % can only be specified for a primitive operation "
27271 & "of a tagged type", N);
27274 -- Remaining semantic checks require a full tree traversal
27277 Disp_Typ := Find_Dispatching_Type (Spec_Id);
27278 Check_Class_Wide_Condition (Expr);
27283 if Restore_Scope then
27287 -- Currently it is not possible to inline pre/postconditions on a
27288 -- subprogram subject to pragma Inline_Always.
27290 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
27291 Set_Is_Analyzed_Pragma (N);
27293 Restore_Ghost_Region (Saved_GM, Saved_IGR);
27294 end Analyze_Pre_Post_Condition_In_Decl_Part;
27296 ------------------------------------------
27297 -- Analyze_Refined_Depends_In_Decl_Part --
27298 ------------------------------------------
27300 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
27301 procedure Check_Dependency_Clause
27302 (Spec_Id : Entity_Id;
27303 Dep_Clause : Node_Id;
27304 Dep_States : Elist_Id;
27305 Refinements : List_Id;
27306 Matched_Items : in out Elist_Id);
27307 -- Try to match a single dependency clause Dep_Clause against one or
27308 -- more refinement clauses found in list Refinements. Each successful
27309 -- match eliminates at least one refinement clause from Refinements.
27310 -- Spec_Id denotes the entity of the related subprogram. Dep_States
27311 -- denotes the entities of all abstract states which appear in pragma
27312 -- Depends. Matched_Items contains the entities of all successfully
27313 -- matched items found in pragma Depends.
27315 procedure Check_Output_States
27316 (Spec_Inputs : Elist_Id;
27317 Spec_Outputs : Elist_Id;
27318 Body_Inputs : Elist_Id;
27319 Body_Outputs : Elist_Id);
27320 -- Determine whether pragma Depends contains an output state with a
27321 -- visible refinement and if so, ensure that pragma Refined_Depends
27322 -- mentions all its constituents as outputs. Spec_Inputs and
27323 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
27324 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
27325 -- the inputs and outputs of the subprogram body synthesized from pragma
27326 -- Refined_Depends.
27328 function Collect_States (Clauses : List_Id) return Elist_Id;
27329 -- Given a normalized list of dependencies obtained from calling
27330 -- Normalize_Clauses, return a list containing the entities of all
27331 -- states appearing in dependencies. It helps in checking refinements
27332 -- involving a state and a corresponding constituent which is not a
27333 -- direct constituent of the state.
27335 procedure Normalize_Clauses (Clauses : List_Id);
27336 -- Given a list of dependence or refinement clauses Clauses, normalize
27337 -- each clause by creating multiple dependencies with exactly one input
27340 procedure Remove_Extra_Clauses
27341 (Clauses : List_Id;
27342 Matched_Items : Elist_Id);
27343 -- Given a list of refinement clauses Clauses, remove all clauses whose
27344 -- inputs and/or outputs have been previously matched. See the body for
27345 -- all special cases. Matched_Items contains the entities of all matched
27346 -- items found in pragma Depends.
27348 procedure Report_Extra_Clauses (Clauses : List_Id);
27349 -- Emit an error for each extra clause found in list Clauses
27351 -----------------------------
27352 -- Check_Dependency_Clause --
27353 -----------------------------
27355 procedure Check_Dependency_Clause
27356 (Spec_Id : Entity_Id;
27357 Dep_Clause : Node_Id;
27358 Dep_States : Elist_Id;
27359 Refinements : List_Id;
27360 Matched_Items : in out Elist_Id)
27362 Dep_Input : constant Node_Id := Expression (Dep_Clause);
27363 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
27365 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
27366 -- Determine whether dependency item Dep_Item has been matched in a
27367 -- previous clause.
27369 function Is_In_Out_State_Clause return Boolean;
27370 -- Determine whether dependence clause Dep_Clause denotes an abstract
27371 -- state that depends on itself (State => State).
27373 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
27374 -- Determine whether item Item denotes an abstract state with visible
27375 -- null refinement.
27377 procedure Match_Items
27378 (Dep_Item : Node_Id;
27379 Ref_Item : Node_Id;
27380 Matched : out Boolean);
27381 -- Try to match dependence item Dep_Item against refinement item
27382 -- Ref_Item. To match against a possible null refinement (see 2, 9),
27383 -- set Ref_Item to Empty. Flag Matched is set to True when one of
27384 -- the following conformance scenarios is in effect:
27385 -- 1) Both items denote null
27386 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
27387 -- 3) Both items denote attribute 'Result
27388 -- 4) Both items denote the same object
27389 -- 5) Both items denote the same formal parameter
27390 -- 6) Both items denote the same current instance of a type
27391 -- 7) Both items denote the same discriminant
27392 -- 8) Dep_Item is an abstract state with visible null refinement
27393 -- and Ref_Item denotes null.
27394 -- 9) Dep_Item is an abstract state with visible null refinement
27395 -- and Ref_Item is Empty (special case).
27396 -- 10) Dep_Item is an abstract state with full or partial visible
27397 -- non-null refinement and Ref_Item denotes one of its
27399 -- 11) Dep_Item is an abstract state without a full visible
27400 -- refinement and Ref_Item denotes the same state.
27401 -- When scenario 10 is in effect, the entity of the abstract state
27402 -- denoted by Dep_Item is added to list Refined_States.
27404 procedure Record_Item (Item_Id : Entity_Id);
27405 -- Store the entity of an item denoted by Item_Id in Matched_Items
27407 ------------------------
27408 -- Is_Already_Matched --
27409 ------------------------
27411 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
27412 Item_Id : Entity_Id := Empty;
27415 -- When the dependency item denotes attribute 'Result, check for
27416 -- the entity of the related subprogram.
27418 if Is_Attribute_Result (Dep_Item) then
27419 Item_Id := Spec_Id;
27421 elsif Is_Entity_Name (Dep_Item) then
27422 Item_Id := Available_View (Entity_Of (Dep_Item));
27426 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
27427 end Is_Already_Matched;
27429 ----------------------------
27430 -- Is_In_Out_State_Clause --
27431 ----------------------------
27433 function Is_In_Out_State_Clause return Boolean is
27434 Dep_Input_Id : Entity_Id;
27435 Dep_Output_Id : Entity_Id;
27438 -- Detect the following clause:
27441 if Is_Entity_Name (Dep_Input)
27442 and then Is_Entity_Name (Dep_Output)
27444 -- Handle abstract views generated for limited with clauses
27446 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
27447 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
27450 Ekind (Dep_Input_Id) = E_Abstract_State
27451 and then Dep_Input_Id = Dep_Output_Id;
27455 end Is_In_Out_State_Clause;
27457 ---------------------------
27458 -- Is_Null_Refined_State --
27459 ---------------------------
27461 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
27462 Item_Id : Entity_Id;
27465 if Is_Entity_Name (Item) then
27467 -- Handle abstract views generated for limited with clauses
27469 Item_Id := Available_View (Entity_Of (Item));
27472 Ekind (Item_Id) = E_Abstract_State
27473 and then Has_Null_Visible_Refinement (Item_Id);
27477 end Is_Null_Refined_State;
27483 procedure Match_Items
27484 (Dep_Item : Node_Id;
27485 Ref_Item : Node_Id;
27486 Matched : out Boolean)
27488 Dep_Item_Id : Entity_Id;
27489 Ref_Item_Id : Entity_Id;
27492 -- Assume that the two items do not match
27496 -- A null matches null or Empty (special case)
27498 if Nkind (Dep_Item) = N_Null
27499 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
27503 -- Attribute 'Result matches attribute 'Result
27505 elsif Is_Attribute_Result (Dep_Item)
27506 and then Is_Attribute_Result (Ref_Item)
27508 -- Put the entity of the related function on the list of
27509 -- matched items because attribute 'Result does not carry
27510 -- an entity similar to states and constituents.
27512 Record_Item (Spec_Id);
27515 -- Abstract states, current instances of concurrent types,
27516 -- discriminants, formal parameters and objects.
27518 elsif Is_Entity_Name (Dep_Item) then
27520 -- Handle abstract views generated for limited with clauses
27522 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
27524 if Ekind (Dep_Item_Id) = E_Abstract_State then
27526 -- An abstract state with visible null refinement matches
27527 -- null or Empty (special case).
27529 if Has_Null_Visible_Refinement (Dep_Item_Id)
27530 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
27532 Record_Item (Dep_Item_Id);
27535 -- An abstract state with visible non-null refinement
27536 -- matches one of its constituents, or itself for an
27537 -- abstract state with partial visible refinement.
27539 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
27540 if Is_Entity_Name (Ref_Item) then
27541 Ref_Item_Id := Entity_Of (Ref_Item);
27543 if Ekind (Ref_Item_Id) in
27544 E_Abstract_State | E_Constant | E_Variable
27545 and then Present (Encapsulating_State (Ref_Item_Id))
27546 and then Find_Encapsulating_State
27547 (Dep_States, Ref_Item_Id) = Dep_Item_Id
27549 Record_Item (Dep_Item_Id);
27552 elsif not Has_Visible_Refinement (Dep_Item_Id)
27553 and then Ref_Item_Id = Dep_Item_Id
27555 Record_Item (Dep_Item_Id);
27560 -- An abstract state without a visible refinement matches
27563 elsif Is_Entity_Name (Ref_Item)
27564 and then Entity_Of (Ref_Item) = Dep_Item_Id
27566 Record_Item (Dep_Item_Id);
27570 -- A current instance of a concurrent type, discriminant,
27571 -- formal parameter or an object matches itself.
27573 elsif Is_Entity_Name (Ref_Item)
27574 and then Entity_Of (Ref_Item) = Dep_Item_Id
27576 Record_Item (Dep_Item_Id);
27586 procedure Record_Item (Item_Id : Entity_Id) is
27588 if No (Matched_Items) then
27589 Matched_Items := New_Elmt_List;
27592 Append_Unique_Elmt (Item_Id, Matched_Items);
27597 Clause_Matched : Boolean := False;
27598 Dummy : Boolean := False;
27599 Inputs_Match : Boolean;
27600 Next_Ref_Clause : Node_Id;
27601 Outputs_Match : Boolean;
27602 Ref_Clause : Node_Id;
27603 Ref_Input : Node_Id;
27604 Ref_Output : Node_Id;
27606 -- Start of processing for Check_Dependency_Clause
27609 -- Do not perform this check in an instance because it was already
27610 -- performed successfully in the generic template.
27612 if In_Instance then
27616 -- Examine all refinement clauses and compare them against the
27617 -- dependence clause.
27619 Ref_Clause := First (Refinements);
27620 while Present (Ref_Clause) loop
27621 Next_Ref_Clause := Next (Ref_Clause);
27623 -- Obtain the attributes of the current refinement clause
27625 Ref_Input := Expression (Ref_Clause);
27626 Ref_Output := First (Choices (Ref_Clause));
27628 -- The current refinement clause matches the dependence clause
27629 -- when both outputs match and both inputs match. See routine
27630 -- Match_Items for all possible conformance scenarios.
27632 -- Depends Dep_Output => Dep_Input
27636 -- Refined_Depends Ref_Output => Ref_Input
27639 (Dep_Item => Dep_Input,
27640 Ref_Item => Ref_Input,
27641 Matched => Inputs_Match);
27644 (Dep_Item => Dep_Output,
27645 Ref_Item => Ref_Output,
27646 Matched => Outputs_Match);
27648 -- An In_Out state clause may be matched against a refinement with
27649 -- a null input or null output as long as the non-null side of the
27650 -- relation contains a valid constituent of the In_Out_State.
27652 if Is_In_Out_State_Clause then
27654 -- Depends => (State => State)
27655 -- Refined_Depends => (null => Constit) -- OK
27658 and then not Outputs_Match
27659 and then Nkind (Ref_Output) = N_Null
27661 Outputs_Match := True;
27664 -- Depends => (State => State)
27665 -- Refined_Depends => (Constit => null) -- OK
27667 if not Inputs_Match
27668 and then Outputs_Match
27669 and then Nkind (Ref_Input) = N_Null
27671 Inputs_Match := True;
27675 -- The current refinement clause is legally constructed following
27676 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
27677 -- the pool of candidates. The search continues because a single
27678 -- dependence clause may have multiple matching refinements.
27680 if Inputs_Match and Outputs_Match then
27681 Clause_Matched := True;
27682 Remove (Ref_Clause);
27685 Ref_Clause := Next_Ref_Clause;
27688 -- Depending on the order or composition of refinement clauses, an
27689 -- In_Out state clause may not be directly refinable.
27691 -- Refined_State => (State => (Constit_1, Constit_2))
27692 -- Depends => ((Output, State) => (Input, State))
27693 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
27695 -- Matching normalized clause (State => State) fails because there is
27696 -- no direct refinement capable of satisfying this relation. Another
27697 -- similar case arises when clauses (Constit_1 => Input) and (Output
27698 -- => Constit_2) are matched first, leaving no candidates for clause
27699 -- (State => State). Both scenarios are legal as long as one of the
27700 -- previous clauses mentioned a valid constituent of State.
27702 if not Clause_Matched
27703 and then Is_In_Out_State_Clause
27704 and then Is_Already_Matched (Dep_Input)
27706 Clause_Matched := True;
27709 -- A clause where the input is an abstract state with visible null
27710 -- refinement or a 'Result attribute is implicitly matched when the
27711 -- output has already been matched in a previous clause.
27713 -- Refined_State => (State => null)
27714 -- Depends => (Output => State) -- implicitly OK
27715 -- Refined_Depends => (Output => ...)
27716 -- Depends => (...'Result => State) -- implicitly OK
27717 -- Refined_Depends => (...'Result => ...)
27719 if not Clause_Matched
27720 and then Is_Null_Refined_State (Dep_Input)
27721 and then Is_Already_Matched (Dep_Output)
27723 Clause_Matched := True;
27726 -- A clause where the output is an abstract state with visible null
27727 -- refinement is implicitly matched when the input has already been
27728 -- matched in a previous clause.
27730 -- Refined_State => (State => null)
27731 -- Depends => (State => Input) -- implicitly OK
27732 -- Refined_Depends => (... => Input)
27734 if not Clause_Matched
27735 and then Is_Null_Refined_State (Dep_Output)
27736 and then Is_Already_Matched (Dep_Input)
27738 Clause_Matched := True;
27741 -- At this point either all refinement clauses have been examined or
27742 -- pragma Refined_Depends contains a solitary null. Only an abstract
27743 -- state with null refinement can possibly match these cases.
27745 -- Refined_State => (State => null)
27746 -- Depends => (State => null)
27747 -- Refined_Depends => null -- OK
27749 if not Clause_Matched then
27751 (Dep_Item => Dep_Input,
27753 Matched => Inputs_Match);
27756 (Dep_Item => Dep_Output,
27758 Matched => Outputs_Match);
27760 Clause_Matched := Inputs_Match and Outputs_Match;
27763 -- If the contents of Refined_Depends are legal, then the current
27764 -- dependence clause should be satisfied either by an explicit match
27765 -- or by one of the special cases.
27767 if not Clause_Matched then
27769 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
27770 & "matching refinement in body"), Dep_Clause, Spec_Id);
27772 end Check_Dependency_Clause;
27774 -------------------------
27775 -- Check_Output_States --
27776 -------------------------
27778 procedure Check_Output_States
27779 (Spec_Inputs : Elist_Id;
27780 Spec_Outputs : Elist_Id;
27781 Body_Inputs : Elist_Id;
27782 Body_Outputs : Elist_Id)
27784 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27785 -- Determine whether all constituents of state State_Id with full
27786 -- visible refinement are used as outputs in pragma Refined_Depends.
27787 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
27789 -----------------------------
27790 -- Check_Constituent_Usage --
27791 -----------------------------
27793 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27794 Constits : constant Elist_Id :=
27795 Partial_Refinement_Constituents (State_Id);
27796 Constit_Elmt : Elmt_Id;
27797 Constit_Id : Entity_Id;
27798 Only_Partial : constant Boolean :=
27799 not Has_Visible_Refinement (State_Id);
27800 Posted : Boolean := False;
27803 if Present (Constits) then
27804 Constit_Elmt := First_Elmt (Constits);
27805 while Present (Constit_Elmt) loop
27806 Constit_Id := Node (Constit_Elmt);
27808 -- Issue an error when a constituent of State_Id is used,
27809 -- and State_Id has only partial visible refinement
27810 -- (SPARK RM 7.2.4(3d)).
27812 if Only_Partial then
27813 if (Present (Body_Inputs)
27814 and then Appears_In (Body_Inputs, Constit_Id))
27816 (Present (Body_Outputs)
27817 and then Appears_In (Body_Outputs, Constit_Id))
27819 Error_Msg_Name_1 := Chars (State_Id);
27821 ("constituent & of state % cannot be used in "
27822 & "dependence refinement", N, Constit_Id);
27823 Error_Msg_Name_1 := Chars (State_Id);
27824 SPARK_Msg_N ("\use state % instead", N);
27827 -- The constituent acts as an input (SPARK RM 7.2.5(3))
27829 elsif Present (Body_Inputs)
27830 and then Appears_In (Body_Inputs, Constit_Id)
27832 Error_Msg_Name_1 := Chars (State_Id);
27834 ("constituent & of state % must act as output in "
27835 & "dependence refinement", N, Constit_Id);
27837 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27839 elsif No (Body_Outputs)
27840 or else not Appears_In (Body_Outputs, Constit_Id)
27845 ("output state & must be replaced by all its "
27846 & "constituents in dependence refinement",
27851 ("\constituent & is missing in output list",
27855 Next_Elmt (Constit_Elmt);
27858 end Check_Constituent_Usage;
27863 Item_Elmt : Elmt_Id;
27864 Item_Id : Entity_Id;
27866 -- Start of processing for Check_Output_States
27869 -- Do not perform this check in an instance because it was already
27870 -- performed successfully in the generic template.
27872 if In_Instance then
27875 -- Inspect the outputs of pragma Depends looking for a state with a
27876 -- visible refinement.
27878 elsif Present (Spec_Outputs) then
27879 Item_Elmt := First_Elmt (Spec_Outputs);
27880 while Present (Item_Elmt) loop
27881 Item := Node (Item_Elmt);
27883 -- Deal with the mixed nature of the input and output lists
27885 if Nkind (Item) = N_Defining_Identifier then
27888 Item_Id := Available_View (Entity_Of (Item));
27891 if Ekind (Item_Id) = E_Abstract_State then
27893 -- The state acts as an input-output, skip it
27895 if Present (Spec_Inputs)
27896 and then Appears_In (Spec_Inputs, Item_Id)
27900 -- Ensure that all of the constituents are utilized as
27901 -- outputs in pragma Refined_Depends.
27903 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27904 Check_Constituent_Usage (Item_Id);
27908 Next_Elmt (Item_Elmt);
27911 end Check_Output_States;
27913 --------------------
27914 -- Collect_States --
27915 --------------------
27917 function Collect_States (Clauses : List_Id) return Elist_Id is
27918 procedure Collect_State
27920 States : in out Elist_Id);
27921 -- Add the entity of Item to list States when it denotes to a state
27923 -------------------
27924 -- Collect_State --
27925 -------------------
27927 procedure Collect_State
27929 States : in out Elist_Id)
27934 if Is_Entity_Name (Item) then
27935 Id := Entity_Of (Item);
27937 if Ekind (Id) = E_Abstract_State then
27938 if No (States) then
27939 States := New_Elmt_List;
27942 Append_Unique_Elmt (Id, States);
27952 States : Elist_Id := No_Elist;
27954 -- Start of processing for Collect_States
27957 Clause := First (Clauses);
27958 while Present (Clause) loop
27959 Input := Expression (Clause);
27960 Output := First (Choices (Clause));
27962 Collect_State (Input, States);
27963 Collect_State (Output, States);
27969 end Collect_States;
27971 -----------------------
27972 -- Normalize_Clauses --
27973 -----------------------
27975 procedure Normalize_Clauses (Clauses : List_Id) is
27976 procedure Normalize_Inputs (Clause : Node_Id);
27977 -- Normalize clause Clause by creating multiple clauses for each
27978 -- input item of Clause. It is assumed that Clause has exactly one
27979 -- output. The transformation is as follows:
27981 -- Output => (Input_1, Input_2) -- original
27983 -- Output => Input_1 -- normalizations
27984 -- Output => Input_2
27986 procedure Normalize_Outputs (Clause : Node_Id);
27987 -- Normalize clause Clause by creating multiple clause for each
27988 -- output item of Clause. The transformation is as follows:
27990 -- (Output_1, Output_2) => Input -- original
27992 -- Output_1 => Input -- normalization
27993 -- Output_2 => Input
27995 ----------------------
27996 -- Normalize_Inputs --
27997 ----------------------
27999 procedure Normalize_Inputs (Clause : Node_Id) is
28000 Inputs : constant Node_Id := Expression (Clause);
28001 Loc : constant Source_Ptr := Sloc (Clause);
28002 Output : constant List_Id := Choices (Clause);
28003 Last_Input : Node_Id;
28005 New_Clause : Node_Id;
28006 Next_Input : Node_Id;
28009 -- Normalization is performed only when the original clause has
28010 -- more than one input. Multiple inputs appear as an aggregate.
28012 if Nkind (Inputs) = N_Aggregate then
28013 Last_Input := Last (Expressions (Inputs));
28015 -- Create a new clause for each input
28017 Input := First (Expressions (Inputs));
28018 while Present (Input) loop
28019 Next_Input := Next (Input);
28021 -- Unhook the current input from the original input list
28022 -- because it will be relocated to a new clause.
28026 -- Special processing for the last input. At this point the
28027 -- original aggregate has been stripped down to one element.
28028 -- Replace the aggregate by the element itself.
28030 if Input = Last_Input then
28031 Rewrite (Inputs, Input);
28033 -- Generate a clause of the form:
28038 Make_Component_Association (Loc,
28039 Choices => New_Copy_List_Tree (Output),
28040 Expression => Input);
28042 -- The new clause contains replicated content that has
28043 -- already been analyzed, mark the clause as analyzed.
28045 Set_Analyzed (New_Clause);
28046 Insert_After (Clause, New_Clause);
28049 Input := Next_Input;
28052 end Normalize_Inputs;
28054 -----------------------
28055 -- Normalize_Outputs --
28056 -----------------------
28058 procedure Normalize_Outputs (Clause : Node_Id) is
28059 Inputs : constant Node_Id := Expression (Clause);
28060 Loc : constant Source_Ptr := Sloc (Clause);
28061 Outputs : constant Node_Id := First (Choices (Clause));
28062 Last_Output : Node_Id;
28063 New_Clause : Node_Id;
28064 Next_Output : Node_Id;
28068 -- Multiple outputs appear as an aggregate. Nothing to do when
28069 -- the clause has exactly one output.
28071 if Nkind (Outputs) = N_Aggregate then
28072 Last_Output := Last (Expressions (Outputs));
28074 -- Create a clause for each output. Note that each time a new
28075 -- clause is created, the original output list slowly shrinks
28076 -- until there is one item left.
28078 Output := First (Expressions (Outputs));
28079 while Present (Output) loop
28080 Next_Output := Next (Output);
28082 -- Unhook the output from the original output list as it
28083 -- will be relocated to a new clause.
28087 -- Special processing for the last output. At this point
28088 -- the original aggregate has been stripped down to one
28089 -- element. Replace the aggregate by the element itself.
28091 if Output = Last_Output then
28092 Rewrite (Outputs, Output);
28095 -- Generate a clause of the form:
28096 -- (Output => Inputs)
28099 Make_Component_Association (Loc,
28100 Choices => New_List (Output),
28101 Expression => New_Copy_Tree (Inputs));
28103 -- The new clause contains replicated content that has
28104 -- already been analyzed. There is not need to reanalyze
28107 Set_Analyzed (New_Clause);
28108 Insert_After (Clause, New_Clause);
28111 Output := Next_Output;
28114 end Normalize_Outputs;
28120 -- Start of processing for Normalize_Clauses
28123 Clause := First (Clauses);
28124 while Present (Clause) loop
28125 Normalize_Outputs (Clause);
28129 Clause := First (Clauses);
28130 while Present (Clause) loop
28131 Normalize_Inputs (Clause);
28134 end Normalize_Clauses;
28136 --------------------------
28137 -- Remove_Extra_Clauses --
28138 --------------------------
28140 procedure Remove_Extra_Clauses
28141 (Clauses : List_Id;
28142 Matched_Items : Elist_Id)
28146 Input_Id : Entity_Id;
28147 Next_Clause : Node_Id;
28149 State_Id : Entity_Id;
28152 Clause := First (Clauses);
28153 while Present (Clause) loop
28154 Next_Clause := Next (Clause);
28156 Input := Expression (Clause);
28157 Output := First (Choices (Clause));
28159 -- Recognize a clause of the form
28163 -- where Input is a constituent of a state which was already
28164 -- successfully matched. This clause must be removed because it
28165 -- simply indicates that some of the constituents of the state
28168 -- Refined_State => (State => (Constit_1, Constit_2))
28169 -- Depends => (Output => State)
28170 -- Refined_Depends => ((Output => Constit_1), -- State matched
28171 -- (null => Constit_2)) -- OK
28173 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
28175 -- Handle abstract views generated for limited with clauses
28177 Input_Id := Available_View (Entity_Of (Input));
28179 -- The input must be a constituent of a state
28181 if Ekind (Input_Id) in
28182 E_Abstract_State | E_Constant | E_Variable
28183 and then Present (Encapsulating_State (Input_Id))
28185 State_Id := Encapsulating_State (Input_Id);
28187 -- The state must have a non-null visible refinement and be
28188 -- matched in a previous clause.
28190 if Has_Non_Null_Visible_Refinement (State_Id)
28191 and then Contains (Matched_Items, State_Id)
28197 -- Recognize a clause of the form
28201 -- where Output is an arbitrary item. This clause must be removed
28202 -- because a null input legitimately matches anything.
28204 elsif Nkind (Input) = N_Null then
28208 Clause := Next_Clause;
28210 end Remove_Extra_Clauses;
28212 --------------------------
28213 -- Report_Extra_Clauses --
28214 --------------------------
28216 procedure Report_Extra_Clauses (Clauses : List_Id) is
28220 -- Do not perform this check in an instance because it was already
28221 -- performed successfully in the generic template.
28223 if In_Instance then
28226 elsif Present (Clauses) then
28227 Clause := First (Clauses);
28228 while Present (Clause) loop
28230 ("unmatched or extra clause in dependence refinement",
28236 end Report_Extra_Clauses;
28240 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28241 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28242 Errors : constant Nat := Serious_Errors_Detected;
28249 Body_Inputs : Elist_Id := No_Elist;
28250 Body_Outputs : Elist_Id := No_Elist;
28251 -- The inputs and outputs of the subprogram body synthesized from pragma
28252 -- Refined_Depends.
28254 Dependencies : List_Id := No_List;
28256 -- The corresponding Depends pragma along with its clauses
28258 Matched_Items : Elist_Id := No_Elist;
28259 -- A list containing the entities of all successfully matched items
28260 -- found in pragma Depends.
28262 Refinements : List_Id := No_List;
28263 -- The clauses of pragma Refined_Depends
28265 Spec_Id : Entity_Id;
28266 -- The entity of the subprogram subject to pragma Refined_Depends
28268 Spec_Inputs : Elist_Id := No_Elist;
28269 Spec_Outputs : Elist_Id := No_Elist;
28270 -- The inputs and outputs of the subprogram spec synthesized from pragma
28273 States : Elist_Id := No_Elist;
28274 -- A list containing the entities of all states whose constituents
28275 -- appear in pragma Depends.
28277 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
28280 -- Do not analyze the pragma multiple times
28282 if Is_Analyzed_Pragma (N) then
28286 Spec_Id := Unique_Defining_Entity (Body_Decl);
28288 -- Use the anonymous object as the proper spec when Refined_Depends
28289 -- applies to the body of a single task type. The object carries the
28290 -- proper Chars as well as all non-refined versions of pragmas.
28292 if Is_Single_Concurrent_Type (Spec_Id) then
28293 Spec_Id := Anonymous_Object (Spec_Id);
28296 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
28298 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
28299 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
28301 if No (Depends) then
28303 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28304 & "& lacks aspect or pragma Depends"), N, Spec_Id);
28308 Deps := Expression (Get_Argument (Depends, Spec_Id));
28310 -- A null dependency relation renders the refinement useless because it
28311 -- cannot possibly mention abstract states with visible refinement. Note
28312 -- that the inverse is not true as states may be refined to null
28313 -- (SPARK RM 7.2.5(2)).
28315 if Nkind (Deps) = N_Null then
28317 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28318 & "depend on abstract state with visible refinement"), N, Spec_Id);
28322 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
28323 -- This ensures that the categorization of all refined dependency items
28324 -- is consistent with their role.
28326 Analyze_Depends_In_Decl_Part (N);
28328 -- Do not match dependencies against refinements if Refined_Depends is
28329 -- illegal to avoid emitting misleading error.
28331 if Serious_Errors_Detected = Errors then
28333 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
28334 -- the inputs and outputs of the subprogram spec and body to verify
28335 -- the use of states with visible refinement and their constituents.
28337 if No (Get_Pragma (Spec_Id, Pragma_Global))
28338 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
28340 Collect_Subprogram_Inputs_Outputs
28341 (Subp_Id => Spec_Id,
28342 Synthesize => True,
28343 Subp_Inputs => Spec_Inputs,
28344 Subp_Outputs => Spec_Outputs,
28345 Global_Seen => Dummy);
28347 Collect_Subprogram_Inputs_Outputs
28348 (Subp_Id => Body_Id,
28349 Synthesize => True,
28350 Subp_Inputs => Body_Inputs,
28351 Subp_Outputs => Body_Outputs,
28352 Global_Seen => Dummy);
28354 -- For an output state with a visible refinement, ensure that all
28355 -- constituents appear as outputs in the dependency refinement.
28357 Check_Output_States
28358 (Spec_Inputs => Spec_Inputs,
28359 Spec_Outputs => Spec_Outputs,
28360 Body_Inputs => Body_Inputs,
28361 Body_Outputs => Body_Outputs);
28364 -- Multiple dependency clauses appear as component associations of an
28365 -- aggregate. Note that the clauses are copied because the algorithm
28366 -- modifies them and this should not be visible in Depends.
28368 pragma Assert (Nkind (Deps) = N_Aggregate);
28369 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
28370 Normalize_Clauses (Dependencies);
28372 -- Gather all states which appear in Depends
28374 States := Collect_States (Dependencies);
28376 Refs := Expression (Get_Argument (N, Spec_Id));
28378 if Nkind (Refs) = N_Null then
28379 Refinements := No_List;
28381 -- Multiple dependency clauses appear as component associations of an
28382 -- aggregate. Note that the clauses are copied because the algorithm
28383 -- modifies them and this should not be visible in Refined_Depends.
28385 else pragma Assert (Nkind (Refs) = N_Aggregate);
28386 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
28387 Normalize_Clauses (Refinements);
28390 -- At this point the clauses of pragmas Depends and Refined_Depends
28391 -- have been normalized into simple dependencies between one output
28392 -- and one input. Examine all clauses of pragma Depends looking for
28393 -- matching clauses in pragma Refined_Depends.
28395 Clause := First (Dependencies);
28396 while Present (Clause) loop
28397 Check_Dependency_Clause
28398 (Spec_Id => Spec_Id,
28399 Dep_Clause => Clause,
28400 Dep_States => States,
28401 Refinements => Refinements,
28402 Matched_Items => Matched_Items);
28407 -- Pragma Refined_Depends may contain multiple clarification clauses
28408 -- which indicate that certain constituents do not influence the data
28409 -- flow in any way. Such clauses must be removed as long as the state
28410 -- has been matched, otherwise they will be incorrectly flagged as
28413 -- Refined_State => (State => (Constit_1, Constit_2))
28414 -- Depends => (Output => State)
28415 -- Refined_Depends => ((Output => Constit_1), -- State matched
28416 -- (null => Constit_2)) -- must be removed
28418 Remove_Extra_Clauses (Refinements, Matched_Items);
28420 if Serious_Errors_Detected = Errors then
28421 Report_Extra_Clauses (Refinements);
28426 Set_Is_Analyzed_Pragma (N);
28427 end Analyze_Refined_Depends_In_Decl_Part;
28429 -----------------------------------------
28430 -- Analyze_Refined_Global_In_Decl_Part --
28431 -----------------------------------------
28433 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
28435 -- The corresponding Global pragma
28437 Has_In_State : Boolean := False;
28438 Has_In_Out_State : Boolean := False;
28439 Has_Out_State : Boolean := False;
28440 Has_Proof_In_State : Boolean := False;
28441 -- These flags are set when the corresponding Global pragma has a state
28442 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
28445 Has_Null_State : Boolean := False;
28446 -- This flag is set when the corresponding Global pragma has at least
28447 -- one state with a null refinement.
28449 In_Constits : Elist_Id := No_Elist;
28450 In_Out_Constits : Elist_Id := No_Elist;
28451 Out_Constits : Elist_Id := No_Elist;
28452 Proof_In_Constits : Elist_Id := No_Elist;
28453 -- These lists contain the entities of all Input, In_Out, Output and
28454 -- Proof_In constituents that appear in Refined_Global and participate
28455 -- in state refinement.
28457 In_Items : Elist_Id := No_Elist;
28458 In_Out_Items : Elist_Id := No_Elist;
28459 Out_Items : Elist_Id := No_Elist;
28460 Proof_In_Items : Elist_Id := No_Elist;
28461 -- These lists contain the entities of all Input, In_Out, Output and
28462 -- Proof_In items defined in the corresponding Global pragma.
28464 Repeat_Items : Elist_Id := No_Elist;
28465 -- A list of all global items without full visible refinement found
28466 -- in pragma Global. These states should be repeated in the global
28467 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
28468 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
28470 Spec_Id : Entity_Id;
28471 -- The entity of the subprogram subject to pragma Refined_Global
28473 States : Elist_Id := No_Elist;
28474 -- A list of all states with full or partial visible refinement found in
28477 procedure Check_In_Out_States;
28478 -- Determine whether the corresponding Global pragma mentions In_Out
28479 -- states with visible refinement and if so, ensure that one of the
28480 -- following completions apply to the constituents of the state:
28481 -- 1) there is at least one constituent of mode In_Out
28482 -- 2) there is at least one Input and one Output constituent
28483 -- 3) not all constituents are present and one of them is of mode
28485 -- This routine may remove elements from In_Constits, In_Out_Constits,
28486 -- Out_Constits and Proof_In_Constits.
28488 procedure Check_Input_States;
28489 -- Determine whether the corresponding Global pragma mentions Input
28490 -- states with visible refinement and if so, ensure that at least one of
28491 -- its constituents appears as an Input item in Refined_Global.
28492 -- This routine may remove elements from In_Constits, In_Out_Constits,
28493 -- Out_Constits and Proof_In_Constits.
28495 procedure Check_Output_States;
28496 -- Determine whether the corresponding Global pragma mentions Output
28497 -- states with visible refinement and if so, ensure that all of its
28498 -- constituents appear as Output items in Refined_Global.
28499 -- This routine may remove elements from In_Constits, In_Out_Constits,
28500 -- Out_Constits and Proof_In_Constits.
28502 procedure Check_Proof_In_States;
28503 -- Determine whether the corresponding Global pragma mentions Proof_In
28504 -- states with visible refinement and if so, ensure that at least one of
28505 -- its constituents appears as a Proof_In item in Refined_Global.
28506 -- This routine may remove elements from In_Constits, In_Out_Constits,
28507 -- Out_Constits and Proof_In_Constits.
28509 procedure Check_Refined_Global_List
28511 Global_Mode : Name_Id := Name_Input);
28512 -- Verify the legality of a single global list declaration. Global_Mode
28513 -- denotes the current mode in effect.
28515 procedure Collect_Global_Items
28517 Mode : Name_Id := Name_Input);
28518 -- Gather all Input, In_Out, Output and Proof_In items from node List
28519 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
28520 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
28521 -- and Has_Proof_In_State are set when there is at least one abstract
28522 -- state with full or partial visible refinement available in the
28523 -- corresponding mode. Flag Has_Null_State is set when at least state
28524 -- has a null refinement. Mode denotes the current global mode in
28527 function Present_Then_Remove
28529 Item : Entity_Id) return Boolean;
28530 -- Search List for a particular entity Item. If Item has been found,
28531 -- remove it from List. This routine is used to strip lists In_Constits,
28532 -- In_Out_Constits and Out_Constits of valid constituents.
28534 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
28535 -- Same as function Present_Then_Remove, but do not report the presence
28536 -- of Item in List.
28538 procedure Report_Extra_Constituents;
28539 -- Emit an error for each constituent found in lists In_Constits,
28540 -- In_Out_Constits and Out_Constits.
28542 procedure Report_Missing_Items;
28543 -- Emit an error for each global item not repeated found in list
28546 -------------------------
28547 -- Check_In_Out_States --
28548 -------------------------
28550 procedure Check_In_Out_States is
28551 procedure Check_Constituent_Usage (State_Id : Entity_Id);
28552 -- Determine whether one of the following coverage scenarios is in
28554 -- 1) there is at least one constituent of mode In_Out or Output
28555 -- 2) there is at least one pair of constituents with modes Input
28556 -- and Output, or Proof_In and Output.
28557 -- 3) there is at least one constituent of mode Output and not all
28558 -- constituents are present.
28559 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
28561 -----------------------------
28562 -- Check_Constituent_Usage --
28563 -----------------------------
28565 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
28566 Constits : constant Elist_Id :=
28567 Partial_Refinement_Constituents (State_Id);
28568 Constit_Elmt : Elmt_Id;
28569 Constit_Id : Entity_Id;
28570 Has_Missing : Boolean := False;
28571 In_Out_Seen : Boolean := False;
28572 Input_Seen : Boolean := False;
28573 Output_Seen : Boolean := False;
28574 Proof_In_Seen : Boolean := False;
28577 -- Process all the constituents of the state and note their modes
28578 -- within the global refinement.
28580 if Present (Constits) then
28581 Constit_Elmt := First_Elmt (Constits);
28582 while Present (Constit_Elmt) loop
28583 Constit_Id := Node (Constit_Elmt);
28585 if Present_Then_Remove (In_Constits, Constit_Id) then
28586 Input_Seen := True;
28588 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
28589 In_Out_Seen := True;
28591 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
28592 Output_Seen := True;
28594 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
28596 Proof_In_Seen := True;
28599 Has_Missing := True;
28602 Next_Elmt (Constit_Elmt);
28606 -- An In_Out constituent is a valid completion
28608 if In_Out_Seen then
28611 -- A pair of one Input/Proof_In and one Output constituent is a
28612 -- valid completion.
28614 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
28617 elsif Output_Seen then
28619 -- A single Output constituent is a valid completion only when
28620 -- some of the other constituents are missing.
28622 if Has_Missing then
28625 -- Otherwise all constituents are of mode Output
28629 ("global refinement of state & must include at least one "
28630 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
28634 -- The state lacks a completion. When full refinement is visible,
28635 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
28636 -- refinement is visible, emit an error if the abstract state
28637 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
28638 -- both are utilized, Check_State_And_Constituent_Use. will issue
28641 elsif not Input_Seen
28642 and then not In_Out_Seen
28643 and then not Output_Seen
28644 and then not Proof_In_Seen
28646 if Has_Visible_Refinement (State_Id)
28647 or else Contains (Repeat_Items, State_Id)
28650 ("missing global refinement of state &", N, State_Id);
28653 -- Otherwise the state has a malformed completion where at least
28654 -- one of the constituents has a different mode.
28658 ("global refinement of state & redefines the mode of its "
28659 & "constituents", N, State_Id);
28661 end Check_Constituent_Usage;
28665 Item_Elmt : Elmt_Id;
28666 Item_Id : Entity_Id;
28668 -- Start of processing for Check_In_Out_States
28671 -- Do not perform this check in an instance because it was already
28672 -- performed successfully in the generic template.
28674 if In_Instance then
28677 -- Inspect the In_Out items of the corresponding Global pragma
28678 -- looking for a state with a visible refinement.
28680 elsif Has_In_Out_State and then Present (In_Out_Items) then
28681 Item_Elmt := First_Elmt (In_Out_Items);
28682 while Present (Item_Elmt) loop
28683 Item_Id := Node (Item_Elmt);
28685 -- Ensure that one of the three coverage variants is satisfied
28687 if Ekind (Item_Id) = E_Abstract_State
28688 and then Has_Non_Null_Visible_Refinement (Item_Id)
28690 Check_Constituent_Usage (Item_Id);
28693 Next_Elmt (Item_Elmt);
28696 end Check_In_Out_States;
28698 ------------------------
28699 -- Check_Input_States --
28700 ------------------------
28702 procedure Check_Input_States is
28703 procedure Check_Constituent_Usage (State_Id : Entity_Id);
28704 -- Determine whether at least one constituent of state State_Id with
28705 -- full or partial visible refinement is used and has mode Input.
28706 -- Ensure that the remaining constituents do not have In_Out or
28707 -- Output modes. Emit an error if this is not the case
28708 -- (SPARK RM 7.2.4(5)).
28710 -----------------------------
28711 -- Check_Constituent_Usage --
28712 -----------------------------
28714 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
28715 Constits : constant Elist_Id :=
28716 Partial_Refinement_Constituents (State_Id);
28717 Constit_Elmt : Elmt_Id;
28718 Constit_Id : Entity_Id;
28719 In_Seen : Boolean := False;
28722 if Present (Constits) then
28723 Constit_Elmt := First_Elmt (Constits);
28724 while Present (Constit_Elmt) loop
28725 Constit_Id := Node (Constit_Elmt);
28727 -- At least one of the constituents appears as an Input
28729 if Present_Then_Remove (In_Constits, Constit_Id) then
28732 -- A Proof_In constituent can refine an Input state as long
28733 -- as there is at least one Input constituent present.
28735 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
28739 -- The constituent appears in the global refinement, but has
28740 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
28742 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
28743 or else Present_Then_Remove (Out_Constits, Constit_Id)
28745 Error_Msg_Name_1 := Chars (State_Id);
28747 ("constituent & of state % must have mode `Input` in "
28748 & "global refinement", N, Constit_Id);
28751 Next_Elmt (Constit_Elmt);
28755 -- Not one of the constituents appeared as Input. Always emit an
28756 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
28757 -- When only partial refinement is visible, emit an error if the
28758 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
28759 -- the case where both are utilized, an error will be issued in
28760 -- Check_State_And_Constituent_Use.
28763 and then (Has_Visible_Refinement (State_Id)
28764 or else Contains (Repeat_Items, State_Id))
28767 ("global refinement of state & must include at least one "
28768 & "constituent of mode `Input`", N, State_Id);
28770 end Check_Constituent_Usage;
28774 Item_Elmt : Elmt_Id;
28775 Item_Id : Entity_Id;
28777 -- Start of processing for Check_Input_States
28780 -- Do not perform this check in an instance because it was already
28781 -- performed successfully in the generic template.
28783 if In_Instance then
28786 -- Inspect the Input items of the corresponding Global pragma looking
28787 -- for a state with a visible refinement.
28789 elsif Has_In_State and then Present (In_Items) then
28790 Item_Elmt := First_Elmt (In_Items);
28791 while Present (Item_Elmt) loop
28792 Item_Id := Node (Item_Elmt);
28794 -- When full refinement is visible, ensure that at least one of
28795 -- the constituents is utilized and is of mode Input. When only
28796 -- partial refinement is visible, ensure that either one of
28797 -- the constituents is utilized and is of mode Input, or the
28798 -- abstract state is repeated and no constituent is utilized.
28800 if Ekind (Item_Id) = E_Abstract_State
28801 and then Has_Non_Null_Visible_Refinement (Item_Id)
28803 Check_Constituent_Usage (Item_Id);
28806 Next_Elmt (Item_Elmt);
28809 end Check_Input_States;
28811 -------------------------
28812 -- Check_Output_States --
28813 -------------------------
28815 procedure Check_Output_States is
28816 procedure Check_Constituent_Usage (State_Id : Entity_Id);
28817 -- Determine whether all constituents of state State_Id with full
28818 -- visible refinement are used and have mode Output. Emit an error
28819 -- if this is not the case (SPARK RM 7.2.4(5)).
28821 -----------------------------
28822 -- Check_Constituent_Usage --
28823 -----------------------------
28825 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
28826 Constits : constant Elist_Id :=
28827 Partial_Refinement_Constituents (State_Id);
28828 Only_Partial : constant Boolean :=
28829 not Has_Visible_Refinement (State_Id);
28830 Constit_Elmt : Elmt_Id;
28831 Constit_Id : Entity_Id;
28832 Posted : Boolean := False;
28835 if Present (Constits) then
28836 Constit_Elmt := First_Elmt (Constits);
28837 while Present (Constit_Elmt) loop
28838 Constit_Id := Node (Constit_Elmt);
28840 -- Issue an error when a constituent of State_Id is utilized
28841 -- and State_Id has only partial visible refinement
28842 -- (SPARK RM 7.2.4(3d)).
28844 if Only_Partial then
28845 if Present_Then_Remove (Out_Constits, Constit_Id)
28846 or else Present_Then_Remove (In_Constits, Constit_Id)
28848 Present_Then_Remove (In_Out_Constits, Constit_Id)
28850 Present_Then_Remove (Proof_In_Constits, Constit_Id)
28852 Error_Msg_Name_1 := Chars (State_Id);
28854 ("constituent & of state % cannot be used in global "
28855 & "refinement", N, Constit_Id);
28856 Error_Msg_Name_1 := Chars (State_Id);
28857 SPARK_Msg_N ("\use state % instead", N);
28860 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
28863 -- The constituent appears in the global refinement, but has
28864 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
28866 elsif Present_Then_Remove (In_Constits, Constit_Id)
28867 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
28868 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
28870 Error_Msg_Name_1 := Chars (State_Id);
28872 ("constituent & of state % must have mode `Output` in "
28873 & "global refinement", N, Constit_Id);
28875 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
28881 ("`Output` state & must be replaced by all its "
28882 & "constituents in global refinement", N, State_Id);
28886 ("\constituent & is missing in output list",
28890 Next_Elmt (Constit_Elmt);
28893 end Check_Constituent_Usage;
28897 Item_Elmt : Elmt_Id;
28898 Item_Id : Entity_Id;
28900 -- Start of processing for Check_Output_States
28903 -- Do not perform this check in an instance because it was already
28904 -- performed successfully in the generic template.
28906 if In_Instance then
28909 -- Inspect the Output items of the corresponding Global pragma
28910 -- looking for a state with a visible refinement.
28912 elsif Has_Out_State and then Present (Out_Items) then
28913 Item_Elmt := First_Elmt (Out_Items);
28914 while Present (Item_Elmt) loop
28915 Item_Id := Node (Item_Elmt);
28917 -- When full refinement is visible, ensure that all of the
28918 -- constituents are utilized and they have mode Output. When
28919 -- only partial refinement is visible, ensure that no
28920 -- constituent is utilized.
28922 if Ekind (Item_Id) = E_Abstract_State
28923 and then Has_Non_Null_Visible_Refinement (Item_Id)
28925 Check_Constituent_Usage (Item_Id);
28928 Next_Elmt (Item_Elmt);
28931 end Check_Output_States;
28933 ---------------------------
28934 -- Check_Proof_In_States --
28935 ---------------------------
28937 procedure Check_Proof_In_States is
28938 procedure Check_Constituent_Usage (State_Id : Entity_Id);
28939 -- Determine whether at least one constituent of state State_Id with
28940 -- full or partial visible refinement is used and has mode Proof_In.
28941 -- Ensure that the remaining constituents do not have Input, In_Out,
28942 -- or Output modes. Emit an error if this is not the case
28943 -- (SPARK RM 7.2.4(5)).
28945 -----------------------------
28946 -- Check_Constituent_Usage --
28947 -----------------------------
28949 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
28950 Constits : constant Elist_Id :=
28951 Partial_Refinement_Constituents (State_Id);
28952 Constit_Elmt : Elmt_Id;
28953 Constit_Id : Entity_Id;
28954 Proof_In_Seen : Boolean := False;
28957 if Present (Constits) then
28958 Constit_Elmt := First_Elmt (Constits);
28959 while Present (Constit_Elmt) loop
28960 Constit_Id := Node (Constit_Elmt);
28962 -- At least one of the constituents appears as Proof_In
28964 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
28965 Proof_In_Seen := True;
28967 -- The constituent appears in the global refinement, but has
28968 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
28970 elsif Present_Then_Remove (In_Constits, Constit_Id)
28971 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
28972 or else Present_Then_Remove (Out_Constits, Constit_Id)
28974 Error_Msg_Name_1 := Chars (State_Id);
28976 ("constituent & of state % must have mode `Proof_In` "
28977 & "in global refinement", N, Constit_Id);
28980 Next_Elmt (Constit_Elmt);
28984 -- Not one of the constituents appeared as Proof_In. Always emit
28985 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
28986 -- When only partial refinement is visible, emit an error if the
28987 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
28988 -- the case where both are utilized, an error will be issued by
28989 -- Check_State_And_Constituent_Use.
28991 if not Proof_In_Seen
28992 and then (Has_Visible_Refinement (State_Id)
28993 or else Contains (Repeat_Items, State_Id))
28996 ("global refinement of state & must include at least one "
28997 & "constituent of mode `Proof_In`", N, State_Id);
28999 end Check_Constituent_Usage;
29003 Item_Elmt : Elmt_Id;
29004 Item_Id : Entity_Id;
29006 -- Start of processing for Check_Proof_In_States
29009 -- Do not perform this check in an instance because it was already
29010 -- performed successfully in the generic template.
29012 if In_Instance then
29015 -- Inspect the Proof_In items of the corresponding Global pragma
29016 -- looking for a state with a visible refinement.
29018 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
29019 Item_Elmt := First_Elmt (Proof_In_Items);
29020 while Present (Item_Elmt) loop
29021 Item_Id := Node (Item_Elmt);
29023 -- Ensure that at least one of the constituents is utilized
29024 -- and is of mode Proof_In. When only partial refinement is
29025 -- visible, ensure that either one of the constituents is
29026 -- utilized and is of mode Proof_In, or the abstract state
29027 -- is repeated and no constituent is utilized.
29029 if Ekind (Item_Id) = E_Abstract_State
29030 and then Has_Non_Null_Visible_Refinement (Item_Id)
29032 Check_Constituent_Usage (Item_Id);
29035 Next_Elmt (Item_Elmt);
29038 end Check_Proof_In_States;
29040 -------------------------------
29041 -- Check_Refined_Global_List --
29042 -------------------------------
29044 procedure Check_Refined_Global_List
29046 Global_Mode : Name_Id := Name_Input)
29048 procedure Check_Refined_Global_Item
29050 Global_Mode : Name_Id);
29051 -- Verify the legality of a single global item declaration. Parameter
29052 -- Global_Mode denotes the current mode in effect.
29054 -------------------------------
29055 -- Check_Refined_Global_Item --
29056 -------------------------------
29058 procedure Check_Refined_Global_Item
29060 Global_Mode : Name_Id)
29062 Item_Id : constant Entity_Id := Entity_Of (Item);
29064 procedure Inconsistent_Mode_Error (Expect : Name_Id);
29065 -- Issue a common error message for all mode mismatches. Expect
29066 -- denotes the expected mode.
29068 -----------------------------
29069 -- Inconsistent_Mode_Error --
29070 -----------------------------
29072 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
29075 ("global item & has inconsistent modes", Item, Item_Id);
29077 Error_Msg_Name_1 := Global_Mode;
29078 Error_Msg_Name_2 := Expect;
29079 SPARK_Msg_N ("\expected mode %, found mode %", Item);
29080 end Inconsistent_Mode_Error;
29084 Enc_State : Entity_Id := Empty;
29085 -- Encapsulating state for constituent, Empty otherwise
29087 -- Start of processing for Check_Refined_Global_Item
29090 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
29092 Enc_State := Find_Encapsulating_State (States, Item_Id);
29095 -- When the state or object acts as a constituent of another
29096 -- state with a visible refinement, collect it for the state
29097 -- completeness checks performed later on. Note that the item
29098 -- acts as a constituent only when the encapsulating state is
29099 -- present in pragma Global.
29101 if Present (Enc_State)
29102 and then (Has_Visible_Refinement (Enc_State)
29103 or else Has_Partial_Visible_Refinement (Enc_State))
29104 and then Contains (States, Enc_State)
29106 -- If the state has only partial visible refinement, remove it
29107 -- from the list of items that should be repeated from pragma
29110 if not Has_Visible_Refinement (Enc_State) then
29111 Present_Then_Remove (Repeat_Items, Enc_State);
29114 if Global_Mode = Name_Input then
29115 Append_New_Elmt (Item_Id, In_Constits);
29117 elsif Global_Mode = Name_In_Out then
29118 Append_New_Elmt (Item_Id, In_Out_Constits);
29120 elsif Global_Mode = Name_Output then
29121 Append_New_Elmt (Item_Id, Out_Constits);
29123 elsif Global_Mode = Name_Proof_In then
29124 Append_New_Elmt (Item_Id, Proof_In_Constits);
29127 -- When not a constituent, ensure that both occurrences of the
29128 -- item in pragmas Global and Refined_Global match. Also remove
29129 -- it when present from the list of items that should be repeated
29130 -- from pragma Global.
29133 Present_Then_Remove (Repeat_Items, Item_Id);
29135 if Contains (In_Items, Item_Id) then
29136 if Global_Mode /= Name_Input then
29137 Inconsistent_Mode_Error (Name_Input);
29140 elsif Contains (In_Out_Items, Item_Id) then
29141 if Global_Mode /= Name_In_Out then
29142 Inconsistent_Mode_Error (Name_In_Out);
29145 elsif Contains (Out_Items, Item_Id) then
29146 if Global_Mode /= Name_Output then
29147 Inconsistent_Mode_Error (Name_Output);
29150 elsif Contains (Proof_In_Items, Item_Id) then
29153 -- The item does not appear in the corresponding Global pragma,
29154 -- it must be an extra (SPARK RM 7.2.4(3)).
29157 pragma Assert (Present (Global));
29158 Error_Msg_Sloc := Sloc (Global);
29160 ("extra global item & does not refine or repeat any "
29161 & "global item #", Item, Item_Id);
29164 end Check_Refined_Global_Item;
29170 -- Start of processing for Check_Refined_Global_List
29173 -- Do not perform this check in an instance because it was already
29174 -- performed successfully in the generic template.
29176 if In_Instance then
29179 elsif Nkind (List) = N_Null then
29182 -- Single global item declaration
29184 elsif Nkind (List) in N_Expanded_Name
29186 | N_Selected_Component
29188 Check_Refined_Global_Item (List, Global_Mode);
29190 -- Simple global list or moded global list declaration
29192 elsif Nkind (List) = N_Aggregate then
29194 -- The declaration of a simple global list appear as a collection
29197 if Present (Expressions (List)) then
29198 Item := First (Expressions (List));
29199 while Present (Item) loop
29200 Check_Refined_Global_Item (Item, Global_Mode);
29204 -- The declaration of a moded global list appears as a collection
29205 -- of component associations where individual choices denote
29208 elsif Present (Component_Associations (List)) then
29209 Item := First (Component_Associations (List));
29210 while Present (Item) loop
29211 Check_Refined_Global_List
29212 (List => Expression (Item),
29213 Global_Mode => Chars (First (Choices (Item))));
29221 raise Program_Error;
29227 raise Program_Error;
29229 end Check_Refined_Global_List;
29231 --------------------------
29232 -- Collect_Global_Items --
29233 --------------------------
29235 procedure Collect_Global_Items
29237 Mode : Name_Id := Name_Input)
29239 procedure Collect_Global_Item
29241 Item_Mode : Name_Id);
29242 -- Add a single item to the appropriate list. Item_Mode denotes the
29243 -- current mode in effect.
29245 -------------------------
29246 -- Collect_Global_Item --
29247 -------------------------
29249 procedure Collect_Global_Item
29251 Item_Mode : Name_Id)
29253 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
29254 -- The above handles abstract views of variables and states built
29255 -- for limited with clauses.
29258 -- Signal that the global list contains at least one abstract
29259 -- state with a visible refinement. Note that the refinement may
29260 -- be null in which case there are no constituents.
29262 if Ekind (Item_Id) = E_Abstract_State then
29263 if Has_Null_Visible_Refinement (Item_Id) then
29264 Has_Null_State := True;
29266 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
29267 Append_New_Elmt (Item_Id, States);
29269 if Item_Mode = Name_Input then
29270 Has_In_State := True;
29271 elsif Item_Mode = Name_In_Out then
29272 Has_In_Out_State := True;
29273 elsif Item_Mode = Name_Output then
29274 Has_Out_State := True;
29275 elsif Item_Mode = Name_Proof_In then
29276 Has_Proof_In_State := True;
29281 -- Record global items without full visible refinement found in
29282 -- pragma Global which should be repeated in the global refinement
29283 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
29285 if Ekind (Item_Id) /= E_Abstract_State
29286 or else not Has_Visible_Refinement (Item_Id)
29288 Append_New_Elmt (Item_Id, Repeat_Items);
29291 -- Add the item to the proper list
29293 if Item_Mode = Name_Input then
29294 Append_New_Elmt (Item_Id, In_Items);
29295 elsif Item_Mode = Name_In_Out then
29296 Append_New_Elmt (Item_Id, In_Out_Items);
29297 elsif Item_Mode = Name_Output then
29298 Append_New_Elmt (Item_Id, Out_Items);
29299 elsif Item_Mode = Name_Proof_In then
29300 Append_New_Elmt (Item_Id, Proof_In_Items);
29302 end Collect_Global_Item;
29308 -- Start of processing for Collect_Global_Items
29311 if Nkind (List) = N_Null then
29314 -- Single global item declaration
29316 elsif Nkind (List) in N_Expanded_Name
29318 | N_Selected_Component
29320 Collect_Global_Item (List, Mode);
29322 -- Single global list or moded global list declaration
29324 elsif Nkind (List) = N_Aggregate then
29326 -- The declaration of a simple global list appear as a collection
29329 if Present (Expressions (List)) then
29330 Item := First (Expressions (List));
29331 while Present (Item) loop
29332 Collect_Global_Item (Item, Mode);
29336 -- The declaration of a moded global list appears as a collection
29337 -- of component associations where individual choices denote mode.
29339 elsif Present (Component_Associations (List)) then
29340 Item := First (Component_Associations (List));
29341 while Present (Item) loop
29342 Collect_Global_Items
29343 (List => Expression (Item),
29344 Mode => Chars (First (Choices (Item))));
29352 raise Program_Error;
29355 -- To accommodate partial decoration of disabled SPARK features, this
29356 -- routine may be called with illegal input. If this is the case, do
29357 -- not raise Program_Error.
29362 end Collect_Global_Items;
29364 -------------------------
29365 -- Present_Then_Remove --
29366 -------------------------
29368 function Present_Then_Remove
29370 Item : Entity_Id) return Boolean
29375 if Present (List) then
29376 Elmt := First_Elmt (List);
29377 while Present (Elmt) loop
29378 if Node (Elmt) = Item then
29379 Remove_Elmt (List, Elmt);
29388 end Present_Then_Remove;
29390 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
29393 Ignore := Present_Then_Remove (List, Item);
29394 end Present_Then_Remove;
29396 -------------------------------
29397 -- Report_Extra_Constituents --
29398 -------------------------------
29400 procedure Report_Extra_Constituents is
29401 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
29402 -- Emit an error for every element of List
29404 ---------------------------------------
29405 -- Report_Extra_Constituents_In_List --
29406 ---------------------------------------
29408 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
29409 Constit_Elmt : Elmt_Id;
29412 if Present (List) then
29413 Constit_Elmt := First_Elmt (List);
29414 while Present (Constit_Elmt) loop
29415 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
29416 Next_Elmt (Constit_Elmt);
29419 end Report_Extra_Constituents_In_List;
29421 -- Start of processing for Report_Extra_Constituents
29424 -- Do not perform this check in an instance because it was already
29425 -- performed successfully in the generic template.
29427 if In_Instance then
29431 Report_Extra_Constituents_In_List (In_Constits);
29432 Report_Extra_Constituents_In_List (In_Out_Constits);
29433 Report_Extra_Constituents_In_List (Out_Constits);
29434 Report_Extra_Constituents_In_List (Proof_In_Constits);
29436 end Report_Extra_Constituents;
29438 --------------------------
29439 -- Report_Missing_Items --
29440 --------------------------
29442 procedure Report_Missing_Items is
29443 Item_Elmt : Elmt_Id;
29444 Item_Id : Entity_Id;
29447 -- Do not perform this check in an instance because it was already
29448 -- performed successfully in the generic template.
29450 if In_Instance then
29454 if Present (Repeat_Items) then
29455 Item_Elmt := First_Elmt (Repeat_Items);
29456 while Present (Item_Elmt) loop
29457 Item_Id := Node (Item_Elmt);
29458 SPARK_Msg_NE ("missing global item &", N, Item_Id);
29459 Next_Elmt (Item_Elmt);
29463 end Report_Missing_Items;
29467 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29468 Errors : constant Nat := Serious_Errors_Detected;
29470 No_Constit : Boolean;
29472 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
29475 -- Do not analyze the pragma multiple times
29477 if Is_Analyzed_Pragma (N) then
29481 Spec_Id := Unique_Defining_Entity (Body_Decl);
29483 -- Use the anonymous object as the proper spec when Refined_Global
29484 -- applies to the body of a single task type. The object carries the
29485 -- proper Chars as well as all non-refined versions of pragmas.
29487 if Is_Single_Concurrent_Type (Spec_Id) then
29488 Spec_Id := Anonymous_Object (Spec_Id);
29491 Global := Get_Pragma (Spec_Id, Pragma_Global);
29492 Items := Expression (Get_Argument (N, Spec_Id));
29494 -- The subprogram declaration lacks pragma Global. This renders
29495 -- Refined_Global useless as there is nothing to refine.
29497 if No (Global) then
29499 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
29500 & "& lacks aspect or pragma Global"), N, Spec_Id);
29504 -- Extract all relevant items from the corresponding Global pragma
29506 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
29508 -- Package and subprogram bodies are instantiated individually in
29509 -- a separate compiler pass. Due to this mode of instantiation, the
29510 -- refinement of a state may no longer be visible when a subprogram
29511 -- body contract is instantiated. Since the generic template is legal,
29512 -- do not perform this check in the instance to circumvent this oddity.
29514 if In_Instance then
29517 -- Non-instance case
29520 -- The corresponding Global pragma must mention at least one
29521 -- state with a visible refinement at the point Refined_Global
29522 -- is processed. States with null refinements need Refined_Global
29523 -- pragma (SPARK RM 7.2.4(2)).
29525 if not Has_In_State
29526 and then not Has_In_Out_State
29527 and then not Has_Out_State
29528 and then not Has_Proof_In_State
29529 and then not Has_Null_State
29532 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
29533 & "depend on abstract state with visible refinement"),
29537 -- The global refinement of inputs and outputs cannot be null when
29538 -- the corresponding Global pragma contains at least one item except
29539 -- in the case where we have states with null refinements.
29541 elsif Nkind (Items) = N_Null
29543 (Present (In_Items)
29544 or else Present (In_Out_Items)
29545 or else Present (Out_Items)
29546 or else Present (Proof_In_Items))
29547 and then not Has_Null_State
29550 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
29551 & "global items"), N, Spec_Id);
29556 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
29557 -- This ensures that the categorization of all refined global items is
29558 -- consistent with their role.
29560 Analyze_Global_In_Decl_Part (N);
29562 -- Perform all refinement checks with respect to completeness and mode
29565 if Serious_Errors_Detected = Errors then
29566 Check_Refined_Global_List (Items);
29569 -- Store the information that no constituent is used in the global
29570 -- refinement, prior to calling checking procedures which remove items
29571 -- from the list of constituents.
29575 and then No (In_Out_Constits)
29576 and then No (Out_Constits)
29577 and then No (Proof_In_Constits);
29579 -- For Input states with visible refinement, at least one constituent
29580 -- must be used as an Input in the global refinement.
29582 if Serious_Errors_Detected = Errors then
29583 Check_Input_States;
29586 -- Verify all possible completion variants for In_Out states with
29587 -- visible refinement.
29589 if Serious_Errors_Detected = Errors then
29590 Check_In_Out_States;
29593 -- For Output states with visible refinement, all constituents must be
29594 -- used as Outputs in the global refinement.
29596 if Serious_Errors_Detected = Errors then
29597 Check_Output_States;
29600 -- For Proof_In states with visible refinement, at least one constituent
29601 -- must be used as Proof_In in the global refinement.
29603 if Serious_Errors_Detected = Errors then
29604 Check_Proof_In_States;
29607 -- Emit errors for all constituents that belong to other states with
29608 -- visible refinement that do not appear in Global.
29610 if Serious_Errors_Detected = Errors then
29611 Report_Extra_Constituents;
29614 -- Emit errors for all items in Global that are not repeated in the
29615 -- global refinement and for which there is no full visible refinement
29616 -- and, in the case of states with partial visible refinement, no
29617 -- constituent is mentioned in the global refinement.
29619 if Serious_Errors_Detected = Errors then
29620 Report_Missing_Items;
29623 -- Emit an error if no constituent is used in the global refinement
29624 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
29625 -- one may be issued by the checking procedures. Do not perform this
29626 -- check in an instance because it was already performed successfully
29627 -- in the generic template.
29629 if Serious_Errors_Detected = Errors
29630 and then not In_Instance
29631 and then not Has_Null_State
29632 and then No_Constit
29634 SPARK_Msg_N ("missing refinement", N);
29638 Set_Is_Analyzed_Pragma (N);
29639 end Analyze_Refined_Global_In_Decl_Part;
29641 ----------------------------------------
29642 -- Analyze_Refined_State_In_Decl_Part --
29643 ----------------------------------------
29645 procedure Analyze_Refined_State_In_Decl_Part
29647 Freeze_Id : Entity_Id := Empty)
29649 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
29650 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
29651 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
29653 Available_States : Elist_Id := No_Elist;
29654 -- A list of all abstract states defined in the package declaration that
29655 -- are available for refinement. The list is used to report unrefined
29658 Body_States : Elist_Id := No_Elist;
29659 -- A list of all hidden states that appear in the body of the related
29660 -- package. The list is used to report unused hidden states.
29662 Constituents_Seen : Elist_Id := No_Elist;
29663 -- A list that contains all constituents processed so far. The list is
29664 -- used to detect multiple uses of the same constituent.
29666 Freeze_Posted : Boolean := False;
29667 -- A flag that controls the output of a freezing-related error (see use
29670 Refined_States_Seen : Elist_Id := No_Elist;
29671 -- A list that contains all refined states processed so far. The list is
29672 -- used to detect duplicate refinements.
29674 procedure Analyze_Refinement_Clause (Clause : Node_Id);
29675 -- Perform full analysis of a single refinement clause
29677 procedure Report_Unrefined_States (States : Elist_Id);
29678 -- Emit errors for all unrefined abstract states found in list States
29680 -------------------------------
29681 -- Analyze_Refinement_Clause --
29682 -------------------------------
29684 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
29685 AR_Constit : Entity_Id := Empty;
29686 AW_Constit : Entity_Id := Empty;
29687 ER_Constit : Entity_Id := Empty;
29688 EW_Constit : Entity_Id := Empty;
29689 -- The entities of external constituents that contain one of the
29690 -- following enabled properties: Async_Readers, Async_Writers,
29691 -- Effective_Reads and Effective_Writes.
29693 External_Constit_Seen : Boolean := False;
29694 -- Flag used to mark when at least one external constituent is part
29695 -- of the state refinement.
29697 Non_Null_Seen : Boolean := False;
29698 Null_Seen : Boolean := False;
29699 -- Flags used to detect multiple uses of null in a single clause or a
29700 -- mixture of null and non-null constituents.
29702 Part_Of_Constits : Elist_Id := No_Elist;
29703 -- A list of all candidate constituents subject to indicator Part_Of
29704 -- where the encapsulating state is the current state.
29707 State_Id : Entity_Id;
29708 -- The current state being refined
29710 procedure Analyze_Constituent (Constit : Node_Id);
29711 -- Perform full analysis of a single constituent
29713 procedure Check_External_Property
29714 (Prop_Nam : Name_Id;
29716 Constit : Entity_Id);
29717 -- Determine whether a property denoted by name Prop_Nam is present
29718 -- in the refined state. Emit an error if this is not the case. Flag
29719 -- Enabled should be set when the property applies to the refined
29720 -- state. Constit denotes the constituent (if any) which introduces
29721 -- the property in the refinement.
29723 procedure Match_State;
29724 -- Determine whether the state being refined appears in list
29725 -- Available_States. Emit an error when attempting to re-refine the
29726 -- state or when the state is not defined in the package declaration,
29727 -- otherwise remove the state from Available_States.
29729 procedure Report_Unused_Constituents (Constits : Elist_Id);
29730 -- Emit errors for all unused Part_Of constituents in list Constits
29732 -------------------------
29733 -- Analyze_Constituent --
29734 -------------------------
29736 procedure Analyze_Constituent (Constit : Node_Id) is
29737 procedure Match_Constituent (Constit_Id : Entity_Id);
29738 -- Determine whether constituent Constit denoted by its entity
29739 -- Constit_Id appears in Body_States. Emit an error when the
29740 -- constituent is not a valid hidden state of the related package
29741 -- or when it is used more than once. Otherwise remove the
29742 -- constituent from Body_States.
29744 -----------------------
29745 -- Match_Constituent --
29746 -----------------------
29748 procedure Match_Constituent (Constit_Id : Entity_Id) is
29749 procedure Collect_Constituent;
29750 -- Verify the legality of constituent Constit_Id and add it to
29751 -- the refinements of State_Id.
29753 -------------------------
29754 -- Collect_Constituent --
29755 -------------------------
29757 procedure Collect_Constituent is
29758 Constits : Elist_Id;
29761 -- The Ghost policy in effect at the point of abstract state
29762 -- declaration and constituent must match (SPARK RM 6.9(15))
29764 Check_Ghost_Refinement
29765 (State, State_Id, Constit, Constit_Id);
29767 -- A synchronized state must be refined by a synchronized
29768 -- object or another synchronized state (SPARK RM 9.6).
29770 if Is_Synchronized_State (State_Id)
29771 and then not Is_Synchronized_Object (Constit_Id)
29772 and then not Is_Synchronized_State (Constit_Id)
29775 ("constituent of synchronized state & must be "
29776 & "synchronized", Constit, State_Id);
29779 -- Add the constituent to the list of processed items to aid
29780 -- with the detection of duplicates.
29782 Append_New_Elmt (Constit_Id, Constituents_Seen);
29784 -- Collect the constituent in the list of refinement items
29785 -- and establish a relation between the refined state and
29788 Constits := Refinement_Constituents (State_Id);
29790 if No (Constits) then
29791 Constits := New_Elmt_List;
29792 Set_Refinement_Constituents (State_Id, Constits);
29795 Append_Elmt (Constit_Id, Constits);
29796 Set_Encapsulating_State (Constit_Id, State_Id);
29798 -- The state has at least one legal constituent, mark the
29799 -- start of the refinement region. The region ends when the
29800 -- body declarations end (see routine Analyze_Declarations).
29802 Set_Has_Visible_Refinement (State_Id);
29804 -- When the constituent is external, save its relevant
29805 -- property for further checks.
29807 if Async_Readers_Enabled (Constit_Id) then
29808 AR_Constit := Constit_Id;
29809 External_Constit_Seen := True;
29812 if Async_Writers_Enabled (Constit_Id) then
29813 AW_Constit := Constit_Id;
29814 External_Constit_Seen := True;
29817 if Effective_Reads_Enabled (Constit_Id) then
29818 ER_Constit := Constit_Id;
29819 External_Constit_Seen := True;
29822 if Effective_Writes_Enabled (Constit_Id) then
29823 EW_Constit := Constit_Id;
29824 External_Constit_Seen := True;
29826 end Collect_Constituent;
29830 State_Elmt : Elmt_Id;
29832 -- Start of processing for Match_Constituent
29835 -- Detect a duplicate use of a constituent
29837 if Contains (Constituents_Seen, Constit_Id) then
29839 ("duplicate use of constituent &", Constit, Constit_Id);
29843 -- The constituent is subject to a Part_Of indicator
29845 if Present (Encapsulating_State (Constit_Id)) then
29846 if Encapsulating_State (Constit_Id) = State_Id then
29847 Remove (Part_Of_Constits, Constit_Id);
29848 Collect_Constituent;
29850 -- The constituent is part of another state and is used
29851 -- incorrectly in the refinement of the current state.
29854 Error_Msg_Name_1 := Chars (State_Id);
29856 ("& cannot act as constituent of state %",
29857 Constit, Constit_Id);
29859 ("\Part_Of indicator specifies encapsulator &",
29860 Constit, Encapsulating_State (Constit_Id));
29865 Pack_Id : Entity_Id;
29866 Placement : State_Space_Kind;
29868 -- Find where the constituent lives with respect to the
29871 Find_Placement_In_State_Space
29872 (Item_Id => Constit_Id,
29873 Placement => Placement,
29874 Pack_Id => Pack_Id);
29876 -- The constituent is either part of the hidden state of
29877 -- the package or part of the visible state of a private
29878 -- child package, but lacks a Part_Of indicator.
29880 if (Placement = Private_State_Space
29881 and then Pack_Id = Spec_Id)
29883 (Placement = Visible_State_Space
29884 and then Is_Child_Unit (Pack_Id)
29885 and then not Is_Generic_Unit (Pack_Id)
29886 and then Is_Private_Descendant (Pack_Id))
29888 Error_Msg_Name_1 := Chars (State_Id);
29890 ("& cannot act as constituent of state %",
29891 Constit, Constit_Id);
29893 Sloc (Enclosing_Declaration (Constit_Id));
29895 ("\missing Part_Of indicator # should specify "
29896 & "encapsulator &",
29897 Constit, State_Id);
29899 -- The only other source of legal constituents is the
29900 -- body state space of the related package.
29903 if Present (Body_States) then
29904 State_Elmt := First_Elmt (Body_States);
29905 while Present (State_Elmt) loop
29907 -- Consume a valid constituent to signal that it
29908 -- has been encountered.
29910 if Node (State_Elmt) = Constit_Id then
29911 Remove_Elmt (Body_States, State_Elmt);
29912 Collect_Constituent;
29916 Next_Elmt (State_Elmt);
29920 -- At this point it is known that the constituent is
29921 -- not part of the package hidden state and cannot be
29922 -- used in a refinement (SPARK RM 7.2.2(9)).
29924 Error_Msg_Name_1 := Chars (Spec_Id);
29926 ("cannot use & in refinement, constituent is not a "
29927 & "hidden state of package %", Constit, Constit_Id);
29931 end Match_Constituent;
29935 Constit_Id : Entity_Id;
29936 Constits : Elist_Id;
29938 -- Start of processing for Analyze_Constituent
29941 -- Detect multiple uses of null in a single refinement clause or a
29942 -- mixture of null and non-null constituents.
29944 if Nkind (Constit) = N_Null then
29947 ("multiple null constituents not allowed", Constit);
29949 elsif Non_Null_Seen then
29951 ("cannot mix null and non-null constituents", Constit);
29956 -- Collect the constituent in the list of refinement items
29958 Constits := Refinement_Constituents (State_Id);
29960 if No (Constits) then
29961 Constits := New_Elmt_List;
29962 Set_Refinement_Constituents (State_Id, Constits);
29965 Append_Elmt (Constit, Constits);
29967 -- The state has at least one legal constituent, mark the
29968 -- start of the refinement region. The region ends when the
29969 -- body declarations end (see Analyze_Declarations).
29971 Set_Has_Visible_Refinement (State_Id);
29974 -- Non-null constituents
29977 Non_Null_Seen := True;
29981 ("cannot mix null and non-null constituents", Constit);
29985 Resolve_State (Constit);
29987 -- Ensure that the constituent denotes a valid state or a
29988 -- whole object (SPARK RM 7.2.2(5)).
29990 if Is_Entity_Name (Constit) then
29991 Constit_Id := Entity_Of (Constit);
29993 -- When a constituent is declared after a subprogram body
29994 -- that caused freezing of the related contract where
29995 -- pragma Refined_State resides, the constituent appears
29996 -- undefined and carries Any_Id as its entity.
29998 -- package body Pack
29999 -- with Refined_State => (State => Constit)
30002 -- with Refined_Global => (Input => Constit)
30010 if Constit_Id = Any_Id then
30011 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
30013 -- Emit a specialized info message when the contract of
30014 -- the related package body was "frozen" by another body.
30015 -- Note that it is not possible to precisely identify why
30016 -- the constituent is undefined because it is not visible
30017 -- when pragma Refined_State is analyzed. This message is
30018 -- a reasonable approximation.
30020 if Present (Freeze_Id) and then not Freeze_Posted then
30021 Freeze_Posted := True;
30023 Error_Msg_Name_1 := Chars (Body_Id);
30024 Error_Msg_Sloc := Sloc (Freeze_Id);
30026 ("body & declared # freezes the contract of %",
30029 ("\all constituents must be declared before body #",
30032 -- A misplaced constituent is a critical error because
30033 -- pragma Refined_Depends or Refined_Global depends on
30034 -- the proper link between a state and a constituent.
30035 -- Stop the compilation, as this leads to a multitude
30036 -- of misleading cascaded errors.
30038 raise Unrecoverable_Error;
30041 -- The constituent is a valid state or object
30043 elsif Ekind (Constit_Id) in
30044 E_Abstract_State | E_Constant | E_Variable
30046 Match_Constituent (Constit_Id);
30048 -- The variable may eventually become a constituent of a
30049 -- single protected/task type. Record the reference now
30050 -- and verify its legality when analyzing the contract of
30051 -- the variable (SPARK RM 9.3).
30053 if Ekind (Constit_Id) = E_Variable then
30054 Record_Possible_Part_Of_Reference
30055 (Var_Id => Constit_Id,
30059 -- Otherwise the constituent is illegal
30063 ("constituent & must denote object or state",
30064 Constit, Constit_Id);
30067 -- The constituent is illegal
30070 SPARK_Msg_N ("malformed constituent", Constit);
30073 end Analyze_Constituent;
30075 -----------------------------
30076 -- Check_External_Property --
30077 -----------------------------
30079 procedure Check_External_Property
30080 (Prop_Nam : Name_Id;
30082 Constit : Entity_Id)
30085 -- The property is missing in the declaration of the state, but
30086 -- a constituent is introducing it in the state refinement
30087 -- (SPARK RM 7.2.8(2)).
30089 if not Enabled and then Present (Constit) then
30090 Error_Msg_Name_1 := Prop_Nam;
30091 Error_Msg_Name_2 := Chars (State_Id);
30093 ("constituent & introduces external property % in refinement "
30094 & "of state %", State, Constit);
30096 Error_Msg_Sloc := Sloc (State_Id);
30098 ("\property is missing in abstract state declaration #",
30101 end Check_External_Property;
30107 procedure Match_State is
30108 State_Elmt : Elmt_Id;
30111 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
30113 if Contains (Refined_States_Seen, State_Id) then
30115 ("duplicate refinement of state &", State, State_Id);
30119 -- Inspect the abstract states defined in the package declaration
30120 -- looking for a match.
30122 State_Elmt := First_Elmt (Available_States);
30123 while Present (State_Elmt) loop
30125 -- A valid abstract state is being refined in the body. Add
30126 -- the state to the list of processed refined states to aid
30127 -- with the detection of duplicate refinements. Remove the
30128 -- state from Available_States to signal that it has already
30131 if Node (State_Elmt) = State_Id then
30132 Append_New_Elmt (State_Id, Refined_States_Seen);
30133 Remove_Elmt (Available_States, State_Elmt);
30137 Next_Elmt (State_Elmt);
30140 -- If we get here, we are refining a state that is not defined in
30141 -- the package declaration.
30143 Error_Msg_Name_1 := Chars (Spec_Id);
30145 ("cannot refine state, & is not defined in package %",
30149 --------------------------------
30150 -- Report_Unused_Constituents --
30151 --------------------------------
30153 procedure Report_Unused_Constituents (Constits : Elist_Id) is
30154 Constit_Elmt : Elmt_Id;
30155 Constit_Id : Entity_Id;
30156 Posted : Boolean := False;
30159 if Present (Constits) then
30160 Constit_Elmt := First_Elmt (Constits);
30161 while Present (Constit_Elmt) loop
30162 Constit_Id := Node (Constit_Elmt);
30164 -- Generate an error message of the form:
30166 -- state ... has unused Part_Of constituents
30167 -- abstract state ... defined at ...
30168 -- constant ... defined at ...
30169 -- variable ... defined at ...
30174 ("state & has unused Part_Of constituents",
30178 Error_Msg_Sloc := Sloc (Constit_Id);
30180 if Ekind (Constit_Id) = E_Abstract_State then
30182 ("\abstract state & defined #", State, Constit_Id);
30184 elsif Ekind (Constit_Id) = E_Constant then
30186 ("\constant & defined #", State, Constit_Id);
30189 pragma Assert (Ekind (Constit_Id) = E_Variable);
30190 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
30193 Next_Elmt (Constit_Elmt);
30196 end Report_Unused_Constituents;
30198 -- Local declarations
30200 Body_Ref : Node_Id;
30201 Body_Ref_Elmt : Elmt_Id;
30203 Extra_State : Node_Id;
30205 -- Start of processing for Analyze_Refinement_Clause
30208 -- A refinement clause appears as a component association where the
30209 -- sole choice is the state and the expressions are the constituents.
30210 -- This is a syntax error, always report.
30212 if Nkind (Clause) /= N_Component_Association then
30213 Error_Msg_N ("malformed state refinement clause", Clause);
30217 -- Analyze the state name of a refinement clause
30219 State := First (Choices (Clause));
30222 Resolve_State (State);
30224 -- Ensure that the state name denotes a valid abstract state that is
30225 -- defined in the spec of the related package.
30227 if Is_Entity_Name (State) then
30228 State_Id := Entity_Of (State);
30230 -- When the abstract state is undefined, it appears as Any_Id. Do
30231 -- not continue with the analysis of the clause.
30233 if State_Id = Any_Id then
30236 -- Catch any attempts to re-refine a state or refine a state that
30237 -- is not defined in the package declaration.
30239 elsif Ekind (State_Id) = E_Abstract_State then
30243 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
30247 -- References to a state with visible refinement are illegal.
30248 -- When nested packages are involved, detecting such references is
30249 -- tricky because pragma Refined_State is analyzed later than the
30250 -- offending pragma Depends or Global. References that occur in
30251 -- such nested context are stored in a list. Emit errors for all
30252 -- references found in Body_References (SPARK RM 6.1.4(8)).
30254 if Present (Body_References (State_Id)) then
30255 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
30256 while Present (Body_Ref_Elmt) loop
30257 Body_Ref := Node (Body_Ref_Elmt);
30259 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
30260 Error_Msg_Sloc := Sloc (State);
30261 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
30263 Next_Elmt (Body_Ref_Elmt);
30267 -- The state name is illegal. This is a syntax error, always report.
30270 Error_Msg_N ("malformed state name in refinement clause", State);
30274 -- A refinement clause may only refine one state at a time
30276 Extra_State := Next (State);
30278 if Present (Extra_State) then
30280 ("refinement clause cannot cover multiple states", Extra_State);
30283 -- Replicate the Part_Of constituents of the refined state because
30284 -- the algorithm will consume items.
30286 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
30288 -- Analyze all constituents of the refinement. Multiple constituents
30289 -- appear as an aggregate.
30291 Constit := Expression (Clause);
30293 if Nkind (Constit) = N_Aggregate then
30294 if Present (Component_Associations (Constit)) then
30296 ("constituents of refinement clause must appear in "
30297 & "positional form", Constit);
30299 else pragma Assert (Present (Expressions (Constit)));
30300 Constit := First (Expressions (Constit));
30301 while Present (Constit) loop
30302 Analyze_Constituent (Constit);
30307 -- Various forms of a single constituent. Note that these may include
30308 -- malformed constituents.
30311 Analyze_Constituent (Constit);
30314 -- Verify that external constituents do not introduce new external
30315 -- property in the state refinement (SPARK RM 7.2.8(2)).
30317 if Is_External_State (State_Id) then
30318 Check_External_Property
30319 (Prop_Nam => Name_Async_Readers,
30320 Enabled => Async_Readers_Enabled (State_Id),
30321 Constit => AR_Constit);
30323 Check_External_Property
30324 (Prop_Nam => Name_Async_Writers,
30325 Enabled => Async_Writers_Enabled (State_Id),
30326 Constit => AW_Constit);
30328 Check_External_Property
30329 (Prop_Nam => Name_Effective_Reads,
30330 Enabled => Effective_Reads_Enabled (State_Id),
30331 Constit => ER_Constit);
30333 Check_External_Property
30334 (Prop_Nam => Name_Effective_Writes,
30335 Enabled => Effective_Writes_Enabled (State_Id),
30336 Constit => EW_Constit);
30338 -- When a refined state is not external, it should not have external
30339 -- constituents (SPARK RM 7.2.8(1)).
30341 elsif External_Constit_Seen then
30343 ("non-external state & cannot contain external constituents in "
30344 & "refinement", State, State_Id);
30347 -- Ensure that all Part_Of candidate constituents have been mentioned
30348 -- in the refinement clause.
30350 Report_Unused_Constituents (Part_Of_Constits);
30352 -- Avoid a cascading error reporting a missing refinement by adding a
30353 -- dummy constituent.
30355 if No (Refinement_Constituents (State_Id)) then
30356 Set_Refinement_Constituents (State_Id, New_Elmt_List (Any_Id));
30359 -- At this point the refinement might be dummy, but must be
30360 -- well-formed, to prevent cascaded errors.
30362 pragma Assert (Has_Null_Refinement (State_Id)
30364 Has_Non_Null_Refinement (State_Id));
30365 end Analyze_Refinement_Clause;
30367 -----------------------------
30368 -- Report_Unrefined_States --
30369 -----------------------------
30371 procedure Report_Unrefined_States (States : Elist_Id) is
30372 State_Elmt : Elmt_Id;
30375 if Present (States) then
30376 State_Elmt := First_Elmt (States);
30377 while Present (State_Elmt) loop
30379 ("abstract state & must be refined", Node (State_Elmt));
30381 Next_Elmt (State_Elmt);
30384 end Report_Unrefined_States;
30386 -- Local declarations
30388 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
30391 -- Start of processing for Analyze_Refined_State_In_Decl_Part
30394 -- Do not analyze the pragma multiple times
30396 if Is_Analyzed_Pragma (N) then
30400 -- Save the scenario for examination by the ABE Processing phase
30402 Record_Elaboration_Scenario (N);
30404 -- Replicate the abstract states declared by the package because the
30405 -- matching algorithm will consume states.
30407 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
30409 -- Gather all abstract states and objects declared in the visible
30410 -- state space of the package body. These items must be utilized as
30411 -- constituents in a state refinement.
30413 Body_States := Collect_Body_States (Body_Id);
30415 -- Multiple non-null state refinements appear as an aggregate
30417 if Nkind (Clauses) = N_Aggregate then
30418 if Present (Expressions (Clauses)) then
30420 ("state refinements must appear as component associations",
30423 else pragma Assert (Present (Component_Associations (Clauses)));
30424 Clause := First (Component_Associations (Clauses));
30425 while Present (Clause) loop
30426 Analyze_Refinement_Clause (Clause);
30431 -- Various forms of a single state refinement. Note that these may
30432 -- include malformed refinements.
30435 Analyze_Refinement_Clause (Clauses);
30438 -- List all abstract states that were left unrefined
30440 Report_Unrefined_States (Available_States);
30442 Set_Is_Analyzed_Pragma (N);
30443 end Analyze_Refined_State_In_Decl_Part;
30445 ---------------------------------------------
30446 -- Analyze_Subprogram_Variant_In_Decl_Part --
30447 ---------------------------------------------
30449 -- WARNING: This routine manages Ghost regions. Return statements must be
30450 -- replaced by gotos which jump to the end of the routine and restore the
30453 procedure Analyze_Subprogram_Variant_In_Decl_Part
30455 Freeze_Id : Entity_Id := Empty)
30457 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
30458 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
30460 procedure Analyze_Variant (Variant : Node_Id);
30461 -- Verify the legality of a single contract case
30463 ---------------------
30464 -- Analyze_Variant --
30465 ---------------------
30467 procedure Analyze_Variant (Variant : Node_Id) is
30468 Direction : Node_Id;
30471 Extra_Direction : Node_Id;
30474 if Nkind (Variant) /= N_Component_Association then
30475 Error_Msg_N ("wrong syntax in subprogram variant", Variant);
30479 Direction := First (Choices (Variant));
30480 Expr := Expression (Variant);
30482 -- Each variant must have exactly one direction
30484 Extra_Direction := Next (Direction);
30486 if Present (Extra_Direction) then
30488 ("subprogram variant case must have exactly one direction",
30492 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
30494 if Nkind (Direction) = N_Identifier then
30495 if Chars (Direction) not in Name_Decreases
30499 Error_Msg_N ("wrong direction", Direction);
30502 Error_Msg_N ("wrong syntax", Direction);
30505 Errors := Serious_Errors_Detected;
30507 -- Preanalyze_Assert_Expression, but without enforcing any of the two
30508 -- acceptable types.
30510 Preanalyze_Assert_Expression (Expr);
30512 -- Expression of a discrete type is allowed. Nothing more to check
30513 -- for structural variants.
30515 if Is_Discrete_Type (Etype (Expr))
30516 or else Chars (Direction) = Name_Structural
30520 -- Expression of a Big_Integer type (or its ghost variant) is only
30521 -- allowed in Decreases clause.
30524 Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer)
30526 Is_RTE (Base_Type (Etype (Expr)), RO_GH_Big_Integer)
30528 if Chars (Direction) = Name_Increases then
30530 ("Subprogram_Variant with Big_Integer can only decrease",
30534 -- Expression of other types is not allowed
30537 Error_Msg_N ("expected a discrete or Big_Integer type", Expr);
30540 -- Emit a clarification message when the variant expression
30541 -- contains at least one undefined reference, possibly due
30542 -- to contract freezing.
30544 if Errors /= Serious_Errors_Detected
30545 and then Present (Freeze_Id)
30546 and then Has_Undefined_Reference (Expr)
30548 Contract_Freeze_Error (Spec_Id, Freeze_Id);
30550 end Analyze_Variant;
30554 Variants : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
30556 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
30557 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
30558 -- Save the Ghost-related attributes to restore on exit
30561 Restore_Scope : Boolean := False;
30563 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
30566 -- Do not analyze the pragma multiple times
30568 if Is_Analyzed_Pragma (N) then
30572 -- Set the Ghost mode in effect from the pragma. Due to the delayed
30573 -- analysis of the pragma, the Ghost mode at point of declaration and
30574 -- point of analysis may not necessarily be the same. Use the mode in
30575 -- effect at the point of declaration.
30577 Set_Ghost_Mode (N);
30579 -- Single and multiple contract cases must appear in aggregate form. If
30580 -- this is not the case, then either the parser of the analysis of the
30581 -- pragma failed to produce an aggregate, e.g. when the contract is
30582 -- "null" or a "(null record)".
30585 (if Nkind (Variants) = N_Aggregate
30586 then Null_Record_Present (Variants)
30587 xor (Present (Component_Associations (Variants))
30589 Present (Expressions (Variants)))
30590 else Nkind (Variants) = N_Null);
30592 -- Only "change_direction => discrete_expression" clauses are allowed
30594 if Nkind (Variants) = N_Aggregate
30595 and then Present (Component_Associations (Variants))
30596 and then No (Expressions (Variants))
30599 -- Check that the expression is a proper aggregate (no parentheses)
30601 if Paren_Count (Variants) /= 0 then
30602 Error_Msg_F -- CODEFIX
30603 ("redundant parentheses", Variants);
30606 -- Ensure that the formal parameters are visible when analyzing all
30607 -- clauses. This falls out of the general rule of aspects pertaining
30608 -- to subprogram declarations.
30610 if not In_Open_Scopes (Spec_Id) then
30611 Restore_Scope := True;
30612 Push_Scope (Spec_Id);
30614 if Is_Generic_Subprogram (Spec_Id) then
30615 Install_Generic_Formals (Spec_Id);
30617 Install_Formals (Spec_Id);
30621 Variant := First (Component_Associations (Variants));
30622 while Present (Variant) loop
30623 Analyze_Variant (Variant);
30625 if Chars (First (Choices (Variant))) = Name_Structural
30626 and then List_Length (Component_Associations (Variants)) > 1
30629 ("Structural variant shall be the only variant", Variant);
30635 if Restore_Scope then
30639 -- Currently it is not possible to inline Subprogram_Variant on a
30640 -- subprogram subject to pragma Inline_Always.
30642 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
30644 -- Otherwise the pragma is illegal
30647 Error_Msg_N ("wrong syntax for subprogram variant", N);
30650 Set_Is_Analyzed_Pragma (N);
30652 Restore_Ghost_Region (Saved_GM, Saved_IGR);
30653 end Analyze_Subprogram_Variant_In_Decl_Part;
30655 ------------------------------------
30656 -- Analyze_Test_Case_In_Decl_Part --
30657 ------------------------------------
30659 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
30660 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
30661 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
30663 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
30664 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
30665 -- denoted by Arg_Nam.
30667 ------------------------------
30668 -- Preanalyze_Test_Case_Arg --
30669 ------------------------------
30671 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
30675 -- Preanalyze the original aspect argument for a generic subprogram
30676 -- to properly capture global references.
30678 if Is_Generic_Subprogram (Spec_Id) then
30682 Arg_Nam => Arg_Nam,
30683 From_Aspect => True);
30685 if Present (Arg) then
30686 Preanalyze_Assert_Expression
30687 (Expression (Arg), Standard_Boolean);
30691 Arg := Test_Case_Arg (N, Arg_Nam);
30693 if Present (Arg) then
30694 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
30696 end Preanalyze_Test_Case_Arg;
30700 Restore_Scope : Boolean := False;
30702 -- Start of processing for Analyze_Test_Case_In_Decl_Part
30705 -- Do not analyze the pragma multiple times
30707 if Is_Analyzed_Pragma (N) then
30711 -- Ensure that the formal parameters are visible when analyzing all
30712 -- clauses. This falls out of the general rule of aspects pertaining
30713 -- to subprogram declarations.
30715 if not In_Open_Scopes (Spec_Id) then
30716 Restore_Scope := True;
30717 Push_Scope (Spec_Id);
30719 if Is_Generic_Subprogram (Spec_Id) then
30720 Install_Generic_Formals (Spec_Id);
30722 Install_Formals (Spec_Id);
30726 Preanalyze_Test_Case_Arg (Name_Requires);
30727 Preanalyze_Test_Case_Arg (Name_Ensures);
30729 if Restore_Scope then
30733 -- Currently it is not possible to inline pre/postconditions on a
30734 -- subprogram subject to pragma Inline_Always.
30736 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
30738 Set_Is_Analyzed_Pragma (N);
30739 end Analyze_Test_Case_In_Decl_Part;
30745 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
30750 if Present (List) then
30751 Elmt := First_Elmt (List);
30752 while Present (Elmt) loop
30753 if Nkind (Node (Elmt)) = N_Defining_Identifier then
30756 Id := Entity_Of (Node (Elmt));
30759 if Id = Item_Id then
30770 -----------------------------------
30771 -- Build_Pragma_Check_Equivalent --
30772 -----------------------------------
30774 function Build_Pragma_Check_Equivalent
30776 Subp_Id : Entity_Id := Empty;
30777 Inher_Id : Entity_Id := Empty;
30778 Keep_Pragma_Id : Boolean := False) return Node_Id
30780 function Suppress_Reference (N : Node_Id) return Traverse_Result;
30781 -- Detect whether node N references a formal parameter subject to
30782 -- pragma Unreferenced. If this is the case, set Comes_From_Source
30783 -- to False to suppress the generation of a reference when analyzing
30786 ------------------------
30787 -- Suppress_Reference --
30788 ------------------------
30790 function Suppress_Reference (N : Node_Id) return Traverse_Result is
30791 Formal : Entity_Id;
30794 if Is_Entity_Name (N) and then Present (Entity (N)) then
30795 Formal := Entity (N);
30797 -- The formal parameter is subject to pragma Unreferenced. Prevent
30798 -- the generation of references by resetting the Comes_From_Source
30801 if Is_Formal (Formal)
30802 and then Has_Pragma_Unreferenced (Formal)
30804 Set_Comes_From_Source (N, False);
30809 end Suppress_Reference;
30811 procedure Suppress_References is
30812 new Traverse_Proc (Suppress_Reference);
30816 Loc : constant Source_Ptr := Sloc (Prag);
30817 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30818 Check_Prag : Node_Id;
30822 -- Start of processing for Build_Pragma_Check_Equivalent
30825 -- When the pre- or postcondition is inherited, map the formals of the
30826 -- inherited subprogram to those of the current subprogram. In addition,
30827 -- map primitive operations of the parent type into the corresponding
30828 -- primitive operations of the descendant.
30830 if Present (Inher_Id) then
30831 pragma Assert (Present (Subp_Id));
30833 Update_Primitives_Mapping (Inher_Id, Subp_Id);
30835 -- Use generic machinery to copy inherited pragma, as if it were an
30836 -- instantiation, resetting source locations appropriately, so that
30837 -- expressions inside the inherited pragma use chained locations.
30838 -- This is used in particular in GNATprove to locate precisely
30839 -- messages on a given inherited pragma.
30841 Set_Copied_Sloc_For_Inherited_Pragma
30842 (Unit_Declaration_Node (Subp_Id), Inher_Id);
30843 Check_Prag := New_Copy_Tree (Source => Prag);
30845 -- Build the inherited class-wide condition
30847 Build_Class_Wide_Expression
30848 (Pragma_Or_Expr => Check_Prag,
30850 Par_Subp => Inher_Id,
30851 Adjust_Sloc => True);
30853 -- If not an inherited condition simply copy the original pragma
30856 Check_Prag := New_Copy_Tree (Source => Prag);
30859 -- Mark the pragma as being internally generated and reset the Analyzed
30862 Set_Analyzed (Check_Prag, False);
30863 Set_Comes_From_Source (Check_Prag, False);
30865 -- The tree of the original pragma may contain references to the
30866 -- formal parameters of the related subprogram. At the same time
30867 -- the corresponding body may mark the formals as unreferenced:
30869 -- procedure Proc (Formal : ...)
30870 -- with Pre => Formal ...;
30872 -- procedure Proc (Formal : ...) is
30873 -- pragma Unreferenced (Formal);
30876 -- This creates problems because all pragma Check equivalents are
30877 -- analyzed at the end of the body declarations. Since all source
30878 -- references have already been accounted for, reset any references
30879 -- to such formals in the generated pragma Check equivalent.
30881 Suppress_References (Check_Prag);
30883 if Present (Corresponding_Aspect (Prag)) then
30884 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
30889 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
30890 -- the copied pragma in the newly created pragma, convert the copy into
30891 -- pragma Check by correcting the name and adding a check_kind argument.
30893 if not Keep_Pragma_Id then
30894 Set_Class_Present (Check_Prag, False);
30896 Set_Pragma_Identifier
30897 (Check_Prag, Make_Identifier (Loc, Name_Check));
30899 Prepend_To (Pragma_Argument_Associations (Check_Prag),
30900 Make_Pragma_Argument_Association (Loc,
30901 Expression => Make_Identifier (Loc, Nam)));
30904 -- Update the error message when the pragma is inherited
30906 if Present (Inher_Id) then
30907 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
30909 if Chars (Msg_Arg) = Name_Message then
30910 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
30912 -- Insert "inherited" to improve the error message
30914 if Name_Buffer (1 .. 8) = "failed p" then
30915 Insert_Str_In_Name_Buffer ("inherited ", 8);
30916 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
30922 end Build_Pragma_Check_Equivalent;
30924 -----------------------------
30925 -- Check_Applicable_Policy --
30926 -----------------------------
30928 procedure Check_Applicable_Policy (N : Node_Id) is
30932 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
30935 -- No effect if not valid assertion kind name
30937 if not Is_Valid_Assertion_Kind (Ename) then
30941 -- Loop through entries in check policy list
30943 PP := Opt.Check_Policy_List;
30944 while Present (PP) loop
30946 PPA : constant List_Id := Pragma_Argument_Associations (PP);
30947 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
30951 or else Pnm = Name_Assertion
30952 or else (Pnm = Name_Statement_Assertions
30953 and then Ename in Name_Assert
30954 | Name_Assert_And_Cut
30956 | Name_Loop_Invariant
30957 | Name_Loop_Variant)
30959 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
30965 -- In CodePeer mode and GNATprove mode, we need to
30966 -- consider all assertions, unless they are disabled.
30967 -- Force Is_Checked on ignored assertions, in particular
30968 -- because transformations of the AST may depend on
30969 -- assertions being checked (e.g. the translation of
30970 -- attribute 'Loop_Entry).
30972 if CodePeer_Mode or GNATprove_Mode then
30973 Set_Is_Checked (N, True);
30974 Set_Is_Ignored (N, False);
30976 Set_Is_Checked (N, False);
30977 Set_Is_Ignored (N, True);
30983 Set_Is_Checked (N, True);
30984 Set_Is_Ignored (N, False);
30986 when Name_Disable =>
30987 Set_Is_Ignored (N, True);
30988 Set_Is_Checked (N, False);
30989 Set_Is_Disabled (N, True);
30991 -- That should be exhaustive, the null here is a defence
30992 -- against a malformed tree from previous errors.
31001 PP := Next_Pragma (PP);
31005 -- If there are no specific entries that matched, then we let the
31006 -- setting of assertions govern. Note that this provides the needed
31007 -- compatibility with the RM for the cases of assertion, invariant,
31008 -- precondition, predicate, and postcondition. Note also that
31009 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
31011 if Assertions_Enabled then
31012 Set_Is_Checked (N, True);
31013 Set_Is_Ignored (N, False);
31015 Set_Is_Checked (N, False);
31016 Set_Is_Ignored (N, True);
31018 end Check_Applicable_Policy;
31020 -------------------------------
31021 -- Check_External_Properties --
31022 -------------------------------
31024 procedure Check_External_Properties
31031 type Properties is array (Positive range 1 .. 4) of Boolean;
31032 type Combinations is array (Positive range <>) of Properties;
31033 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
31034 -- Effective_Reads properties and their combinations, respectively.
31036 Specified : constant Properties := (AR, AW, EW, ER);
31037 -- External properties, as given by the Item pragma
31039 Allowed : constant Combinations :=
31040 (1 => (True, False, True, False),
31041 2 => (False, True, False, True),
31042 3 => (True, False, False, False),
31043 4 => (False, True, False, False),
31044 5 => (True, True, True, False),
31045 6 => (True, True, False, True),
31046 7 => (True, True, False, False),
31047 8 => (True, True, True, True));
31048 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
31051 -- Check if the specified properties match any of the allowed
31052 -- combination; if not, then emit an error.
31054 for J in Allowed'Range loop
31055 if Specified = Allowed (J) then
31061 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
31063 end Check_External_Properties;
31069 function Check_Kind (Nam : Name_Id) return Name_Id is
31073 -- Loop through entries in check policy list
31075 PP := Opt.Check_Policy_List;
31076 while Present (PP) loop
31078 PPA : constant List_Id := Pragma_Argument_Associations (PP);
31079 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
31083 or else (Pnm = Name_Assertion
31084 and then Is_Valid_Assertion_Kind (Nam))
31085 or else (Pnm = Name_Statement_Assertions
31086 and then Nam in Name_Assert
31087 | Name_Assert_And_Cut
31089 | Name_Loop_Invariant
31090 | Name_Loop_Variant)
31092 case Chars (Get_Pragma_Arg (Last (PPA))) is
31101 return Name_Ignore;
31103 when Name_Disable =>
31104 return Name_Disable;
31107 raise Program_Error;
31111 PP := Next_Pragma (PP);
31116 -- If there are no specific entries that matched, then we let the
31117 -- setting of assertions govern. Note that this provides the needed
31118 -- compatibility with the RM for the cases of assertion, invariant,
31119 -- precondition, predicate, and postcondition.
31121 if Assertions_Enabled then
31124 return Name_Ignore;
31128 ---------------------------
31129 -- Check_Missing_Part_Of --
31130 ---------------------------
31132 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
31133 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
31134 -- Determine whether a package denoted by Pack_Id declares at least one
31137 -----------------------
31138 -- Has_Visible_State --
31139 -----------------------
31141 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
31142 Item_Id : Entity_Id;
31145 -- Traverse the entity chain of the package trying to find at least
31146 -- one visible abstract state, variable or a package [instantiation]
31147 -- that declares a visible state.
31149 Item_Id := First_Entity (Pack_Id);
31150 while Present (Item_Id)
31151 and then not In_Private_Part (Item_Id)
31153 -- Do not consider internally generated items
31155 if not Comes_From_Source (Item_Id) then
31158 -- Do not consider generic formals or their corresponding actuals
31159 -- because they are not part of a visible state. Note that both
31160 -- entities are marked as hidden.
31162 elsif Is_Hidden (Item_Id) then
31165 -- A visible state has been found. Note that constants are not
31166 -- considered here because it is not possible to determine whether
31167 -- they depend on variable input. This check is left to the SPARK
31170 elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
31173 -- Recursively peek into nested packages and instantiations
31175 elsif Ekind (Item_Id) = E_Package
31176 and then Has_Visible_State (Item_Id)
31181 Next_Entity (Item_Id);
31185 end Has_Visible_State;
31189 Pack_Id : Entity_Id;
31190 Placement : State_Space_Kind;
31192 -- Start of processing for Check_Missing_Part_Of
31195 -- Do not consider abstract states, variables or package instantiations
31196 -- coming from an instance as those always inherit the Part_Of indicator
31197 -- of the instance itself.
31199 if In_Instance then
31202 -- Do not consider internally generated entities as these can never
31203 -- have a Part_Of indicator.
31205 elsif not Comes_From_Source (Item_Id) then
31208 -- Perform these checks only when SPARK_Mode is enabled as they will
31209 -- interfere with standard Ada rules and produce false positives.
31211 elsif SPARK_Mode /= On then
31214 -- Do not consider constants, because the compiler cannot accurately
31215 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
31216 -- act as a hidden state of a package.
31218 elsif Ekind (Item_Id) = E_Constant then
31222 -- Find where the abstract state, variable or package instantiation
31223 -- lives with respect to the state space.
31225 Find_Placement_In_State_Space
31226 (Item_Id => Item_Id,
31227 Placement => Placement,
31228 Pack_Id => Pack_Id);
31230 -- Items that appear in a non-package construct (subprogram, block, etc)
31231 -- do not require a Part_Of indicator because they can never act as a
31234 if Placement = Not_In_Package then
31237 -- An item declared in the body state space of a package always act as a
31238 -- constituent and does not need explicit Part_Of indicator.
31240 elsif Placement = Body_State_Space then
31243 -- In general an item declared in the visible state space of a package
31244 -- does not require a Part_Of indicator. The only exception is when the
31245 -- related package is a nongeneric private child unit, in which case
31246 -- Part_Of must denote a state in the parent unit or in one of its
31249 elsif Placement = Visible_State_Space then
31250 if Is_Child_Unit (Pack_Id)
31251 and then not Is_Generic_Unit (Pack_Id)
31252 and then Is_Private_Descendant (Pack_Id)
31254 -- A package instantiation does not need a Part_Of indicator when
31255 -- the related generic template has no visible state.
31257 if Ekind (Item_Id) = E_Package
31258 and then Is_Generic_Instance (Item_Id)
31259 and then not Has_Visible_State (Item_Id)
31263 -- All other cases require Part_Of
31267 ("indicator Part_Of is required in this context "
31268 & "(SPARK RM 7.2.6(3))", Item_Id);
31269 Error_Msg_Name_1 := Chars (Pack_Id);
31271 ("\& is declared in the visible part of private child "
31272 & "unit %", Item_Id);
31276 -- When the item appears in the private state space of a package, it
31277 -- must be a part of some state declared by the said package.
31279 else pragma Assert (Placement = Private_State_Space);
31281 -- The related package does not declare a state, the item cannot act
31282 -- as a Part_Of constituent.
31284 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
31287 -- A package instantiation does not need a Part_Of indicator when the
31288 -- related generic template has no visible state.
31290 elsif Ekind (Item_Id) = E_Package
31291 and then Is_Generic_Instance (Item_Id)
31292 and then not Has_Visible_State (Item_Id)
31296 -- All other cases require Part_Of
31299 Error_Msg_Code := GEC_Required_Part_Of;
31301 ("indicator Part_Of is required in this context '[[]']",
31303 Error_Msg_Name_1 := Chars (Pack_Id);
31305 ("\& is declared in the private part of package %", Item_Id);
31308 end Check_Missing_Part_Of;
31310 ---------------------------------------------------
31311 -- Check_Postcondition_Use_In_Inlined_Subprogram --
31312 ---------------------------------------------------
31314 procedure Check_Postcondition_Use_In_Inlined_Subprogram
31316 Spec_Id : Entity_Id)
31319 if Warn_On_Redundant_Constructs
31320 and then Has_Pragma_Inline_Always (Spec_Id)
31321 and then Assertions_Enabled
31322 and then not Back_End_Inlining
31324 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
31326 if From_Aspect_Specification (Prag) then
31328 ("aspect % not enforced on inlined subprogram &?r?",
31329 Corresponding_Aspect (Prag), Spec_Id);
31332 ("pragma % not enforced on inlined subprogram &?r?",
31336 end Check_Postcondition_Use_In_Inlined_Subprogram;
31338 -------------------------------------
31339 -- Check_State_And_Constituent_Use --
31340 -------------------------------------
31342 procedure Check_State_And_Constituent_Use
31343 (States : Elist_Id;
31344 Constits : Elist_Id;
31347 Constit_Elmt : Elmt_Id;
31348 Constit_Id : Entity_Id;
31349 State_Id : Entity_Id;
31352 -- Nothing to do if there are no states or constituents
31354 if No (States) or else No (Constits) then
31358 -- Inspect the list of constituents and try to determine whether its
31359 -- encapsulating state is in list States.
31361 Constit_Elmt := First_Elmt (Constits);
31362 while Present (Constit_Elmt) loop
31363 Constit_Id := Node (Constit_Elmt);
31365 -- Determine whether the constituent is part of an encapsulating
31366 -- state that appears in the same context and if this is the case,
31367 -- emit an error (SPARK RM 7.2.6(7)).
31369 State_Id := Find_Encapsulating_State (States, Constit_Id);
31371 if Present (State_Id) then
31372 Error_Msg_Name_1 := Chars (Constit_Id);
31374 ("cannot mention state & and its constituent % in the same "
31375 & "context", Context, State_Id);
31379 Next_Elmt (Constit_Elmt);
31381 end Check_State_And_Constituent_Use;
31383 ---------------------------------------------
31384 -- Collect_Inherited_Class_Wide_Conditions --
31385 ---------------------------------------------
31387 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
31388 Parent_Subp : constant Entity_Id :=
31389 Ultimate_Alias (Overridden_Operation (Subp));
31390 -- The Overridden_Operation may itself be inherited and as such have no
31391 -- explicit contract.
31393 Prags : constant Node_Id := Contract (Parent_Subp);
31394 In_Spec_Expr : Boolean := In_Spec_Expression;
31395 Installed : Boolean;
31397 New_Prag : Node_Id;
31400 Installed := False;
31402 -- Iterate over the contract of the overridden subprogram to find all
31403 -- inherited class-wide pre- and postconditions.
31405 if Present (Prags) then
31406 Prag := Pre_Post_Conditions (Prags);
31408 while Present (Prag) loop
31409 if Pragma_Name_Unmapped (Prag)
31410 in Name_Precondition | Name_Postcondition
31411 and then Class_Present (Prag)
31413 -- The generated pragma must be analyzed in the context of
31414 -- the subprogram, to make its formals visible. In addition,
31415 -- we must inhibit freezing and full analysis because the
31416 -- controlling type of the subprogram is not frozen yet, and
31417 -- may have further primitives.
31419 if not Installed then
31422 Install_Formals (Subp);
31423 In_Spec_Expr := In_Spec_Expression;
31424 In_Spec_Expression := True;
31428 Build_Pragma_Check_Equivalent
31429 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
31431 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
31432 Preanalyze (New_Prag);
31434 -- Prevent further analysis in subsequent processing of the
31435 -- current list of declarations
31437 Set_Analyzed (New_Prag);
31440 Prag := Next_Pragma (Prag);
31444 In_Spec_Expression := In_Spec_Expr;
31448 end Collect_Inherited_Class_Wide_Conditions;
31450 ---------------------------------------
31451 -- Collect_Subprogram_Inputs_Outputs --
31452 ---------------------------------------
31454 procedure Collect_Subprogram_Inputs_Outputs
31455 (Subp_Id : Entity_Id;
31456 Synthesize : Boolean := False;
31457 Subp_Inputs : in out Elist_Id;
31458 Subp_Outputs : in out Elist_Id;
31459 Global_Seen : out Boolean)
31461 procedure Collect_Dependency_Clause (Clause : Node_Id);
31462 -- Collect all relevant items from a dependency clause
31464 procedure Collect_Global_List
31466 Mode : Name_Id := Name_Input);
31467 -- Collect all relevant items from a global list
31469 -------------------------------
31470 -- Collect_Dependency_Clause --
31471 -------------------------------
31473 procedure Collect_Dependency_Clause (Clause : Node_Id) is
31474 procedure Collect_Dependency_Item
31476 Is_Input : Boolean);
31477 -- Add an item to the proper subprogram input or output collection
31479 -----------------------------
31480 -- Collect_Dependency_Item --
31481 -----------------------------
31483 procedure Collect_Dependency_Item
31485 Is_Input : Boolean)
31490 -- Nothing to collect when the item is null
31492 if Nkind (Item) = N_Null then
31495 -- Ditto for attribute 'Result
31497 elsif Is_Attribute_Result (Item) then
31500 -- Multiple items appear as an aggregate
31502 elsif Nkind (Item) = N_Aggregate then
31503 Extra := First (Expressions (Item));
31504 while Present (Extra) loop
31505 Collect_Dependency_Item (Extra, Is_Input);
31509 -- Otherwise this is a solitary item
31513 Append_New_Elmt (Item, Subp_Inputs);
31515 Append_New_Elmt (Item, Subp_Outputs);
31518 end Collect_Dependency_Item;
31520 -- Start of processing for Collect_Dependency_Clause
31523 if Nkind (Clause) = N_Null then
31526 -- A dependency clause appears as component association
31528 elsif Nkind (Clause) = N_Component_Association then
31529 Collect_Dependency_Item
31530 (Item => Expression (Clause),
31533 Collect_Dependency_Item
31534 (Item => First (Choices (Clause)),
31535 Is_Input => False);
31537 -- To accommodate partial decoration of disabled SPARK features, this
31538 -- routine may be called with illegal input. If this is the case, do
31539 -- not raise Program_Error.
31544 end Collect_Dependency_Clause;
31546 -------------------------
31547 -- Collect_Global_List --
31548 -------------------------
31550 procedure Collect_Global_List
31552 Mode : Name_Id := Name_Input)
31554 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
31555 -- Add an item to the proper subprogram input or output collection
31557 -------------------------
31558 -- Collect_Global_Item --
31559 -------------------------
31561 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
31563 if Mode in Name_In_Out | Name_Input then
31564 Append_New_Elmt (Item, Subp_Inputs);
31567 if Mode in Name_In_Out | Name_Output then
31568 Append_New_Elmt (Item, Subp_Outputs);
31570 end Collect_Global_Item;
31577 -- Start of processing for Collect_Global_List
31580 if Nkind (List) = N_Null then
31583 -- Single global item declaration
31585 elsif Nkind (List) in N_Expanded_Name
31587 | N_Selected_Component
31589 Collect_Global_Item (List, Mode);
31591 -- Simple global list or moded global list declaration
31593 elsif Nkind (List) = N_Aggregate then
31594 if Present (Expressions (List)) then
31595 Item := First (Expressions (List));
31596 while Present (Item) loop
31597 Collect_Global_Item (Item, Mode);
31602 Assoc := First (Component_Associations (List));
31603 while Present (Assoc) loop
31604 Collect_Global_List
31605 (List => Expression (Assoc),
31606 Mode => Chars (First (Choices (Assoc))));
31611 -- To accommodate partial decoration of disabled SPARK features, this
31612 -- routine may be called with illegal input. If this is the case, do
31613 -- not raise Program_Error.
31618 end Collect_Global_List;
31625 Formal : Entity_Id;
31627 Spec_Id : Entity_Id := Empty;
31628 Subp_Decl : Node_Id;
31631 -- Start of processing for Collect_Subprogram_Inputs_Outputs
31634 Global_Seen := False;
31636 -- Process all formal parameters of entries, [generic] subprograms, and
31639 if Ekind (Subp_Id) in E_Entry
31642 | E_Generic_Function
31643 | E_Generic_Procedure
31645 | E_Subprogram_Body
31647 Subp_Decl := Unit_Declaration_Node (Subp_Id);
31648 Spec_Id := Unique_Defining_Entity (Subp_Decl);
31650 -- Process all formal parameters
31652 Formal := First_Formal (Spec_Id);
31653 while Present (Formal) loop
31654 if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
31655 Append_New_Elmt (Formal, Subp_Inputs);
31657 -- IN parameters of procedures and protected entries can act as
31658 -- outputs when the related type is access-to-variable.
31660 if Ekind (Formal) = E_In_Parameter
31661 and then (Ekind (Spec_Id) not in E_Function
31662 | E_Generic_Function
31663 or else Is_Function_With_Side_Effects (Spec_Id))
31664 and then Is_Access_Variable (Etype (Formal))
31666 Append_New_Elmt (Formal, Subp_Outputs);
31670 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
31671 Append_New_Elmt (Formal, Subp_Outputs);
31673 -- OUT parameters can act as inputs when the related type is
31674 -- tagged, unconstrained array or unconstrained record.
31676 if Ekind (Formal) = E_Out_Parameter
31677 and then Is_Unconstrained_Or_Tagged_Item (Formal)
31679 Append_New_Elmt (Formal, Subp_Inputs);
31683 Next_Formal (Formal);
31686 -- Otherwise the input denotes a task type, a task body, or the
31687 -- anonymous object created for a single task type.
31689 elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
31690 or else Is_Single_Task_Object (Subp_Id)
31692 Subp_Decl := Declaration_Node (Subp_Id);
31693 Spec_Id := Unique_Defining_Entity (Subp_Decl);
31696 -- When processing an entry, subprogram or task body, look for pragmas
31697 -- Refined_Depends and Refined_Global as they specify the inputs and
31700 if Is_Entry_Body (Subp_Id)
31701 or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
31703 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
31704 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
31706 -- Subprogram declaration or stand-alone body case, look for pragmas
31707 -- Depends and Global.
31710 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
31711 Global := Get_Pragma (Spec_Id, Pragma_Global);
31714 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
31715 -- because it provides finer granularity of inputs and outputs.
31717 if Present (Global) then
31718 Global_Seen := True;
31719 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
31721 -- When the related subprogram lacks pragma [Refined_]Global, fall back
31722 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
31723 -- the inputs and outputs from [Refined_]Depends.
31725 elsif Synthesize and then Present (Depends) then
31726 Clauses := Expression (Get_Argument (Depends, Spec_Id));
31728 -- Multiple dependency clauses appear as an aggregate
31730 if Nkind (Clauses) = N_Aggregate then
31731 Clause := First (Component_Associations (Clauses));
31732 while Present (Clause) loop
31733 Collect_Dependency_Clause (Clause);
31737 -- Otherwise this is a single dependency clause
31740 Collect_Dependency_Clause (Clauses);
31744 -- The current instance of a protected type acts as a formal parameter
31745 -- of mode IN for functions and IN OUT for entries and procedures
31746 -- (SPARK RM 6.1.4).
31748 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
31749 Typ := Scope (Spec_Id);
31751 -- Use the anonymous object when the type is single protected
31753 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
31754 Typ := Anonymous_Object (Typ);
31757 Append_New_Elmt (Typ, Subp_Inputs);
31759 if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
31760 Append_New_Elmt (Typ, Subp_Outputs);
31763 -- The current instance of a task type acts as a formal parameter of
31764 -- mode IN OUT (SPARK RM 6.1.4).
31766 elsif Ekind (Spec_Id) = E_Task_Type then
31769 -- Use the anonymous object when the type is single task
31771 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
31772 Typ := Anonymous_Object (Typ);
31775 Append_New_Elmt (Typ, Subp_Inputs);
31776 Append_New_Elmt (Typ, Subp_Outputs);
31778 elsif Is_Single_Task_Object (Spec_Id) then
31779 Append_New_Elmt (Spec_Id, Subp_Inputs);
31780 Append_New_Elmt (Spec_Id, Subp_Outputs);
31782 end Collect_Subprogram_Inputs_Outputs;
31784 ---------------------------
31785 -- Contract_Freeze_Error --
31786 ---------------------------
31788 procedure Contract_Freeze_Error
31789 (Contract_Id : Entity_Id;
31790 Freeze_Id : Entity_Id)
31793 Error_Msg_Name_1 := Chars (Contract_Id);
31794 Error_Msg_Sloc := Sloc (Freeze_Id);
31797 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
31799 ("\all contractual items must be declared before body #", Contract_Id);
31800 end Contract_Freeze_Error;
31802 ---------------------------------
31803 -- Delay_Config_Pragma_Analyze --
31804 ---------------------------------
31806 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
31808 return Pragma_Name_Unmapped (N)
31809 in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
31810 end Delay_Config_Pragma_Analyze;
31812 -----------------------
31813 -- Duplication_Error --
31814 -----------------------
31816 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
31817 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
31818 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
31821 Error_Msg_Sloc := Sloc (Prev);
31822 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
31824 -- Emit a precise message to distinguish between source pragmas and
31825 -- pragmas generated from aspects. The ordering of the two pragmas is
31829 -- Prag -- duplicate
31831 -- No error is emitted when both pragmas come from aspects because this
31832 -- is already detected by the general aspect analysis mechanism.
31834 if Prag_From_Asp and Prev_From_Asp then
31836 elsif Prag_From_Asp then
31837 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
31838 elsif Prev_From_Asp then
31839 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
31841 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
31843 end Duplication_Error;
31845 ------------------------------
31846 -- Find_Encapsulating_State --
31847 ------------------------------
31849 function Find_Encapsulating_State
31850 (States : Elist_Id;
31851 Constit_Id : Entity_Id) return Entity_Id
31853 State_Id : Entity_Id;
31856 -- Since a constituent may be part of a larger constituent set, climb
31857 -- the encapsulating state chain looking for a state that appears in
31860 State_Id := Encapsulating_State (Constit_Id);
31861 while Present (State_Id) loop
31862 if Contains (States, State_Id) then
31866 State_Id := Encapsulating_State (State_Id);
31870 end Find_Encapsulating_State;
31872 --------------------------
31873 -- Find_Related_Context --
31874 --------------------------
31876 function Find_Related_Context
31878 Do_Checks : Boolean := False) return Node_Id
31883 -- If the pragma comes from an aspect on a compilation unit that is a
31884 -- package instance, then return the original package instantiation
31887 if Nkind (Parent (Prag)) = N_Compilation_Unit_Aux then
31889 Get_Unit_Instantiation_Node
31890 (Defining_Entity (Unit (Enclosing_Comp_Unit_Node (Prag))));
31893 Stmt := Prev (Prag);
31894 while Present (Stmt) loop
31896 -- Skip prior pragmas, but check for duplicates
31898 if Nkind (Stmt) = N_Pragma then
31900 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
31907 -- Skip internally generated code
31909 elsif not Comes_From_Source (Stmt)
31910 and then not Comes_From_Source (Original_Node (Stmt))
31913 -- The anonymous object created for a single concurrent type is a
31914 -- suitable context.
31916 if Nkind (Stmt) = N_Object_Declaration
31917 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
31922 -- Return the current source construct
31932 end Find_Related_Context;
31934 --------------------------------------
31935 -- Find_Related_Declaration_Or_Body --
31936 --------------------------------------
31938 function Find_Related_Declaration_Or_Body
31940 Do_Checks : Boolean := False) return Node_Id
31942 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
31944 procedure Expression_Function_Error;
31945 -- Emit an error concerning pragma Prag that illegaly applies to an
31946 -- expression function.
31948 -------------------------------
31949 -- Expression_Function_Error --
31950 -------------------------------
31952 procedure Expression_Function_Error is
31954 Error_Msg_Name_1 := Prag_Nam;
31956 -- Emit a precise message to distinguish between source pragmas and
31957 -- pragmas generated from aspects.
31959 if From_Aspect_Specification (Prag) then
31961 ("aspect % cannot apply to a standalone expression function",
31965 ("pragma % cannot apply to a standalone expression function",
31968 end Expression_Function_Error;
31972 Context : constant Node_Id := Parent (Prag);
31975 Look_For_Body : constant Boolean :=
31976 Prag_Nam in Name_Refined_Depends
31977 | Name_Refined_Global
31978 | Name_Refined_Post
31979 | Name_Refined_State;
31980 -- Refinement pragmas must be associated with a subprogram body [stub]
31982 -- Start of processing for Find_Related_Declaration_Or_Body
31985 Stmt := Prev (Prag);
31986 while Present (Stmt) loop
31988 -- Skip prior pragmas, but check for duplicates. Pragmas produced
31989 -- by splitting a complex pre/postcondition are not considered to
31992 if Nkind (Stmt) = N_Pragma then
31994 and then not Split_PPC (Stmt)
31995 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
32002 -- Emit an error when a refinement pragma appears on an expression
32003 -- function without a completion.
32006 and then Look_For_Body
32007 and then Nkind (Stmt) = N_Subprogram_Declaration
32008 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
32009 and then not Has_Completion (Defining_Entity (Stmt))
32011 Expression_Function_Error;
32014 -- The refinement pragma applies to a subprogram body stub
32016 elsif Look_For_Body
32017 and then Nkind (Stmt) = N_Subprogram_Body_Stub
32021 -- Skip internally generated code
32023 elsif not Comes_From_Source (Stmt) then
32025 -- The anonymous object created for a single concurrent type is a
32026 -- suitable context.
32028 if Nkind (Stmt) = N_Object_Declaration
32029 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
32033 elsif Nkind (Stmt) = N_Subprogram_Declaration then
32035 -- The subprogram declaration is an internally generated spec
32036 -- for an expression function.
32038 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
32041 -- The subprogram declaration is an internally generated spec
32042 -- for a stand-alone subprogram body declared inside a
32045 elsif Present (Corresponding_Body (Stmt))
32046 and then Comes_From_Source (Corresponding_Body (Stmt))
32047 and then Is_Protected_Type (Current_Scope)
32051 -- The subprogram is actually an instance housed within an
32052 -- anonymous wrapper package.
32054 elsif Present (Generic_Parent (Specification (Stmt))) then
32057 -- Ada 2022: contract on formal subprogram or on generated
32058 -- Access_Subprogram_Wrapper, which appears after the related
32059 -- Access_Subprogram declaration.
32061 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
32062 and then Ada_Version >= Ada_2022
32066 elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
32067 and then Ada_Version >= Ada_2022
32073 -- Return the current construct which is either a subprogram body,
32074 -- a subprogram declaration or is illegal.
32083 -- If we fall through, then the pragma was either the first declaration
32084 -- or it was preceded by other pragmas and no source constructs.
32086 -- The pragma is associated with a library-level subprogram
32088 if Nkind (Context) = N_Compilation_Unit_Aux then
32089 return Unit (Parent (Context));
32091 -- The pragma appears inside the declarations of an entry body
32093 elsif Nkind (Context) = N_Entry_Body then
32096 -- The pragma appears inside the statements of a subprogram body at
32097 -- some nested level.
32099 elsif Is_Statement (Context)
32100 and then Present (Enclosing_HSS (Context))
32102 return Parent (Enclosing_HSS (Context));
32104 -- The pragma appears directly in the statements of a subprogram body
32106 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
32107 return Parent (Context);
32109 -- The pragma appears inside the declarative part of a package body
32111 elsif Nkind (Context) = N_Package_Body then
32114 -- The pragma appears inside the declarative part of a subprogram body
32116 elsif Nkind (Context) = N_Subprogram_Body then
32119 -- The pragma appears inside the declarative part of a task body
32121 elsif Nkind (Context) = N_Task_Body then
32124 -- The pragma appears inside the visible part of a package specification
32126 elsif Nkind (Context) = N_Package_Specification then
32127 return Parent (Context);
32129 -- The pragma is a byproduct of aspect expansion, return the related
32130 -- context of the original aspect. This case has a lower priority as
32131 -- the above circuitry pinpoints precisely the related context.
32133 elsif Present (Corresponding_Aspect (Prag)) then
32134 return Parent (Corresponding_Aspect (Prag));
32136 -- No candidate subprogram [body] found
32141 end Find_Related_Declaration_Or_Body;
32143 ----------------------------------
32144 -- Find_Related_Package_Or_Body --
32145 ----------------------------------
32147 function Find_Related_Package_Or_Body
32149 Do_Checks : Boolean := False) return Node_Id
32151 Context : constant Node_Id := Parent (Prag);
32152 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
32156 Stmt := Prev (Prag);
32157 while Present (Stmt) loop
32159 -- Skip prior pragmas, but check for duplicates
32161 if Nkind (Stmt) = N_Pragma then
32162 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
32168 -- Skip internally generated code
32170 elsif not Comes_From_Source (Stmt) then
32171 if Nkind (Stmt) = N_Subprogram_Declaration then
32173 -- The subprogram declaration is an internally generated spec
32174 -- for an expression function.
32176 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
32179 -- The subprogram is actually an instance housed within an
32180 -- anonymous wrapper package.
32182 elsif Present (Generic_Parent (Specification (Stmt))) then
32187 -- Return the current source construct which is illegal
32196 -- If we fall through, then the pragma was either the first declaration
32197 -- or it was preceded by other pragmas and no source constructs.
32199 -- The pragma is associated with a package. The immediate context in
32200 -- this case is the specification of the package.
32202 if Nkind (Context) = N_Package_Specification then
32203 return Parent (Context);
32205 -- The pragma appears in the declarations of a package body
32207 elsif Nkind (Context) = N_Package_Body then
32210 -- The pragma appears in the statements of a package body
32212 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
32213 and then Nkind (Parent (Context)) = N_Package_Body
32215 return Parent (Context);
32217 -- The pragma is a byproduct of aspect expansion, return the related
32218 -- context of the original aspect. This case has a lower priority as
32219 -- the above circuitry pinpoints precisely the related context.
32221 elsif Present (Corresponding_Aspect (Prag)) then
32222 return Parent (Corresponding_Aspect (Prag));
32224 -- No candidate package [body] found
32229 end Find_Related_Package_Or_Body;
32235 function Get_Argument
32237 Context_Id : Entity_Id := Empty) return Node_Id
32239 Args : constant List_Id := Pragma_Argument_Associations (Prag);
32242 -- Use the expression of the original aspect when analyzing the template
32243 -- of a generic unit. In both cases the aspect's tree must be decorated
32244 -- to save the global references in the generic context.
32246 if From_Aspect_Specification (Prag)
32247 and then Present (Context_Id)
32249 Is_Generic_Declaration_Or_Body (Unit_Declaration_Node (Context_Id))
32251 return Corresponding_Aspect (Prag);
32253 -- Otherwise use the expression of the pragma
32255 elsif Present (Args) then
32256 return First (Args);
32263 -------------------------
32264 -- Get_Base_Subprogram --
32265 -------------------------
32267 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
32269 -- Follow subprogram renaming chain
32271 if Is_Subprogram (Def_Id)
32272 and then Parent_Kind (Declaration_Node (Def_Id)) =
32273 N_Subprogram_Renaming_Declaration
32274 and then Present (Alias (Def_Id))
32276 return Alias (Def_Id);
32280 end Get_Base_Subprogram;
32282 -------------------------
32283 -- Get_SPARK_Mode_Type --
32284 -------------------------
32286 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
32296 -- Any other argument is illegal. Assume that no SPARK mode applies
32297 -- to avoid potential cascaded errors.
32302 end Get_SPARK_Mode_Type;
32304 ------------------------------------
32305 -- Get_SPARK_Mode_From_Annotation --
32306 ------------------------------------
32308 function Get_SPARK_Mode_From_Annotation
32309 (N : Node_Id) return SPARK_Mode_Type
32314 if Nkind (N) = N_Aspect_Specification then
32315 Mode := Expression (N);
32317 else pragma Assert (Nkind (N) = N_Pragma);
32318 Mode := First (Pragma_Argument_Associations (N));
32320 if Present (Mode) then
32321 Mode := Get_Pragma_Arg (Mode);
32325 -- Aspect or pragma SPARK_Mode specifies an explicit mode
32327 if Present (Mode) then
32328 if Nkind (Mode) = N_Identifier then
32329 return Get_SPARK_Mode_Type (Chars (Mode));
32331 -- In case of a malformed aspect or pragma, return the default None
32337 -- Otherwise the lack of an expression defaults SPARK_Mode to On
32342 end Get_SPARK_Mode_From_Annotation;
32344 ---------------------------
32345 -- Has_Extra_Parentheses --
32346 ---------------------------
32348 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
32352 -- The aggregate should not have an expression list because a clause
32353 -- is always interpreted as a component association. The only way an
32354 -- expression list can sneak in is by adding extra parentheses around
32355 -- the individual clauses:
32357 -- Depends (Output => Input) -- proper form
32358 -- Depends ((Output => Input)) -- extra parentheses
32360 -- Since the extra parentheses are not allowed by the syntax of the
32361 -- pragma, flag them now to avoid emitting misleading errors down the
32364 if Nkind (Clause) = N_Aggregate
32365 and then Present (Expressions (Clause))
32367 Expr := First (Expressions (Clause));
32368 while Present (Expr) loop
32370 -- A dependency clause surrounded by extra parentheses appears
32371 -- as an aggregate of component associations with an optional
32372 -- Paren_Count set.
32374 if Nkind (Expr) = N_Aggregate
32375 and then Present (Component_Associations (Expr))
32378 ("dependency clause contains extra parentheses", Expr);
32380 -- Otherwise the expression is a malformed construct
32383 SPARK_Msg_N ("malformed dependency clause", Expr);
32393 end Has_Extra_Parentheses;
32399 procedure Initialize is
32402 Compile_Time_Warnings_Errors.Init;
32411 Dummy := Dummy + 1;
32414 -----------------------------
32415 -- Is_Config_Static_String --
32416 -----------------------------
32418 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
32420 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
32421 -- This is an internal recursive function that is just like the outer
32422 -- function except that it adds the string to the name buffer rather
32423 -- than placing the string in the name buffer.
32425 ------------------------------
32426 -- Add_Config_Static_String --
32427 ------------------------------
32429 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
32436 if Nkind (N) = N_Op_Concat then
32437 if Add_Config_Static_String (Left_Opnd (N)) then
32438 N := Right_Opnd (N);
32444 if Nkind (N) /= N_String_Literal then
32445 Error_Msg_N ("string literal expected for pragma argument", N);
32449 for J in 1 .. String_Length (Strval (N)) loop
32450 C := Get_String_Char (Strval (N), J);
32452 if not In_Character_Range (C) then
32454 ("string literal contains invalid wide character",
32455 Sloc (N) + 1 + Source_Ptr (J));
32459 Add_Char_To_Name_Buffer (Get_Character (C));
32464 end Add_Config_Static_String;
32466 -- Start of processing for Is_Config_Static_String
32471 return Add_Config_Static_String (Arg);
32472 end Is_Config_Static_String;
32474 -------------------------------
32475 -- Is_Elaboration_SPARK_Mode --
32476 -------------------------------
32478 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
32481 (Nkind (N) = N_Pragma
32482 and then Pragma_Name (N) = Name_SPARK_Mode
32483 and then Is_List_Member (N));
32485 -- Pragma SPARK_Mode affects the elaboration of a package body when it
32486 -- appears in the statement part of the body.
32489 Present (Parent (N))
32490 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
32491 and then List_Containing (N) = Statements (Parent (N))
32492 and then Present (Parent (Parent (N)))
32493 and then Nkind (Parent (Parent (N))) = N_Package_Body;
32494 end Is_Elaboration_SPARK_Mode;
32496 -----------------------
32497 -- Is_Enabled_Pragma --
32498 -----------------------
32500 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
32504 if Present (Prag) then
32505 Arg := First (Pragma_Argument_Associations (Prag));
32507 if Present (Arg) then
32508 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
32510 -- The lack of a Boolean argument automatically enables the pragma
32516 -- The pragma is missing, therefore it is not enabled
32521 end Is_Enabled_Pragma;
32523 -----------------------------------------
32524 -- Is_Non_Significant_Pragma_Reference --
32525 -----------------------------------------
32527 -- This function makes use of the following static table which indicates
32528 -- whether appearance of some name in a given pragma is to be considered
32529 -- as a reference for the purposes of warnings about unreferenced objects.
32531 -- -1 indicates that appearance in any argument is significant
32532 -- 0 indicates that appearance in any argument is not significant
32533 -- +n indicates that appearance as argument n is significant, but all
32534 -- other arguments are not significant
32535 -- 9n arguments from n on are significant, before n insignificant
32537 Sig_Flags : constant array (Pragma_Id) of Int :=
32538 (Pragma_Abort_Defer => -1,
32539 Pragma_Abstract_State => -1,
32540 Pragma_Ada_83 => -1,
32541 Pragma_Ada_95 => -1,
32542 Pragma_Ada_05 => -1,
32543 Pragma_Ada_2005 => -1,
32544 Pragma_Ada_12 => -1,
32545 Pragma_Ada_2012 => -1,
32546 Pragma_Ada_2022 => -1,
32547 Pragma_Aggregate_Individually_Assign => 0,
32548 Pragma_All_Calls_Remote => -1,
32549 Pragma_Allow_Integer_Address => -1,
32550 Pragma_Always_Terminates => -1,
32551 Pragma_Annotate => 93,
32552 Pragma_Assert => -1,
32553 Pragma_Assert_And_Cut => -1,
32554 Pragma_Assertion_Policy => 0,
32555 Pragma_Assume => -1,
32556 Pragma_Assume_No_Invalid_Values => 0,
32557 Pragma_Async_Readers => 0,
32558 Pragma_Async_Writers => 0,
32559 Pragma_Asynchronous => 0,
32560 Pragma_Atomic => 0,
32561 Pragma_Atomic_Components => 0,
32562 Pragma_Attach_Handler => -1,
32563 Pragma_Attribute_Definition => 92,
32564 Pragma_Check => -1,
32565 Pragma_Check_Float_Overflow => 0,
32566 Pragma_Check_Name => 0,
32567 Pragma_Check_Policy => 0,
32568 Pragma_CPP_Class => 0,
32569 Pragma_CPP_Constructor => 0,
32570 Pragma_CPP_Virtual => 0,
32571 Pragma_CPP_Vtable => 0,
32573 Pragma_C_Pass_By_Copy => 0,
32574 Pragma_Comment => -1,
32575 Pragma_Common_Object => 0,
32576 Pragma_CUDA_Device => -1,
32577 Pragma_CUDA_Execute => -1,
32578 Pragma_CUDA_Global => -1,
32579 Pragma_Compile_Time_Error => -1,
32580 Pragma_Compile_Time_Warning => -1,
32581 Pragma_Complete_Representation => 0,
32582 Pragma_Complex_Representation => 0,
32583 Pragma_Component_Alignment => 0,
32584 Pragma_Constant_After_Elaboration => 0,
32585 Pragma_Contract_Cases => -1,
32586 Pragma_Controlled => 0,
32587 Pragma_Convention => 0,
32588 Pragma_Convention_Identifier => 0,
32589 Pragma_Deadline_Floor => -1,
32590 Pragma_Debug => -1,
32591 Pragma_Debug_Policy => 0,
32592 Pragma_Default_Initial_Condition => -1,
32593 Pragma_Default_Scalar_Storage_Order => 0,
32594 Pragma_Default_Storage_Pool => 0,
32595 Pragma_Depends => -1,
32596 Pragma_Detect_Blocking => 0,
32597 Pragma_Disable_Atomic_Synchronization => 0,
32598 Pragma_Discard_Names => 0,
32599 Pragma_Dispatching_Domain => -1,
32600 Pragma_Effective_Reads => 0,
32601 Pragma_Effective_Writes => 0,
32602 Pragma_Elaborate => 0,
32603 Pragma_Elaborate_All => 0,
32604 Pragma_Elaborate_Body => 0,
32605 Pragma_Elaboration_Checks => 0,
32606 Pragma_Eliminate => 0,
32607 Pragma_Enable_Atomic_Synchronization => 0,
32608 Pragma_Exceptional_Cases => -1,
32609 Pragma_Export => -1,
32610 Pragma_Export_Function => -1,
32611 Pragma_Export_Object => -1,
32612 Pragma_Export_Procedure => -1,
32613 Pragma_Export_Valued_Procedure => -1,
32614 Pragma_Extend_System => -1,
32615 Pragma_Extensions_Allowed => 0,
32616 Pragma_Extensions_Visible => 0,
32617 Pragma_External => -1,
32618 Pragma_External_Name_Casing => 0,
32619 Pragma_Fast_Math => 0,
32620 Pragma_Favor_Top_Level => 0,
32621 Pragma_Finalize_Storage_Only => 0,
32623 Pragma_Global => -1,
32624 Pragma_GNAT_Annotate => 93,
32625 Pragma_Ident => -1,
32626 Pragma_Ignore_Pragma => 0,
32627 Pragma_Implementation_Defined => -1,
32628 Pragma_Implemented => -1,
32629 Pragma_Implicit_Packing => 0,
32630 Pragma_Import => 93,
32631 Pragma_Import_Function => 0,
32632 Pragma_Import_Object => 0,
32633 Pragma_Import_Procedure => 0,
32634 Pragma_Import_Valued_Procedure => 0,
32635 Pragma_Independent => 0,
32636 Pragma_Independent_Components => 0,
32637 Pragma_Initial_Condition => -1,
32638 Pragma_Initialize_Scalars => 0,
32639 Pragma_Initializes => -1,
32640 Pragma_Inline => 0,
32641 Pragma_Inline_Always => 0,
32642 Pragma_Inline_Generic => 0,
32643 Pragma_Inspection_Point => -1,
32644 Pragma_Interface => 92,
32645 Pragma_Interface_Name => 0,
32646 Pragma_Interrupt_Handler => -1,
32647 Pragma_Interrupt_Priority => -1,
32648 Pragma_Interrupt_State => -1,
32649 Pragma_Invariant => -1,
32650 Pragma_Keep_Names => 0,
32651 Pragma_License => 0,
32652 Pragma_Link_With => -1,
32653 Pragma_Linker_Alias => -1,
32654 Pragma_Linker_Constructor => -1,
32655 Pragma_Linker_Destructor => -1,
32656 Pragma_Linker_Options => -1,
32657 Pragma_Linker_Section => -1,
32659 Pragma_Lock_Free => 0,
32660 Pragma_Locking_Policy => 0,
32661 Pragma_Loop_Invariant => -1,
32662 Pragma_Loop_Optimize => 0,
32663 Pragma_Loop_Variant => -1,
32664 Pragma_Machine_Attribute => -1,
32666 Pragma_Main_Storage => -1,
32667 Pragma_Max_Entry_Queue_Depth => 0,
32668 Pragma_Max_Entry_Queue_Length => 0,
32669 Pragma_Max_Queue_Length => 0,
32670 Pragma_Memory_Size => 0,
32671 Pragma_No_Body => 0,
32672 Pragma_No_Caching => 0,
32673 Pragma_No_Component_Reordering => -1,
32674 Pragma_No_Elaboration_Code_All => 0,
32675 Pragma_No_Heap_Finalization => 0,
32676 Pragma_No_Inline => 0,
32677 Pragma_No_Return => 0,
32678 Pragma_No_Run_Time => -1,
32679 Pragma_No_Strict_Aliasing => -1,
32680 Pragma_No_Tagged_Streams => 0,
32681 Pragma_Normalize_Scalars => 0,
32682 Pragma_Obsolescent => 0,
32683 Pragma_Optimize => 0,
32684 Pragma_Optimize_Alignment => 0,
32685 Pragma_Ordered => 0,
32686 Pragma_Overflow_Mode => 0,
32687 Pragma_Overriding_Renamings => 0,
32690 Pragma_Part_Of => 0,
32691 Pragma_Partition_Elaboration_Policy => 0,
32692 Pragma_Passive => 0,
32693 Pragma_Persistent_BSS => 0,
32695 Pragma_Postcondition => -1,
32696 Pragma_Post_Class => -1,
32698 Pragma_Precondition => -1,
32699 Pragma_Predicate => -1,
32700 Pragma_Predicate_Failure => -1,
32701 Pragma_Preelaborable_Initialization => -1,
32702 Pragma_Preelaborate => 0,
32703 Pragma_Prefix_Exception_Messages => 0,
32704 Pragma_Pre_Class => -1,
32705 Pragma_Priority => -1,
32706 Pragma_Priority_Specific_Dispatching => 0,
32707 Pragma_Profile => 0,
32708 Pragma_Profile_Warnings => 0,
32709 Pragma_Propagate_Exceptions => 0,
32710 Pragma_Provide_Shift_Operators => 0,
32711 Pragma_Psect_Object => 0,
32713 Pragma_Pure_Function => 0,
32714 Pragma_Queuing_Policy => 0,
32715 Pragma_Rational => 0,
32716 Pragma_Ravenscar => 0,
32717 Pragma_Refined_Depends => -1,
32718 Pragma_Refined_Global => -1,
32719 Pragma_Refined_Post => -1,
32720 Pragma_Refined_State => 0,
32721 Pragma_Relative_Deadline => 0,
32722 Pragma_Remote_Access_Type => -1,
32723 Pragma_Remote_Call_Interface => -1,
32724 Pragma_Remote_Types => -1,
32725 Pragma_Rename_Pragma => 0,
32726 Pragma_Restricted_Run_Time => 0,
32727 Pragma_Restriction_Warnings => 0,
32728 Pragma_Restrictions => 0,
32729 Pragma_Reviewable => -1,
32730 Pragma_Side_Effects => 0,
32731 Pragma_Secondary_Stack_Size => -1,
32732 Pragma_Share_Generic => 0,
32733 Pragma_Shared => 0,
32734 Pragma_Shared_Passive => 0,
32735 Pragma_Short_Circuit_And_Or => 0,
32736 Pragma_Short_Descriptors => 0,
32737 Pragma_Simple_Storage_Pool_Type => 0,
32738 Pragma_Source_File_Name => 0,
32739 Pragma_Source_File_Name_Project => 0,
32740 Pragma_Source_Reference => 0,
32741 Pragma_SPARK_Mode => 0,
32742 Pragma_Static_Elaboration_Desired => 0,
32743 Pragma_Storage_Size => -1,
32744 Pragma_Storage_Unit => 0,
32745 Pragma_Stream_Convert => 0,
32746 Pragma_Style_Checks => 0,
32747 Pragma_Subprogram_Variant => -1,
32748 Pragma_Subtitle => 0,
32749 Pragma_Suppress => 0,
32750 Pragma_Suppress_All => 0,
32751 Pragma_Suppress_Debug_Info => 0,
32752 Pragma_Suppress_Exception_Locations => 0,
32753 Pragma_Suppress_Initialization => 0,
32754 Pragma_System_Name => 0,
32755 Pragma_Task_Dispatching_Policy => 0,
32756 Pragma_Task_Info => -1,
32757 Pragma_Task_Name => -1,
32758 Pragma_Task_Storage => -1,
32759 Pragma_Test_Case => -1,
32760 Pragma_Thread_Local_Storage => -1,
32761 Pragma_Time_Slice => -1,
32763 Pragma_Type_Invariant => -1,
32764 Pragma_Type_Invariant_Class => -1,
32765 Pragma_Unchecked_Union => 0,
32766 Pragma_Unevaluated_Use_Of_Old => 0,
32767 Pragma_Unimplemented_Unit => 0,
32768 Pragma_Universal_Aliasing => 0,
32769 Pragma_Unmodified => 0,
32770 Pragma_Unreferenced => 0,
32771 Pragma_Unreferenced_Objects => 0,
32772 Pragma_Unreserve_All_Interrupts => 0,
32773 Pragma_Unsuppress => 0,
32774 Pragma_Unused => 0,
32775 Pragma_Use_VADS_Size => 0,
32776 Pragma_User_Aspect_Definition => 0,
32777 Pragma_Validity_Checks => 0,
32778 Pragma_Volatile => 0,
32779 Pragma_Volatile_Components => 0,
32780 Pragma_Volatile_Full_Access => 0,
32781 Pragma_Volatile_Function => 0,
32782 Pragma_Warning_As_Error => 0,
32783 Pragma_Warnings => 0,
32784 Pragma_Weak_External => 0,
32785 Pragma_Wide_Character_Encoding => 0,
32786 Unknown_Pragma => 0);
32788 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
32794 function Arg_No return Nat;
32795 -- Returns an integer showing what argument we are in. A value of
32796 -- zero means we are not in any of the arguments.
32802 function Arg_No return Nat is
32807 A := First (Pragma_Argument_Associations (Parent (P)));
32821 -- Start of processing for Non_Significant_Pragma_Reference
32824 -- Reference might appear either directly as expression of a pragma
32825 -- argument association, e.g. pragma Export (...), or within an
32826 -- aggregate with component associations, e.g. pragma Refined_State
32832 when N_Pragma_Argument_Association =>
32834 when N_Aggregate | N_Component_Association =>
32847 Id := Get_Pragma_Id (Parent (P));
32848 C := Sig_Flags (Id);
32858 return AN < (C - 90);
32863 end Is_Non_Significant_Pragma_Reference;
32865 ------------------------------
32866 -- Is_Pragma_String_Literal --
32867 ------------------------------
32869 -- This function returns true if the corresponding pragma argument is a
32870 -- static string expression. These are the only cases in which string
32871 -- literals can appear as pragma arguments. We also allow a string literal
32872 -- as the first argument to pragma Assert (although it will of course
32873 -- always generate a type error).
32875 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
32876 Pragn : constant Node_Id := Parent (Par);
32877 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
32878 Pname : constant Name_Id := Pragma_Name (Pragn);
32884 N := First (Assoc);
32891 if Pname = Name_Assert then
32894 elsif Pname = Name_Export then
32897 elsif Pname = Name_Ident then
32900 elsif Pname = Name_Import then
32903 elsif Pname = Name_Interface_Name then
32906 elsif Pname = Name_Linker_Alias then
32909 elsif Pname = Name_Linker_Section then
32912 elsif Pname = Name_Machine_Attribute then
32915 elsif Pname = Name_Source_File_Name then
32918 elsif Pname = Name_Source_Reference then
32921 elsif Pname = Name_Title then
32924 elsif Pname = Name_Subtitle then
32930 end Is_Pragma_String_Literal;
32932 ---------------------------
32933 -- Is_Private_SPARK_Mode --
32934 ---------------------------
32936 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
32939 (Nkind (N) = N_Pragma
32940 and then Pragma_Name (N) = Name_SPARK_Mode
32941 and then Is_List_Member (N));
32943 -- For pragma SPARK_Mode to be private, it has to appear in the private
32944 -- declarations of a package.
32947 Present (Parent (N))
32948 and then Nkind (Parent (N)) = N_Package_Specification
32949 and then List_Containing (N) = Private_Declarations (Parent (N));
32950 end Is_Private_SPARK_Mode;
32952 -------------------------------------
32953 -- Is_Unconstrained_Or_Tagged_Item --
32954 -------------------------------------
32956 function Is_Unconstrained_Or_Tagged_Item
32957 (Item : Entity_Id) return Boolean
32959 Typ : constant Entity_Id := Etype (Item);
32961 if Is_Tagged_Type (Typ) then
32964 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
32967 elsif Is_Record_Type (Typ) then
32968 return Has_Discriminants (Typ) and then not Is_Constrained (Typ);
32970 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
32976 end Is_Unconstrained_Or_Tagged_Item;
32978 -----------------------------
32979 -- Is_Valid_Assertion_Kind --
32980 -----------------------------
32982 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
32989 | Name_Static_Predicate
32990 | Name_Dynamic_Predicate
32995 | Name_Type_Invariant
32996 | Name_uType_Invariant
33000 | Name_Assert_And_Cut
33002 | Name_Contract_Cases
33004 | Name_Default_Initial_Condition
33006 | Name_Ghost_Predicate
33007 | Name_Initial_Condition
33010 | Name_Loop_Invariant
33011 | Name_Loop_Variant
33012 | Name_Postcondition
33013 | Name_Precondition
33015 | Name_Refined_Post
33016 | Name_Statement_Assertions
33017 | Name_Subprogram_Variant
33024 end Is_Valid_Assertion_Kind;
33026 --------------------------------------
33027 -- Process_Compilation_Unit_Pragmas --
33028 --------------------------------------
33030 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
33032 -- A special check for pragma Suppress_All, a very strange DEC pragma,
33033 -- strange because it comes at the end of the unit. Rational has the
33034 -- same name for a pragma, but treats it as a program unit pragma, In
33035 -- GNAT we just decide to allow it anywhere at all. If it appeared then
33036 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
33037 -- node, and we insert a pragma Suppress (All_Checks) at the start of
33038 -- the context clause to ensure the correct processing.
33040 if Has_Pragma_Suppress_All (N) then
33041 Prepend_To (Context_Items (N),
33042 Make_Pragma (Sloc (N),
33043 Chars => Name_Suppress,
33044 Pragma_Argument_Associations => New_List (
33045 Make_Pragma_Argument_Association (Sloc (N),
33046 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
33049 -- Nothing else to do at the current time
33051 end Process_Compilation_Unit_Pragmas;
33053 --------------------------------------------
33054 -- Validate_Compile_Time_Warning_Or_Error --
33055 --------------------------------------------
33057 procedure Validate_Compile_Time_Warning_Or_Error
33061 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
33062 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
33063 Arg2 : constant Node_Id := Next (Arg1);
33065 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
33066 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
33069 Analyze_And_Resolve (Arg1x, Standard_Boolean);
33071 if Compile_Time_Known_Value (Arg1x) then
33072 if Is_True (Expr_Value (Arg1x)) then
33074 -- We have already verified that the second argument is a static
33075 -- string expression. Its string value must be retrieved
33076 -- explicitly if it is a declared constant, otherwise it has
33077 -- been constant-folded previously.
33080 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
33081 Str : constant String_Id :=
33082 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
33083 Str_Len : constant Nat := String_Length (Str);
33085 Force : constant Boolean :=
33086 Prag_Id = Pragma_Compile_Time_Warning
33087 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
33088 and then (Ekind (Cent) /= E_Package
33089 or else not In_Private_Part (Cent));
33090 -- Set True if this is the warning case, and we are in the
33091 -- visible part of a package spec, or in a subprogram spec,
33092 -- in which case we want to force the client to see the
33093 -- warning, even though it is not in the main unit.
33101 -- Loop through segments of message separated by line feeds.
33102 -- We output these segments as separate messages with
33103 -- continuation marks for all but the first.
33108 Error_Msg_Strlen := 0;
33110 -- Loop to copy characters from argument to error message
33114 exit when Ptr > Str_Len;
33115 CC := Get_String_Char (Str, Ptr);
33118 -- Ignore wide chars ??? else store character
33120 if In_Character_Range (CC) then
33121 C := Get_Character (CC);
33122 exit when C = ASCII.LF;
33123 Error_Msg_Strlen := Error_Msg_Strlen + 1;
33124 Error_Msg_String (Error_Msg_Strlen) := C;
33128 -- Here with one line ready to go
33130 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
33132 -- If this is a warning in a spec, then we want clients
33133 -- to see the warning, so mark the message with the
33134 -- special sequence !! to force the warning. In the case
33135 -- of a package spec, we do not force this if we are in
33136 -- the private part of the spec.
33139 if Cont = False then
33141 ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
33145 ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
33148 -- Error, rather than warning, or in a body, so we do not
33149 -- need to force visibility for client (error will be
33150 -- output in any case, and this is the situation in which
33151 -- we do not want a client to get a warning, since the
33152 -- warning is in the body or the spec private part).
33155 if Cont = False then
33157 ("<<~", Eloc, Is_Compile_Time_Pragma => True);
33161 ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
33165 exit when Ptr > Str_Len;
33170 -- Arg1x is not known at compile time, so possibly issue an error
33171 -- or warning. This can happen only if the pragma's processing
33172 -- was deferred until after the back end is run (see
33173 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
33174 -- control switch applies to only the warning case.
33176 elsif Prag_Id = Pragma_Compile_Time_Error then
33177 Error_Msg_N ("condition is not known at compile time", Arg1x);
33179 elsif Warn_On_Unknown_Compile_Time_Warning then
33180 Error_Msg_N ("?_c?condition is not known at compile time", Arg1x);
33182 end Validate_Compile_Time_Warning_Or_Error;
33184 ------------------------------------
33185 -- Record_Possible_Body_Reference --
33186 ------------------------------------
33188 procedure Record_Possible_Body_Reference
33189 (State_Id : Entity_Id;
33193 Spec_Id : Entity_Id;
33196 -- Ensure that we are dealing with a reference to a state
33198 pragma Assert (Ekind (State_Id) = E_Abstract_State);
33200 -- Climb the tree starting from the reference looking for a package body
33201 -- whose spec declares the referenced state. This criteria automatically
33202 -- excludes references in package specs which are legal. Note that it is
33203 -- not wise to emit an error now as the package body may lack pragma
33204 -- Refined_State or the referenced state may not be mentioned in the
33205 -- refinement. This approach avoids the generation of misleading errors.
33208 while Present (Context) loop
33209 if Nkind (Context) = N_Package_Body then
33210 Spec_Id := Corresponding_Spec (Context);
33212 if Contains (Abstract_States (Spec_Id), State_Id) then
33213 if No (Body_References (State_Id)) then
33214 Set_Body_References (State_Id, New_Elmt_List);
33217 Append_Elmt (Ref, To => Body_References (State_Id));
33222 Context := Parent (Context);
33224 end Record_Possible_Body_Reference;
33226 ------------------------------------------
33227 -- Relocate_Pragmas_To_Anonymous_Object --
33228 ------------------------------------------
33230 procedure Relocate_Pragmas_To_Anonymous_Object
33231 (Typ_Decl : Node_Id;
33232 Obj_Decl : Node_Id)
33236 Next_Decl : Node_Id;
33239 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
33240 Def := Protected_Definition (Typ_Decl);
33242 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
33243 Def := Task_Definition (Typ_Decl);
33246 -- The concurrent definition has a visible declaration list. Inspect it
33247 -- and relocate all canidate pragmas.
33249 if Present (Def) and then Present (Visible_Declarations (Def)) then
33250 Decl := First (Visible_Declarations (Def));
33251 while Present (Decl) loop
33253 -- Preserve the following declaration for iteration purposes due
33254 -- to possible relocation of a pragma.
33256 Next_Decl := Next (Decl);
33258 if Nkind (Decl) = N_Pragma
33259 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
33262 Insert_After (Obj_Decl, Decl);
33264 -- Skip internally generated code
33266 elsif not Comes_From_Source (Decl) then
33269 -- No candidate pragmas are available for relocation
33278 end Relocate_Pragmas_To_Anonymous_Object;
33280 ------------------------------
33281 -- Relocate_Pragmas_To_Body --
33282 ------------------------------
33284 procedure Relocate_Pragmas_To_Body
33285 (Subp_Body : Node_Id;
33286 Target_Body : Node_Id := Empty)
33288 procedure Relocate_Pragma (Prag : Node_Id);
33289 -- Remove a single pragma from its current list and add it to the
33290 -- declarations of the proper body (either Subp_Body or Target_Body).
33292 ---------------------
33293 -- Relocate_Pragma --
33294 ---------------------
33296 procedure Relocate_Pragma (Prag : Node_Id) is
33301 -- When subprogram stubs or expression functions are involves, the
33302 -- destination declaration list belongs to the proper body.
33304 if Present (Target_Body) then
33305 Target := Target_Body;
33307 Target := Subp_Body;
33310 Decls := Declarations (Target);
33314 Set_Declarations (Target, Decls);
33317 -- Unhook the pragma from its current list
33320 Prepend (Prag, Decls);
33321 end Relocate_Pragma;
33325 Body_Id : constant Entity_Id :=
33326 Defining_Unit_Name (Specification (Subp_Body));
33327 Next_Stmt : Node_Id;
33330 -- Start of processing for Relocate_Pragmas_To_Body
33333 -- Do not process a body that comes from a separate unit as no construct
33334 -- can possibly follow it.
33336 if not Is_List_Member (Subp_Body) then
33339 -- Do not relocate pragmas that follow a stub if the stub does not have
33342 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
33343 and then No (Target_Body)
33347 -- Do not process internally generated routine _Wrapped_Statements
33349 elsif Ekind (Body_Id) = E_Procedure
33350 and then Chars (Body_Id) = Name_uWrapped_Statements
33355 -- Look at what is following the body. We are interested in certain kind
33356 -- of pragmas (either from source or byproducts of expansion) that can
33357 -- apply to a body [stub].
33359 Stmt := Next (Subp_Body);
33360 while Present (Stmt) loop
33362 -- Preserve the following statement for iteration purposes due to a
33363 -- possible relocation of a pragma.
33365 Next_Stmt := Next (Stmt);
33367 -- Move a candidate pragma following the body to the declarations of
33370 if Nkind (Stmt) = N_Pragma
33371 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
33374 -- If a source pragma Warnings follows the body, it applies to
33375 -- following statements and does not belong in the body.
33377 if Get_Pragma_Id (Stmt) = Pragma_Warnings
33378 and then Comes_From_Source (Stmt)
33382 Relocate_Pragma (Stmt);
33385 -- Skip internally generated code
33387 elsif not Comes_From_Source (Stmt) then
33390 -- No candidate pragmas are available for relocation
33398 end Relocate_Pragmas_To_Body;
33400 -------------------
33401 -- Resolve_State --
33402 -------------------
33404 procedure Resolve_State (N : Node_Id) is
33409 if Is_Entity_Name (N) and then Present (Entity (N)) then
33410 Func := Entity (N);
33412 -- Handle overloading of state names by functions. Traverse the
33413 -- homonym chain looking for an abstract state.
33415 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
33416 pragma Assert (Is_Overloaded (N));
33418 State := Homonym (Func);
33419 while Present (State) loop
33420 if Ekind (State) = E_Abstract_State then
33422 -- Resolve the overloading by setting the proper entity of
33423 -- the reference to that of the state.
33425 Set_Etype (N, Standard_Void_Type);
33426 Set_Entity (N, State);
33427 Set_Is_Overloaded (N, False);
33429 Generate_Reference (State, N);
33433 State := Homonym (State);
33436 -- A function can never act as a state. If the homonym chain does
33437 -- not contain a corresponding state, then something went wrong in
33438 -- the overloading mechanism.
33440 raise Program_Error;
33445 ----------------------------
33446 -- Rewrite_Assertion_Kind --
33447 ----------------------------
33449 procedure Rewrite_Assertion_Kind
33451 From_Policy : Boolean := False)
33457 if Nkind (N) = N_Attribute_Reference
33458 and then Attribute_Name (N) = Name_Class
33459 and then Nkind (Prefix (N)) = N_Identifier
33461 case Chars (Prefix (N)) is
33468 when Name_Type_Invariant =>
33469 Nam := Name_uType_Invariant;
33471 when Name_Invariant =>
33472 Nam := Name_uInvariant;
33478 -- Recommend standard use of aspect names Pre/Post
33480 elsif Nkind (N) = N_Identifier
33481 and then From_Policy
33482 and then Serious_Errors_Detected = 0
33484 if Chars (N) = Name_Precondition
33485 or else Chars (N) = Name_Postcondition
33487 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
33489 ("\use Assertion_Policy and aspect names Pre/Post for "
33490 & "Ada2012 conformance?", N);
33496 if Nam /= No_Name then
33497 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
33499 end Rewrite_Assertion_Kind;
33507 Dummy := Dummy + 1;
33510 --------------------------------
33511 -- Set_Encoded_Interface_Name --
33512 --------------------------------
33514 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
33515 Str : constant String_Id := Strval (S);
33516 Len : constant Nat := String_Length (Str);
33521 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
33524 -- Stores encoded value of character code CC. The encoding we use an
33525 -- underscore followed by four lower case hex digits.
33531 procedure Encode is
33533 Store_String_Char (Get_Char_Code ('_'));
33535 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
33537 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
33539 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
33541 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
33544 -- Start of processing for Set_Encoded_Interface_Name
33547 -- If first character is asterisk, this is a link name, and we leave it
33548 -- completely unmodified. We also ignore null strings (the latter case
33549 -- happens only in error cases).
33552 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
33554 Set_Interface_Name (E, S);
33559 CC := Get_String_Char (Str, J);
33561 exit when not In_Character_Range (CC);
33563 C := Get_Character (CC);
33565 exit when C /= '_' and then C /= '$'
33566 and then C not in '0' .. '9'
33567 and then C not in 'a' .. 'z'
33568 and then C not in 'A' .. 'Z';
33571 Set_Interface_Name (E, S);
33579 -- Here we need to encode. The encoding we use as follows:
33580 -- three underscores + four hex digits (lower case)
33584 for J in 1 .. String_Length (Str) loop
33585 CC := Get_String_Char (Str, J);
33587 if not In_Character_Range (CC) then
33590 C := Get_Character (CC);
33592 if C = '_' or else C = '$'
33593 or else C in '0' .. '9'
33594 or else C in 'a' .. 'z'
33595 or else C in 'A' .. 'Z'
33597 Store_String_Char (CC);
33604 Set_Interface_Name (E,
33605 Make_String_Literal (Sloc (S),
33606 Strval => End_String));
33608 end Set_Encoded_Interface_Name;
33610 ------------------------
33611 -- Set_Elab_Unit_Name --
33612 ------------------------
33614 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
33619 if Nkind (N) = N_Identifier
33620 and then Nkind (With_Item) = N_Identifier
33622 Set_Entity (N, Entity (With_Item));
33624 elsif Nkind (N) = N_Selected_Component then
33625 Change_Selected_Component_To_Expanded_Name (N);
33626 Set_Entity (N, Entity (With_Item));
33627 Set_Entity (Selector_Name (N), Entity (N));
33629 Pref := Prefix (N);
33630 Scop := Scope (Entity (N));
33631 while Nkind (Pref) = N_Selected_Component loop
33632 Change_Selected_Component_To_Expanded_Name (Pref);
33633 Set_Entity (Selector_Name (Pref), Scop);
33634 Set_Entity (Pref, Scop);
33635 Pref := Prefix (Pref);
33636 Scop := Scope (Scop);
33639 Set_Entity (Pref, Scop);
33642 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
33643 end Set_Elab_Unit_Name;
33645 -----------------------
33646 -- Set_Overflow_Mode --
33647 -----------------------
33649 procedure Set_Overflow_Mode (N : Node_Id) is
33651 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
33652 -- Function to process one pragma argument, Arg
33654 -----------------------
33655 -- Get_Overflow_Mode --
33656 -----------------------
33658 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
33659 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
33662 if Chars (Argx) = Name_Strict then
33665 elsif Chars (Argx) = Name_Minimized then
33668 elsif Chars (Argx) = Name_Eliminated then
33672 raise Program_Error;
33674 end Get_Overflow_Mode;
33678 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
33679 Arg2 : constant Node_Id := Next (Arg1);
33681 -- Start of processing for Set_Overflow_Mode
33684 -- Process first argument
33686 Scope_Suppress.Overflow_Mode_General :=
33687 Get_Overflow_Mode (Arg1);
33689 -- Case of only one argument
33692 Scope_Suppress.Overflow_Mode_Assertions :=
33693 Scope_Suppress.Overflow_Mode_General;
33695 -- Case of two arguments present
33698 Scope_Suppress.Overflow_Mode_Assertions :=
33699 Get_Overflow_Mode (Arg2);
33701 end Set_Overflow_Mode;
33703 -------------------
33704 -- Test_Case_Arg --
33705 -------------------
33707 function Test_Case_Arg
33710 From_Aspect : Boolean := False) return Node_Id
33712 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
33718 (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
33720 -- The caller requests the aspect argument
33722 if From_Aspect then
33723 if Present (Aspect)
33724 and then Nkind (Expression (Aspect)) = N_Aggregate
33726 Args := Expression (Aspect);
33728 -- "Name" and "Mode" may appear without an identifier as a
33729 -- positional association.
33731 if Present (Expressions (Args)) then
33732 Arg := First (Expressions (Args));
33734 if Present (Arg) and then Arg_Nam = Name_Name then
33742 if Present (Arg) and then Arg_Nam = Name_Mode then
33747 -- Some or all arguments may appear as component associatons
33749 if Present (Component_Associations (Args)) then
33750 Arg := First (Component_Associations (Args));
33751 while Present (Arg) loop
33752 if Chars (First (Choices (Arg))) = Arg_Nam then
33761 -- Otherwise retrieve the argument directly from the pragma
33764 Arg := First (Pragma_Argument_Associations (Prag));
33766 if Present (Arg) and then Arg_Nam = Name_Name then
33770 -- Skip argument "Name"
33774 if Present (Arg) and then Arg_Nam = Name_Mode then
33778 -- Skip argument "Mode"
33782 -- Arguments "Requires" and "Ensures" are optional and may not be
33785 while Present (Arg) loop
33786 if Chars (Arg) = Arg_Nam then
33797 --------------------------------------------
33798 -- Defer_Compile_Time_Warning_Error_To_BE --
33799 --------------------------------------------
33801 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
33802 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
33804 Compile_Time_Warnings_Errors.Append
33805 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
33806 Scope => Current_Scope,
33809 -- If the Boolean expression contains T'Size, and we're not in the main
33810 -- unit being compiled, then we need to copy the pragma into the main
33811 -- unit, because otherwise T'Size might never be computed, leaving it
33814 if not In_Extended_Main_Code_Unit (N) then
33815 Insert_Library_Level_Action (New_Copy_Tree (N));
33817 end Defer_Compile_Time_Warning_Error_To_BE;
33819 ------------------------------------------
33820 -- Validate_Compile_Time_Warning_Errors --
33821 ------------------------------------------
33823 procedure Validate_Compile_Time_Warning_Errors is
33824 procedure Set_Scope (S : Entity_Id);
33825 -- Install all enclosing scopes of S along with S itself
33827 procedure Unset_Scope (S : Entity_Id);
33828 -- Uninstall all enclosing scopes of S along with S itself
33834 procedure Set_Scope (S : Entity_Id) is
33836 if S /= Standard_Standard then
33837 Set_Scope (Scope (S));
33847 procedure Unset_Scope (S : Entity_Id) is
33849 if S /= Standard_Standard then
33850 Unset_Scope (Scope (S));
33856 -- Start of processing for Validate_Compile_Time_Warning_Errors
33860 -- These error/warning messages were deferred because they could not be
33861 -- evaluated in the front-end and they needed additional information
33862 -- from the back-end. There is no reason to run these checks again if
33863 -- the back-end was not activated by this point.
33865 if not Generating_Code then
33869 Expander_Mode_Save_And_Set (False);
33870 In_Compile_Time_Warning_Or_Error := True;
33872 for N in Compile_Time_Warnings_Errors.First ..
33873 Compile_Time_Warnings_Errors.Last
33876 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
33879 Set_Scope (T.Scope);
33880 Reset_Analyzed_Flags (T.Prag);
33881 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
33882 Unset_Scope (T.Scope);
33886 In_Compile_Time_Warning_Or_Error := False;
33887 Expander_Mode_Restore;
33888 end Validate_Compile_Time_Warning_Errors;