1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with GNAT_CUDA; use GNAT_CUDA;
48 with Gnatvsn; use Gnatvsn;
50 with Lib.Writ; use Lib.Writ;
51 with Lib.Xref; use Lib.Xref;
52 with Namet.Sp; use Namet.Sp;
53 with Nlists; use Nlists;
54 with Nmake; use Nmake;
55 with Output; use Output;
56 with Par_SCO; use Par_SCO;
57 with Restrict; use Restrict;
58 with Rident; use Rident;
59 with Rtsfind; use Rtsfind;
61 with Sem_Aux; use Sem_Aux;
62 with Sem_Ch3; use Sem_Ch3;
63 with Sem_Ch6; use Sem_Ch6;
64 with Sem_Ch8; use Sem_Ch8;
65 with Sem_Ch12; use Sem_Ch12;
66 with Sem_Ch13; use Sem_Ch13;
67 with Sem_Disp; use Sem_Disp;
68 with Sem_Dist; use Sem_Dist;
69 with Sem_Elab; use Sem_Elab;
70 with Sem_Elim; use Sem_Elim;
71 with Sem_Eval; use Sem_Eval;
72 with Sem_Intr; use Sem_Intr;
73 with Sem_Mech; use Sem_Mech;
74 with Sem_Res; use Sem_Res;
75 with Sem_Type; use Sem_Type;
76 with Sem_Util; use Sem_Util;
77 with Sem_Warn; use Sem_Warn;
78 with Stand; use Stand;
79 with Sinfo; use Sinfo;
80 with Sinfo.CN; use Sinfo.CN;
81 with Sinput; use Sinput;
82 with Stringt; use Stringt;
83 with Stylesw; use Stylesw;
85 with Targparm; use Targparm;
86 with Tbuild; use Tbuild;
88 with Uintp; use Uintp;
89 with Uname; use Uname;
90 with Urealp; use Urealp;
91 with Validsw; use Validsw;
92 with Warnsw; use Warnsw;
94 with System.Case_Util;
96 package body Sem_Prag is
98 ----------------------------------------------
99 -- Common Handling of Import-Export Pragmas --
100 ----------------------------------------------
102 -- In the following section, a number of Import_xxx and Export_xxx pragmas
103 -- are defined by GNAT. These are compatible with the DEC pragmas of the
104 -- same name, and all have the following common form and processing:
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
112 -- [Internal =>] LOCAL_NAME
113 -- [, [External =>] EXTERNAL_SYMBOL]
114 -- [, other optional parameters ]);
116 -- EXTERNAL_SYMBOL ::=
118 -- | static_string_EXPRESSION
120 -- The internal LOCAL_NAME designates the entity that is imported or
121 -- exported, and must refer to an entity in the current declarative
122 -- part (as required by the rules for LOCAL_NAME).
124 -- The external linker name is designated by the External parameter if
125 -- given, or the Internal parameter if not (if there is no External
126 -- parameter, the External parameter is a copy of the Internal name).
128 -- If the External parameter is given as a string, then this string is
129 -- treated as an external name (exactly as though it had been given as an
130 -- External_Name parameter for a normal Import pragma).
132 -- If the External parameter is given as an identifier (or there is no
133 -- External parameter, so that the Internal identifier is used), then
134 -- the external name is the characters of the identifier, translated
135 -- to all lower case letters.
137 -- Note: the external name specified or implied by any of these special
138 -- Import_xxx or Export_xxx pragmas override an external or link name
139 -- specified in a previous Import or Export pragma.
141 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
142 -- named notation, following the standard rules for subprogram calls, i.e.
143 -- parameters can be given in any order if named notation is used, and
144 -- positional and named notation can be mixed, subject to the rule that all
145 -- positional parameters must appear first.
147 -- Note: All these pragmas are implemented exactly following the DEC design
148 -- and implementation and are intended to be fully compatible with the use
149 -- of these pragmas in the DEC Ada compiler.
151 --------------------------------------------
152 -- Checking for Duplicated External Names --
153 --------------------------------------------
155 -- It is suspicious if two separate Export pragmas use the same external
156 -- name. The following table is used to diagnose this situation so that
157 -- an appropriate warning can be issued.
159 -- The Node_Id stored is for the N_String_Literal node created to hold
160 -- the value of the external name. The Sloc of this node is used to
161 -- cross-reference the location of the duplication.
163 package Externals is new Table.Table (
164 Table_Component_Type => Node_Id,
165 Table_Index_Type => Int,
166 Table_Low_Bound => 0,
167 Table_Initial => 100,
168 Table_Increment => 100,
169 Table_Name => "Name_Externals");
171 -------------------------------------
172 -- Local Subprograms and Variables --
173 -------------------------------------
175 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
176 -- This routine is used for possible casing adjustment of an explicit
177 -- external name supplied as a string literal (the node N), according to
178 -- the casing requirement of Opt.External_Name_Casing. If this is set to
179 -- As_Is, then the string literal is returned unchanged, but if it is set
180 -- to Uppercase or Lowercase, then a new string literal with appropriate
181 -- casing is constructed.
183 procedure Analyze_Part_Of
187 Encap_Id : out Entity_Id;
188 Legal : out Boolean);
189 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
190 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
191 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
192 -- package instantiation. Encap denotes the encapsulating state or single
193 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
194 -- the indicator is legal.
196 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
197 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
198 -- Query whether a particular item appears in a mixed list of nodes and
199 -- entities. It is assumed that all nodes in the list have entities.
201 procedure Check_Postcondition_Use_In_Inlined_Subprogram
203 Spec_Id : Entity_Id);
204 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
205 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
206 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
207 -- and assertions are enabled.
209 procedure Check_State_And_Constituent_Use
213 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
214 -- Global and Initializes. Determine whether a state from list States and a
215 -- corresponding constituent from list Constits (if any) appear in the same
216 -- context denoted by Context. If this is the case, emit an error.
218 procedure Contract_Freeze_Error
219 (Contract_Id : Entity_Id;
220 Freeze_Id : Entity_Id);
221 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
222 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
223 -- of a body which caused contract freezing and Contract_Id denotes the
224 -- entity of the affected contstruct.
226 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
227 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
228 -- Prag that duplicates previous pragma Prev.
230 function Find_Encapsulating_State
232 Constit_Id : Entity_Id) return Entity_Id;
233 -- Given the entity of a constituent Constit_Id, find the corresponding
234 -- encapsulating state which appears in States. The routine returns Empty
235 -- if no such state is found.
237 function Find_Related_Context
239 Do_Checks : Boolean := False) return Node_Id;
240 -- Subsidiary to the analysis of pragmas
243 -- Constant_After_Elaboration
247 -- Find the first source declaration or statement found while traversing
248 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
249 -- set, the routine reports duplicate pragmas. The routine returns Empty
250 -- when reaching the start of the node chain.
252 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
253 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
254 -- original one, following the renaming chain) is returned. Otherwise the
255 -- entity is returned unchanged. Should be in Einfo???
257 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
258 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
259 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
260 -- value of type SPARK_Mode_Type.
262 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
263 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
264 -- Determine whether dependency clause Clause is surrounded by extra
265 -- parentheses. If this is the case, issue an error message.
267 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
268 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
269 -- pragma Depends. Determine whether the type of dependency item Item is
270 -- tagged, unconstrained array, unconstrained record or a record with at
271 -- least one unconstrained component.
273 procedure Record_Possible_Body_Reference
274 (State_Id : Entity_Id;
276 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
277 -- Global. Given an abstract state denoted by State_Id and a reference Ref
278 -- to it, determine whether the reference appears in a package body that
279 -- will eventually refine the state. If this is the case, record the
280 -- reference for future checks (see Analyze_Refined_State_In_Decls).
282 procedure Resolve_State (N : Node_Id);
283 -- Handle the overloading of state names by functions. When N denotes a
284 -- function, this routine finds the corresponding state and sets the entity
285 -- of N to that of the state.
287 procedure Rewrite_Assertion_Kind
289 From_Policy : Boolean := False);
290 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
291 -- then it is rewritten as an identifier with the corresponding special
292 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
293 -- and Check_Policy. If the names are Precondition or Postcondition, this
294 -- combination is deprecated in favor of Assertion_Policy and Ada2012
295 -- Aspect names. The parameter From_Policy indicates that the pragma
296 -- is the old non-standard Check_Policy and not a rewritten pragma.
298 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
299 -- Place semantic information on the argument of an Elaborate/Elaborate_All
300 -- pragma. Entity name for unit and its parents is taken from item in
301 -- previous with_clause that mentions the unit.
303 procedure Validate_Compile_Time_Warning_Or_Error
306 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
307 -- pragma N. Called when the pragma is processed as part of its regular
308 -- analysis but also called after calling the back end to validate these
309 -- pragmas for size and alignment appropriateness.
311 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id);
312 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
313 -- expression is not known at compile time during the front end. This
314 -- procedure makes an entry in a table. The actual checking is performed by
315 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
318 Dummy : Integer := 0;
319 pragma Volatile (Dummy);
320 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
323 pragma No_Inline (ip);
324 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
325 -- is just to help debugging the front end. If a pragma Inspection_Point
326 -- is added to a source program, then breaking on ip will get you to that
327 -- point in the program.
330 pragma No_Inline (rv);
331 -- This is a dummy function called by the processing for pragma Reviewable.
332 -- It is there for assisting front end debugging. By placing a Reviewable
333 -- pragma in the source program, a breakpoint on rv catches this place in
334 -- the source, allowing convenient stepping to the point of interest.
336 ------------------------------------------------------
337 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
338 ------------------------------------------------------
340 -- The following table collects pragmas Compile_Time_Error and Compile_
341 -- Time_Warning for validation. Entries are made by calls to subprogram
342 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
343 -- Validate_Compile_Time_Warning_Errors does the actual error checking
344 -- and posting of warning and error messages. The reason for this delayed
345 -- processing is to take advantage of back-annotations of attributes size
346 -- and alignment values performed by the back end.
348 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
349 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
350 -- will already have modified all Sloc values if the -gnatD option is set.
352 type CTWE_Entry is record
354 -- Source location used in warnings and error messages
357 -- Pragma Compile_Time_Error or Compile_Time_Warning
360 -- The scope which encloses the pragma
363 package Compile_Time_Warnings_Errors is new Table.Table (
364 Table_Component_Type => CTWE_Entry,
365 Table_Index_Type => Int,
366 Table_Low_Bound => 1,
368 Table_Increment => 200,
369 Table_Name => "Compile_Time_Warnings_Errors");
371 -------------------------------
372 -- Adjust_External_Name_Case --
373 -------------------------------
375 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
379 -- Adjust case of literal if required
381 if Opt.External_Name_Exp_Casing = As_Is then
385 -- Copy existing string
391 for J in 1 .. String_Length (Strval (N)) loop
392 CC := Get_String_Char (Strval (N), J);
394 if Opt.External_Name_Exp_Casing = Uppercase
395 and then CC >= Get_Char_Code ('a')
396 and then CC <= Get_Char_Code ('z')
398 Store_String_Char (CC - 32);
400 elsif Opt.External_Name_Exp_Casing = Lowercase
401 and then CC >= Get_Char_Code ('A')
402 and then CC <= Get_Char_Code ('Z')
404 Store_String_Char (CC + 32);
407 Store_String_Char (CC);
412 Make_String_Literal (Sloc (N),
413 Strval => End_String);
415 end Adjust_External_Name_Case;
417 -----------------------------------------
418 -- Analyze_Contract_Cases_In_Decl_Part --
419 -----------------------------------------
421 -- WARNING: This routine manages Ghost regions. Return statements must be
422 -- replaced by gotos which jump to the end of the routine and restore the
425 procedure Analyze_Contract_Cases_In_Decl_Part
427 Freeze_Id : Entity_Id := Empty)
429 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
430 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
432 Others_Seen : Boolean := False;
433 -- This flag is set when an "others" choice is encountered. It is used
434 -- to detect multiple illegal occurrences of "others".
436 procedure Analyze_Contract_Case (CCase : Node_Id);
437 -- Verify the legality of a single contract case
439 ---------------------------
440 -- Analyze_Contract_Case --
441 ---------------------------
443 procedure Analyze_Contract_Case (CCase : Node_Id) is
444 Case_Guard : Node_Id;
447 Extra_Guard : Node_Id;
450 if Nkind (CCase) = N_Component_Association then
451 Case_Guard := First (Choices (CCase));
452 Conseq := Expression (CCase);
454 -- Each contract case must have exactly one case guard
456 Extra_Guard := Next (Case_Guard);
458 if Present (Extra_Guard) then
460 ("contract case must have exactly one case guard",
464 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
466 if Nkind (Case_Guard) = N_Others_Choice then
469 ("only one others choice allowed in contract cases",
475 elsif Others_Seen then
477 ("others must be the last choice in contract cases", N);
480 -- Preanalyze the case guard and consequence
482 if Nkind (Case_Guard) /= N_Others_Choice then
483 Errors := Serious_Errors_Detected;
484 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
486 -- Emit a clarification message when the case guard contains
487 -- at least one undefined reference, possibly due to contract
490 if Errors /= Serious_Errors_Detected
491 and then Present (Freeze_Id)
492 and then Has_Undefined_Reference (Case_Guard)
494 Contract_Freeze_Error (Spec_Id, Freeze_Id);
498 Errors := Serious_Errors_Detected;
499 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
501 -- Emit a clarification message when the consequence contains
502 -- at least one undefined reference, possibly due to contract
505 if Errors /= Serious_Errors_Detected
506 and then Present (Freeze_Id)
507 and then Has_Undefined_Reference (Conseq)
509 Contract_Freeze_Error (Spec_Id, Freeze_Id);
512 -- The contract case is malformed
515 Error_Msg_N ("wrong syntax in contract case", CCase);
517 end Analyze_Contract_Case;
521 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
523 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
524 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
525 -- Save the Ghost-related attributes to restore on exit
528 Restore_Scope : Boolean := False;
530 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
533 -- Do not analyze the pragma multiple times
535 if Is_Analyzed_Pragma (N) then
539 -- Set the Ghost mode in effect from the pragma. Due to the delayed
540 -- analysis of the pragma, the Ghost mode at point of declaration and
541 -- point of analysis may not necessarily be the same. Use the mode in
542 -- effect at the point of declaration.
546 -- Single and multiple contract cases must appear in aggregate form. If
547 -- this is not the case, then either the parser or the analysis of the
548 -- pragma failed to produce an aggregate.
550 pragma Assert (Nkind (CCases) = N_Aggregate);
552 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
554 if Present (Component_Associations (CCases))
555 and then No (Expressions (CCases))
558 -- Ensure that the formal parameters are visible when analyzing all
559 -- clauses. This falls out of the general rule of aspects pertaining
560 -- to subprogram declarations.
562 if not In_Open_Scopes (Spec_Id) then
563 Restore_Scope := True;
564 Push_Scope (Spec_Id);
566 if Is_Generic_Subprogram (Spec_Id) then
567 Install_Generic_Formals (Spec_Id);
569 Install_Formals (Spec_Id);
573 CCase := First (Component_Associations (CCases));
574 while Present (CCase) loop
575 Analyze_Contract_Case (CCase);
579 if Restore_Scope then
583 -- Currently it is not possible to inline pre/postconditions on a
584 -- subprogram subject to pragma Inline_Always.
586 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
588 -- Otherwise the pragma is illegal
591 Error_Msg_N ("wrong syntax for contract cases", N);
594 Set_Is_Analyzed_Pragma (N);
596 Restore_Ghost_Region (Saved_GM, Saved_IGR);
597 end Analyze_Contract_Cases_In_Decl_Part;
599 ----------------------------------
600 -- Analyze_Depends_In_Decl_Part --
601 ----------------------------------
603 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
604 Loc : constant Source_Ptr := Sloc (N);
605 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
606 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
608 All_Inputs_Seen : Elist_Id := No_Elist;
609 -- A list containing the entities of all the inputs processed so far.
610 -- The list is populated with unique entities because the same input
611 -- may appear in multiple input lists.
613 All_Outputs_Seen : Elist_Id := No_Elist;
614 -- A list containing the entities of all the outputs processed so far.
615 -- The list is populated with unique entities because output items are
616 -- unique in a dependence relation.
618 Constits_Seen : Elist_Id := No_Elist;
619 -- A list containing the entities of all constituents processed so far.
620 -- It aids in detecting illegal usage of a state and a corresponding
621 -- constituent in pragma [Refinde_]Depends.
623 Global_Seen : Boolean := False;
624 -- A flag set when pragma Global has been processed
626 Null_Output_Seen : Boolean := False;
627 -- A flag used to track the legality of a null output
629 Result_Seen : Boolean := False;
630 -- A flag set when Spec_Id'Result is processed
632 States_Seen : Elist_Id := No_Elist;
633 -- A list containing the entities of all states processed so far. It
634 -- helps in detecting illegal usage of a state and a corresponding
635 -- constituent in pragma [Refined_]Depends.
637 Subp_Inputs : Elist_Id := No_Elist;
638 Subp_Outputs : Elist_Id := No_Elist;
639 -- Two lists containing the full set of inputs and output of the related
640 -- subprograms. Note that these lists contain both nodes and entities.
642 Task_Input_Seen : Boolean := False;
643 Task_Output_Seen : Boolean := False;
644 -- Flags used to track the implicit dependence of a task unit on itself
646 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
647 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
648 -- to the name buffer. The individual kinds are as follows:
649 -- E_Abstract_State - "state"
650 -- E_Constant - "constant"
651 -- E_Generic_In_Out_Parameter - "generic parameter"
652 -- E_Generic_In_Parameter - "generic parameter"
653 -- E_In_Parameter - "parameter"
654 -- E_In_Out_Parameter - "parameter"
655 -- E_Loop_Parameter - "loop parameter"
656 -- E_Out_Parameter - "parameter"
657 -- E_Protected_Type - "current instance of protected type"
658 -- E_Task_Type - "current instance of task type"
659 -- E_Variable - "global"
661 procedure Analyze_Dependency_Clause
664 -- Verify the legality of a single dependency clause. Flag Is_Last
665 -- denotes whether Clause is the last clause in the relation.
667 procedure Check_Function_Return;
668 -- Verify that Funtion'Result appears as one of the outputs
669 -- (SPARK RM 6.1.5(10)).
676 -- Ensure that an item fulfills its designated input and/or output role
677 -- as specified by pragma Global (if any) or the enclosing context. If
678 -- this is not the case, emit an error. Item and Item_Id denote the
679 -- attributes of an item. Flag Is_Input should be set when item comes
680 -- from an input list. Flag Self_Ref should be set when the item is an
681 -- output and the dependency clause has operator "+".
683 procedure Check_Usage
684 (Subp_Items : Elist_Id;
685 Used_Items : Elist_Id;
687 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
688 -- error if this is not the case.
690 procedure Normalize_Clause (Clause : Node_Id);
691 -- Remove a self-dependency "+" from the input list of a clause
693 -----------------------------
694 -- Add_Item_To_Name_Buffer --
695 -----------------------------
697 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
699 if Ekind (Item_Id) = E_Abstract_State then
700 Add_Str_To_Name_Buffer ("state");
702 elsif Ekind (Item_Id) = E_Constant then
703 Add_Str_To_Name_Buffer ("constant");
705 elsif Ekind (Item_Id) in
706 E_Generic_In_Out_Parameter | E_Generic_In_Parameter
708 Add_Str_To_Name_Buffer ("generic parameter");
710 elsif Is_Formal (Item_Id) then
711 Add_Str_To_Name_Buffer ("parameter");
713 elsif Ekind (Item_Id) = E_Loop_Parameter then
714 Add_Str_To_Name_Buffer ("loop parameter");
716 elsif Ekind (Item_Id) = E_Protected_Type
717 or else Is_Single_Protected_Object (Item_Id)
719 Add_Str_To_Name_Buffer ("current instance of protected type");
721 elsif Ekind (Item_Id) = E_Task_Type
722 or else Is_Single_Task_Object (Item_Id)
724 Add_Str_To_Name_Buffer ("current instance of task type");
726 elsif Ekind (Item_Id) = E_Variable then
727 Add_Str_To_Name_Buffer ("global");
729 -- The routine should not be called with non-SPARK items
734 end Add_Item_To_Name_Buffer;
736 -------------------------------
737 -- Analyze_Dependency_Clause --
738 -------------------------------
740 procedure Analyze_Dependency_Clause
744 procedure Analyze_Input_List (Inputs : Node_Id);
745 -- Verify the legality of a single input list
747 procedure Analyze_Input_Output
752 Seen : in out Elist_Id;
753 Null_Seen : in out Boolean;
754 Non_Null_Seen : in out Boolean);
755 -- Verify the legality of a single input or output item. Flag
756 -- Is_Input should be set whenever Item is an input, False when it
757 -- denotes an output. Flag Self_Ref should be set when the item is an
758 -- output and the dependency clause has a "+". Flag Top_Level should
759 -- be set whenever Item appears immediately within an input or output
760 -- list. Seen is a collection of all abstract states, objects and
761 -- formals processed so far. Flag Null_Seen denotes whether a null
762 -- input or output has been encountered. Flag Non_Null_Seen denotes
763 -- whether a non-null input or output has been encountered.
765 ------------------------
766 -- Analyze_Input_List --
767 ------------------------
769 procedure Analyze_Input_List (Inputs : Node_Id) is
770 Inputs_Seen : Elist_Id := No_Elist;
771 -- A list containing the entities of all inputs that appear in the
772 -- current input list.
774 Non_Null_Input_Seen : Boolean := False;
775 Null_Input_Seen : Boolean := False;
776 -- Flags used to check the legality of an input list
781 -- Multiple inputs appear as an aggregate
783 if Nkind (Inputs) = N_Aggregate then
784 if Present (Component_Associations (Inputs)) then
786 ("nested dependency relations not allowed", Inputs);
788 elsif Present (Expressions (Inputs)) then
789 Input := First (Expressions (Inputs));
790 while Present (Input) loop
797 Null_Seen => Null_Input_Seen,
798 Non_Null_Seen => Non_Null_Input_Seen);
803 -- Syntax error, always report
806 Error_Msg_N ("malformed input dependency list", Inputs);
809 -- Process a solitary input
818 Null_Seen => Null_Input_Seen,
819 Non_Null_Seen => Non_Null_Input_Seen);
822 -- Detect an illegal dependency clause of the form
826 if Null_Output_Seen and then Null_Input_Seen then
828 ("null dependency clause cannot have a null input list",
831 end Analyze_Input_List;
833 --------------------------
834 -- Analyze_Input_Output --
835 --------------------------
837 procedure Analyze_Input_Output
842 Seen : in out Elist_Id;
843 Null_Seen : in out Boolean;
844 Non_Null_Seen : in out Boolean)
846 procedure Current_Task_Instance_Seen;
847 -- Set the appropriate global flag when the current instance of a
848 -- task unit is encountered.
850 --------------------------------
851 -- Current_Task_Instance_Seen --
852 --------------------------------
854 procedure Current_Task_Instance_Seen is
857 Task_Input_Seen := True;
859 Task_Output_Seen := True;
861 end Current_Task_Instance_Seen;
865 Is_Output : constant Boolean := not Is_Input;
869 -- Start of processing for Analyze_Input_Output
872 -- Multiple input or output items appear as an aggregate
874 if Nkind (Item) = N_Aggregate then
875 if not Top_Level then
876 SPARK_Msg_N ("nested grouping of items not allowed", Item);
878 elsif Present (Component_Associations (Item)) then
880 ("nested dependency relations not allowed", Item);
882 -- Recursively analyze the grouped items
884 elsif Present (Expressions (Item)) then
885 Grouped := First (Expressions (Item));
886 while Present (Grouped) loop
889 Is_Input => Is_Input,
890 Self_Ref => Self_Ref,
893 Null_Seen => Null_Seen,
894 Non_Null_Seen => Non_Null_Seen);
899 -- Syntax error, always report
902 Error_Msg_N ("malformed dependency list", Item);
905 -- Process attribute 'Result in the context of a dependency clause
907 elsif Is_Attribute_Result (Item) then
908 Non_Null_Seen := True;
912 -- Attribute 'Result is allowed to appear on the output side of
913 -- a dependency clause (SPARK RM 6.1.5(6)).
916 SPARK_Msg_N ("function result cannot act as input", Item);
920 ("cannot mix null and non-null dependency items", Item);
926 -- Detect multiple uses of null in a single dependency list or
927 -- throughout the whole relation. Verify the placement of a null
928 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
930 elsif Nkind (Item) = N_Null then
933 ("multiple null dependency relations not allowed", Item);
935 elsif Non_Null_Seen then
937 ("cannot mix null and non-null dependency items", Item);
945 ("null output list must be the last clause in a "
946 & "dependency relation", Item);
948 -- Catch a useless dependence of the form:
953 ("useless dependence, null depends on itself", Item);
961 Non_Null_Seen := True;
964 SPARK_Msg_N ("cannot mix null and non-null items", Item);
968 Resolve_State (Item);
970 -- Find the entity of the item. If this is a renaming, climb
971 -- the renaming chain to reach the root object. Renamings of
972 -- non-entire objects do not yield an entity (Empty).
974 Item_Id := Entity_Of (Item);
976 if Present (Item_Id) then
980 if Ekind (Item_Id) in E_Constant | E_Loop_Parameter
983 -- Current instances of concurrent types
985 Ekind (Item_Id) in E_Protected_Type | E_Task_Type
990 Ekind (Item_Id) in E_Generic_In_Out_Parameter
991 | E_Generic_In_Parameter
999 Ekind (Item_Id) in E_Abstract_State | E_Variable
1001 -- A [generic] function is not allowed to have Output
1002 -- items in its dependency relations. Note that "null"
1003 -- and attribute 'Result are still valid items.
1005 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1006 and then not Is_Input
1009 ("output item is not applicable to function", Item);
1012 -- The item denotes a concurrent type. Note that single
1013 -- protected/task types are not considered here because
1014 -- they behave as objects in the context of pragma
1015 -- [Refined_]Depends.
1017 if Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
1019 -- This use is legal as long as the concurrent type is
1020 -- the current instance of an enclosing type.
1022 if Is_CCT_Instance (Item_Id, Spec_Id) then
1024 -- The dependence of a task unit on itself is
1025 -- implicit and may or may not be explicitly
1026 -- specified (SPARK RM 6.1.4).
1028 if Ekind (Item_Id) = E_Task_Type then
1029 Current_Task_Instance_Seen;
1032 -- Otherwise this is not the current instance
1036 ("invalid use of subtype mark in dependency "
1037 & "relation", Item);
1040 -- The dependency of a task unit on itself is implicit
1041 -- and may or may not be explicitly specified
1042 -- (SPARK RM 6.1.4).
1044 elsif Is_Single_Task_Object (Item_Id)
1045 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1047 Current_Task_Instance_Seen;
1050 -- Ensure that the item fulfills its role as input and/or
1051 -- output as specified by pragma Global or the enclosing
1054 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1056 -- Detect multiple uses of the same state, variable or
1057 -- formal parameter. If this is not the case, add the
1058 -- item to the list of processed relations.
1060 if Contains (Seen, Item_Id) then
1062 ("duplicate use of item &", Item, Item_Id);
1064 Append_New_Elmt (Item_Id, Seen);
1067 -- Detect illegal use of an input related to a null
1068 -- output. Such input items cannot appear in other
1069 -- input lists (SPARK RM 6.1.5(13)).
1072 and then Null_Output_Seen
1073 and then Contains (All_Inputs_Seen, Item_Id)
1076 ("input of a null output list cannot appear in "
1077 & "multiple input lists", Item);
1080 -- Add an input or a self-referential output to the list
1081 -- of all processed inputs.
1083 if Is_Input or else Self_Ref then
1084 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1087 -- State related checks (SPARK RM 6.1.5(3))
1089 if Ekind (Item_Id) = E_Abstract_State then
1091 -- Package and subprogram bodies are instantiated
1092 -- individually in a separate compiler pass. Due to
1093 -- this mode of instantiation, the refinement of a
1094 -- state may no longer be visible when a subprogram
1095 -- body contract is instantiated. Since the generic
1096 -- template is legal, do not perform this check in
1097 -- the instance to circumvent this oddity.
1102 -- An abstract state with visible refinement cannot
1103 -- appear in pragma [Refined_]Depends as its place
1104 -- must be taken by some of its constituents
1105 -- (SPARK RM 6.1.4(7)).
1107 elsif Has_Visible_Refinement (Item_Id) then
1109 ("cannot mention state & in dependence relation",
1111 SPARK_Msg_N ("\use its constituents instead", Item);
1114 -- If the reference to the abstract state appears in
1115 -- an enclosing package body that will eventually
1116 -- refine the state, record the reference for future
1120 Record_Possible_Body_Reference
1121 (State_Id => Item_Id,
1126 -- When the item renames an entire object, replace the
1127 -- item with a reference to the object.
1129 if Entity (Item) /= Item_Id then
1131 New_Occurrence_Of (Item_Id, Sloc (Item)));
1135 -- Add the entity of the current item to the list of
1138 if Ekind (Item_Id) = E_Abstract_State then
1139 Append_New_Elmt (Item_Id, States_Seen);
1141 -- The variable may eventually become a constituent of a
1142 -- single protected/task type. Record the reference now
1143 -- and verify its legality when analyzing the contract of
1144 -- the variable (SPARK RM 9.3).
1146 elsif Ekind (Item_Id) = E_Variable then
1147 Record_Possible_Part_Of_Reference
1152 if Ekind (Item_Id) in E_Abstract_State
1155 and then Present (Encapsulating_State (Item_Id))
1157 Append_New_Elmt (Item_Id, Constits_Seen);
1160 -- All other input/output items are illegal
1161 -- (SPARK RM 6.1.5(1)).
1165 ("item must denote parameter, variable, state or "
1166 & "current instance of concurrent type", Item);
1169 -- All other input/output items are illegal
1170 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1174 ("item must denote parameter, variable, state or current "
1175 & "instance of concurrent type", Item);
1178 end Analyze_Input_Output;
1186 Non_Null_Output_Seen : Boolean := False;
1187 -- Flag used to check the legality of an output list
1189 -- Start of processing for Analyze_Dependency_Clause
1192 Inputs := Expression (Clause);
1195 -- An input list with a self-dependency appears as operator "+" where
1196 -- the actuals inputs are the right operand.
1198 if Nkind (Inputs) = N_Op_Plus then
1199 Inputs := Right_Opnd (Inputs);
1203 -- Process the output_list of a dependency_clause
1205 Output := First (Choices (Clause));
1206 while Present (Output) loop
1207 Analyze_Input_Output
1210 Self_Ref => Self_Ref,
1212 Seen => All_Outputs_Seen,
1213 Null_Seen => Null_Output_Seen,
1214 Non_Null_Seen => Non_Null_Output_Seen);
1219 -- Process the input_list of a dependency_clause
1221 Analyze_Input_List (Inputs);
1222 end Analyze_Dependency_Clause;
1224 ---------------------------
1225 -- Check_Function_Return --
1226 ---------------------------
1228 procedure Check_Function_Return is
1230 if Ekind (Spec_Id) in E_Function | E_Generic_Function
1231 and then not Result_Seen
1234 ("result of & must appear in exactly one output list",
1237 end Check_Function_Return;
1243 procedure Check_Role
1245 Item_Id : Entity_Id;
1250 (Item_Is_Input : out Boolean;
1251 Item_Is_Output : out Boolean);
1252 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1253 -- Item_Is_Output are set depending on the role.
1255 procedure Role_Error
1256 (Item_Is_Input : Boolean;
1257 Item_Is_Output : Boolean);
1258 -- Emit an error message concerning the incorrect use of Item in
1259 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1260 -- denote whether the item is an input and/or an output.
1267 (Item_Is_Input : out Boolean;
1268 Item_Is_Output : out Boolean)
1270 -- A constant or IN parameter of access type should be handled
1271 -- like a variable, as the underlying memory pointed-to can be
1272 -- modified. Use Adjusted_Kind to do this adjustment.
1274 Adjusted_Kind : Entity_Kind := Ekind (Item_Id);
1277 if Ekind (Item_Id) in E_Constant
1278 | E_Generic_In_Parameter
1280 and then Is_Access_Type (Etype (Item_Id))
1282 Adjusted_Kind := E_Variable;
1285 case Adjusted_Kind is
1289 when E_Abstract_State =>
1291 -- When pragma Global is present it determines the mode of
1292 -- the abstract state.
1295 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1296 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1298 -- Otherwise the state has a default IN OUT mode, because it
1299 -- behaves as a variable.
1302 Item_Is_Input := True;
1303 Item_Is_Output := True;
1306 -- Constants and IN parameters
1309 | E_Generic_In_Parameter
1313 -- When pragma Global is present it determines the mode
1314 -- of constant objects as inputs (and such objects cannot
1315 -- appear as outputs in the Global contract).
1318 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1320 Item_Is_Input := True;
1323 Item_Is_Output := False;
1325 -- Variables and IN OUT parameters, as well as constants and
1326 -- IN parameters of access type which are handled like
1329 when E_Generic_In_Out_Parameter
1330 | E_In_Out_Parameter
1333 -- When pragma Global is present it determines the mode of
1338 -- A variable has mode IN when its type is unconstrained
1339 -- or tagged because array bounds, discriminants or tags
1343 Appears_In (Subp_Inputs, Item_Id)
1344 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1346 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1348 -- Otherwise the variable has a default IN OUT mode
1351 Item_Is_Input := True;
1352 Item_Is_Output := True;
1355 when E_Out_Parameter =>
1357 -- An OUT parameter of the related subprogram; it cannot
1358 -- appear in Global.
1360 if Scope (Item_Id) = Spec_Id then
1362 -- The parameter has mode IN if its type is unconstrained
1363 -- or tagged because array bounds, discriminants or tags
1367 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1369 Item_Is_Output := True;
1371 -- An OUT parameter of an enclosing subprogram; it can
1372 -- appear in Global and behaves as a read-write variable.
1375 -- When pragma Global is present it determines the mode
1380 -- A variable has mode IN when its type is
1381 -- unconstrained or tagged because array
1382 -- bounds, discriminants or tags can be read.
1385 Appears_In (Subp_Inputs, Item_Id)
1386 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1388 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1390 -- Otherwise the variable has a default IN OUT mode
1393 Item_Is_Input := True;
1394 Item_Is_Output := True;
1400 when E_Protected_Type =>
1403 -- A variable has mode IN when its type is unconstrained
1404 -- or tagged because array bounds, discriminants or tags
1408 Appears_In (Subp_Inputs, Item_Id)
1409 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1411 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1414 -- A protected type acts as a formal parameter of mode IN
1415 -- when it applies to a protected function.
1417 if Ekind (Spec_Id) = E_Function then
1418 Item_Is_Input := True;
1419 Item_Is_Output := False;
1421 -- Otherwise the protected type acts as a formal of mode
1425 Item_Is_Input := True;
1426 Item_Is_Output := True;
1434 -- When pragma Global is present it determines the mode of
1439 Appears_In (Subp_Inputs, Item_Id)
1440 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1442 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1444 -- Otherwise task types act as IN OUT parameters
1447 Item_Is_Input := True;
1448 Item_Is_Output := True;
1452 raise Program_Error;
1460 procedure Role_Error
1461 (Item_Is_Input : Boolean;
1462 Item_Is_Output : Boolean)
1464 Error_Msg : Name_Id;
1469 -- When the item is not part of the input and the output set of
1470 -- the related subprogram, then it appears as extra in pragma
1471 -- [Refined_]Depends.
1473 if not Item_Is_Input and then not Item_Is_Output then
1474 Add_Item_To_Name_Buffer (Item_Id);
1475 Add_Str_To_Name_Buffer
1476 (" & cannot appear in dependence relation");
1478 Error_Msg := Name_Find;
1479 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1481 Error_Msg_Name_1 := Chars (Spec_Id);
1483 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1484 & "set of subprogram %"), Item, Item_Id);
1486 -- The mode of the item and its role in pragma [Refined_]Depends
1487 -- are in conflict. Construct a detailed message explaining the
1488 -- illegality (SPARK RM 6.1.5(5-6)).
1491 if Item_Is_Input then
1492 Add_Str_To_Name_Buffer ("read-only");
1494 Add_Str_To_Name_Buffer ("write-only");
1497 Add_Char_To_Name_Buffer (' ');
1498 Add_Item_To_Name_Buffer (Item_Id);
1499 Add_Str_To_Name_Buffer (" & cannot appear as ");
1501 if Item_Is_Input then
1502 Add_Str_To_Name_Buffer ("output");
1504 Add_Str_To_Name_Buffer ("input");
1507 Add_Str_To_Name_Buffer (" in dependence relation");
1508 Error_Msg := Name_Find;
1509 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1515 Item_Is_Input : Boolean;
1516 Item_Is_Output : Boolean;
1518 -- Start of processing for Check_Role
1521 Find_Role (Item_Is_Input, Item_Is_Output);
1526 if not Item_Is_Input then
1527 Role_Error (Item_Is_Input, Item_Is_Output);
1530 -- Self-referential item
1533 if not Item_Is_Input or else not Item_Is_Output then
1534 Role_Error (Item_Is_Input, Item_Is_Output);
1539 elsif not Item_Is_Output then
1540 Role_Error (Item_Is_Input, Item_Is_Output);
1548 procedure Check_Usage
1549 (Subp_Items : Elist_Id;
1550 Used_Items : Elist_Id;
1553 procedure Usage_Error (Item_Id : Entity_Id);
1554 -- Emit an error concerning the illegal usage of an item
1560 procedure Usage_Error (Item_Id : Entity_Id) is
1561 Error_Msg : Name_Id;
1568 -- Unconstrained and tagged items are not part of the explicit
1569 -- input set of the related subprogram, they do not have to be
1570 -- present in a dependence relation and should not be flagged
1571 -- (SPARK RM 6.1.5(5)).
1573 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1576 Add_Item_To_Name_Buffer (Item_Id);
1577 Add_Str_To_Name_Buffer
1578 (" & is missing from input dependence list");
1580 Error_Msg := Name_Find;
1581 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1583 ("\add `null ='> &` dependency to ignore this input",
1587 -- Output case (SPARK RM 6.1.5(10))
1592 Add_Item_To_Name_Buffer (Item_Id);
1593 Add_Str_To_Name_Buffer
1594 (" & is missing from output dependence list");
1596 Error_Msg := Name_Find;
1597 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1605 Item_Id : Entity_Id;
1607 -- Start of processing for Check_Usage
1610 if No (Subp_Items) then
1614 -- Each input or output of the subprogram must appear in a dependency
1617 Elmt := First_Elmt (Subp_Items);
1618 while Present (Elmt) loop
1619 Item := Node (Elmt);
1621 if Nkind (Item) = N_Defining_Identifier then
1624 Item_Id := Entity_Of (Item);
1627 -- The item does not appear in a dependency
1629 if Present (Item_Id)
1630 and then not Contains (Used_Items, Item_Id)
1632 if Is_Formal (Item_Id) then
1633 Usage_Error (Item_Id);
1635 -- The current instance of a protected type behaves as a formal
1636 -- parameter (SPARK RM 6.1.4).
1638 elsif Ekind (Item_Id) = E_Protected_Type
1639 or else Is_Single_Protected_Object (Item_Id)
1641 Usage_Error (Item_Id);
1643 -- The current instance of a task type behaves as a formal
1644 -- parameter (SPARK RM 6.1.4).
1646 elsif Ekind (Item_Id) = E_Task_Type
1647 or else Is_Single_Task_Object (Item_Id)
1649 -- The dependence of a task unit on itself is implicit and
1650 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1651 -- Emit an error if only one input/output is present.
1653 if Task_Input_Seen /= Task_Output_Seen then
1654 Usage_Error (Item_Id);
1657 -- States and global objects are not used properly only when
1658 -- the subprogram is subject to pragma Global.
1660 elsif Global_Seen then
1661 Usage_Error (Item_Id);
1669 ----------------------
1670 -- Normalize_Clause --
1671 ----------------------
1673 procedure Normalize_Clause (Clause : Node_Id) is
1674 procedure Create_Or_Modify_Clause
1680 Multiple : Boolean);
1681 -- Create a brand new clause to represent the self-reference or
1682 -- modify the input and/or output lists of an existing clause. Output
1683 -- denotes a self-referencial output. Outputs is the output list of a
1684 -- clause. Inputs is the input list of a clause. After denotes the
1685 -- clause after which the new clause is to be inserted. Flag In_Place
1686 -- should be set when normalizing the last output of an output list.
1687 -- Flag Multiple should be set when Output comes from a list with
1690 -----------------------------
1691 -- Create_Or_Modify_Clause --
1692 -----------------------------
1694 procedure Create_Or_Modify_Clause
1702 procedure Propagate_Output
1705 -- Handle the various cases of output propagation to the input
1706 -- list. Output denotes a self-referencial output item. Inputs
1707 -- is the input list of a clause.
1709 ----------------------
1710 -- Propagate_Output --
1711 ----------------------
1713 procedure Propagate_Output
1717 function In_Input_List
1719 Inputs : List_Id) return Boolean;
1720 -- Determine whether a particulat item appears in the input
1721 -- list of a clause.
1727 function In_Input_List
1729 Inputs : List_Id) return Boolean
1734 Elmt := First (Inputs);
1735 while Present (Elmt) loop
1736 if Entity_Of (Elmt) = Item then
1748 Output_Id : constant Entity_Id := Entity_Of (Output);
1751 -- Start of processing for Propagate_Output
1754 -- The clause is of the form:
1756 -- (Output =>+ null)
1758 -- Remove null input and replace it with a copy of the output:
1760 -- (Output => Output)
1762 if Nkind (Inputs) = N_Null then
1763 Rewrite (Inputs, New_Copy_Tree (Output));
1765 -- The clause is of the form:
1767 -- (Output =>+ (Input1, ..., InputN))
1769 -- Determine whether the output is not already mentioned in the
1770 -- input list and if not, add it to the list of inputs:
1772 -- (Output => (Output, Input1, ..., InputN))
1774 elsif Nkind (Inputs) = N_Aggregate then
1775 Grouped := Expressions (Inputs);
1777 if not In_Input_List
1781 Prepend_To (Grouped, New_Copy_Tree (Output));
1784 -- The clause is of the form:
1786 -- (Output =>+ Input)
1788 -- If the input does not mention the output, group the two
1791 -- (Output => (Output, Input))
1793 elsif Entity_Of (Inputs) /= Output_Id then
1795 Make_Aggregate (Loc,
1796 Expressions => New_List (
1797 New_Copy_Tree (Output),
1798 New_Copy_Tree (Inputs))));
1800 end Propagate_Output;
1804 Loc : constant Source_Ptr := Sloc (Clause);
1805 New_Clause : Node_Id;
1807 -- Start of processing for Create_Or_Modify_Clause
1810 -- A null output depending on itself does not require any
1813 if Nkind (Output) = N_Null then
1816 -- A function result cannot depend on itself because it cannot
1817 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1819 elsif Is_Attribute_Result (Output) then
1820 SPARK_Msg_N ("function result cannot depend on itself", Output);
1824 -- When performing the transformation in place, simply add the
1825 -- output to the list of inputs (if not already there). This
1826 -- case arises when dealing with the last output of an output
1827 -- list. Perform the normalization in place to avoid generating
1828 -- a malformed tree.
1831 Propagate_Output (Output, Inputs);
1833 -- A list with multiple outputs is slowly trimmed until only
1834 -- one element remains. When this happens, replace aggregate
1835 -- with the element itself.
1839 Rewrite (Outputs, Output);
1845 -- Unchain the output from its output list as it will appear in
1846 -- a new clause. Note that we cannot simply rewrite the output
1847 -- as null because this will violate the semantics of pragma
1852 -- Generate a new clause of the form:
1853 -- (Output => Inputs)
1856 Make_Component_Association (Loc,
1857 Choices => New_List (Output),
1858 Expression => New_Copy_Tree (Inputs));
1860 -- The new clause contains replicated content that has already
1861 -- been analyzed. There is not need to reanalyze or renormalize
1864 Set_Analyzed (New_Clause);
1867 (Output => First (Choices (New_Clause)),
1868 Inputs => Expression (New_Clause));
1870 Insert_After (After, New_Clause);
1872 end Create_Or_Modify_Clause;
1876 Outputs : constant Node_Id := First (Choices (Clause));
1878 Last_Output : Node_Id;
1879 Next_Output : Node_Id;
1882 -- Start of processing for Normalize_Clause
1885 -- A self-dependency appears as operator "+". Remove the "+" from the
1886 -- tree by moving the real inputs to their proper place.
1888 if Nkind (Expression (Clause)) = N_Op_Plus then
1889 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1890 Inputs := Expression (Clause);
1892 -- Multiple outputs appear as an aggregate
1894 if Nkind (Outputs) = N_Aggregate then
1895 Last_Output := Last (Expressions (Outputs));
1897 Output := First (Expressions (Outputs));
1898 while Present (Output) loop
1900 -- Normalization may remove an output from its list,
1901 -- preserve the subsequent output now.
1903 Next_Output := Next (Output);
1905 Create_Or_Modify_Clause
1910 In_Place => Output = Last_Output,
1913 Output := Next_Output;
1919 Create_Or_Modify_Clause
1928 end Normalize_Clause;
1932 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1933 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1937 Last_Clause : Node_Id;
1938 Restore_Scope : Boolean := False;
1940 -- Start of processing for Analyze_Depends_In_Decl_Part
1943 -- Do not analyze the pragma multiple times
1945 if Is_Analyzed_Pragma (N) then
1949 -- Empty dependency list
1951 if Nkind (Deps) = N_Null then
1953 -- Gather all states, objects and formal parameters that the
1954 -- subprogram may depend on. These items are obtained from the
1955 -- parameter profile or pragma [Refined_]Global (if available).
1957 Collect_Subprogram_Inputs_Outputs
1958 (Subp_Id => Subp_Id,
1959 Subp_Inputs => Subp_Inputs,
1960 Subp_Outputs => Subp_Outputs,
1961 Global_Seen => Global_Seen);
1963 -- Verify that every input or output of the subprogram appear in a
1966 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1967 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1968 Check_Function_Return;
1970 -- Dependency clauses appear as component associations of an aggregate
1972 elsif Nkind (Deps) = N_Aggregate then
1974 -- Do not attempt to perform analysis of a syntactically illegal
1975 -- clause as this will lead to misleading errors.
1977 if Has_Extra_Parentheses (Deps) then
1981 if Present (Component_Associations (Deps)) then
1982 Last_Clause := Last (Component_Associations (Deps));
1984 -- Gather all states, objects and formal parameters that the
1985 -- subprogram may depend on. These items are obtained from the
1986 -- parameter profile or pragma [Refined_]Global (if available).
1988 Collect_Subprogram_Inputs_Outputs
1989 (Subp_Id => Subp_Id,
1990 Subp_Inputs => Subp_Inputs,
1991 Subp_Outputs => Subp_Outputs,
1992 Global_Seen => Global_Seen);
1994 -- When pragma [Refined_]Depends appears on a single concurrent
1995 -- type, it is relocated to the anonymous object.
1997 if Is_Single_Concurrent_Object (Spec_Id) then
2000 -- Ensure that the formal parameters are visible when analyzing
2001 -- all clauses. This falls out of the general rule of aspects
2002 -- pertaining to subprogram declarations.
2004 elsif not In_Open_Scopes (Spec_Id) then
2005 Restore_Scope := True;
2006 Push_Scope (Spec_Id);
2008 if Ekind (Spec_Id) = E_Task_Type then
2010 -- Task discriminants cannot appear in the [Refined_]Depends
2011 -- contract, but must be present for the analysis so that we
2012 -- can reject them with an informative error message.
2014 if Has_Discriminants (Spec_Id) then
2015 Install_Discriminants (Spec_Id);
2018 elsif Is_Generic_Subprogram (Spec_Id) then
2019 Install_Generic_Formals (Spec_Id);
2022 Install_Formals (Spec_Id);
2026 Clause := First (Component_Associations (Deps));
2027 while Present (Clause) loop
2028 Errors := Serious_Errors_Detected;
2030 -- The normalization mechanism may create extra clauses that
2031 -- contain replicated input and output names. There is no need
2032 -- to reanalyze them.
2034 if not Analyzed (Clause) then
2035 Set_Analyzed (Clause);
2037 Analyze_Dependency_Clause
2039 Is_Last => Clause = Last_Clause);
2042 -- Do not normalize a clause if errors were detected (count
2043 -- of Serious_Errors has increased) because the inputs and/or
2044 -- outputs may denote illegal items.
2046 if Serious_Errors_Detected = Errors then
2047 Normalize_Clause (Clause);
2053 if Restore_Scope then
2057 -- Verify that every input or output of the subprogram appear in a
2060 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2061 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2062 Check_Function_Return;
2064 -- The dependency list is malformed. This is a syntax error, always
2068 Error_Msg_N ("malformed dependency relation", Deps);
2072 -- The top level dependency relation is malformed. This is a syntax
2073 -- error, always report.
2076 Error_Msg_N ("malformed dependency relation", Deps);
2080 -- Ensure that a state and a corresponding constituent do not appear
2081 -- together in pragma [Refined_]Depends.
2083 Check_State_And_Constituent_Use
2084 (States => States_Seen,
2085 Constits => Constits_Seen,
2089 Set_Is_Analyzed_Pragma (N);
2090 end Analyze_Depends_In_Decl_Part;
2092 --------------------------------------------
2093 -- Analyze_External_Property_In_Decl_Part --
2094 --------------------------------------------
2096 procedure Analyze_External_Property_In_Decl_Part
2098 Expr_Val : out Boolean)
2100 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2101 Arg1 : constant Node_Id :=
2102 First (Pragma_Argument_Associations (N));
2103 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2104 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2108 -- Do not analyze the pragma multiple times, but set the output
2109 -- parameter to the argument specified by the pragma.
2111 if Is_Analyzed_Pragma (N) then
2115 Error_Msg_Name_1 := Pragma_Name (N);
2117 -- An external property pragma must apply to an effectively volatile
2118 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2119 -- The check is performed at the end of the declarative region due to a
2120 -- possible out-of-order arrangement of pragmas:
2123 -- pragma Async_Readers (Obj);
2124 -- pragma Volatile (Obj);
2126 if Prag_Id /= Pragma_No_Caching
2127 and then not Is_Effectively_Volatile (Obj_Id)
2129 if Ekind (Obj_Id) = E_Variable
2130 and then No_Caching_Enabled (Obj_Id)
2133 ("illegal combination of external property % and property "
2134 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2137 ("external property % must apply to a volatile type or object",
2141 -- Pragma No_Caching should only apply to volatile variables of
2142 -- a non-effectively volatile type (SPARK RM 7.1.2).
2144 elsif Prag_Id = Pragma_No_Caching then
2145 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2146 SPARK_Msg_N ("property % must not apply to an object of "
2147 & "an effectively volatile type", N);
2148 elsif not Is_Volatile (Obj_Id) then
2149 SPARK_Msg_N ("property % must apply to a volatile object", N);
2153 Set_Is_Analyzed_Pragma (N);
2157 -- Ensure that the Boolean expression (if present) is static. A missing
2158 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2162 if Present (Arg1) then
2163 Expr := Get_Pragma_Arg (Arg1);
2165 if Is_OK_Static_Expression (Expr) then
2166 Expr_Val := Is_True (Expr_Value (Expr));
2170 end Analyze_External_Property_In_Decl_Part;
2172 ---------------------------------
2173 -- Analyze_Global_In_Decl_Part --
2174 ---------------------------------
2176 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2177 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2178 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2179 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2181 Constits_Seen : Elist_Id := No_Elist;
2182 -- A list containing the entities of all constituents processed so far.
2183 -- It aids in detecting illegal usage of a state and a corresponding
2184 -- constituent in pragma [Refinde_]Global.
2186 Seen : Elist_Id := No_Elist;
2187 -- A list containing the entities of all the items processed so far. It
2188 -- plays a role in detecting distinct entities.
2190 States_Seen : Elist_Id := No_Elist;
2191 -- A list containing the entities of all states processed so far. It
2192 -- helps in detecting illegal usage of a state and a corresponding
2193 -- constituent in pragma [Refined_]Global.
2195 In_Out_Seen : Boolean := False;
2196 Input_Seen : Boolean := False;
2197 Output_Seen : Boolean := False;
2198 Proof_Seen : Boolean := False;
2199 -- Flags used to verify the consistency of modes
2201 procedure Analyze_Global_List
2203 Global_Mode : Name_Id := Name_Input);
2204 -- Verify the legality of a single global list declaration. Global_Mode
2205 -- denotes the current mode in effect.
2207 -------------------------
2208 -- Analyze_Global_List --
2209 -------------------------
2211 procedure Analyze_Global_List
2213 Global_Mode : Name_Id := Name_Input)
2215 procedure Analyze_Global_Item
2217 Global_Mode : Name_Id);
2218 -- Verify the legality of a single global item declaration denoted by
2219 -- Item. Global_Mode denotes the current mode in effect.
2221 procedure Check_Duplicate_Mode
2223 Status : in out Boolean);
2224 -- Flag Status denotes whether a particular mode has been seen while
2225 -- processing a global list. This routine verifies that Mode is not a
2226 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2228 procedure Check_Mode_Restriction_In_Enclosing_Context
2230 Item_Id : Entity_Id);
2231 -- Verify that an item of mode In_Out or Output does not appear as
2232 -- an input in the Global aspect of an enclosing subprogram or task
2233 -- unit. If this is the case, emit an error. Item and Item_Id are
2234 -- respectively the item and its entity.
2236 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2237 -- Mode denotes either In_Out or Output. Depending on the kind of the
2238 -- related subprogram, emit an error if those two modes apply to a
2239 -- function (SPARK RM 6.1.4(10)).
2241 -------------------------
2242 -- Analyze_Global_Item --
2243 -------------------------
2245 procedure Analyze_Global_Item
2247 Global_Mode : Name_Id)
2249 Item_Id : Entity_Id;
2252 -- Detect one of the following cases
2254 -- with Global => (null, Name)
2255 -- with Global => (Name_1, null, Name_2)
2256 -- with Global => (Name, null)
2258 if Nkind (Item) = N_Null then
2259 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2264 Resolve_State (Item);
2266 -- Find the entity of the item. If this is a renaming, climb the
2267 -- renaming chain to reach the root object. Renamings of non-
2268 -- entire objects do not yield an entity (Empty).
2270 Item_Id := Entity_Of (Item);
2272 if Present (Item_Id) then
2274 -- A global item may denote a formal parameter of an enclosing
2275 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2276 -- provide a better error diagnostic.
2278 if Is_Formal (Item_Id) then
2279 if Scope (Item_Id) = Spec_Id then
2281 (Fix_Msg (Spec_Id, "global item cannot reference "
2282 & "parameter of subprogram &"), Item, Spec_Id);
2286 -- A global item may denote a concurrent type as long as it is
2287 -- the current instance of an enclosing protected or task type
2288 -- (SPARK RM 6.1.4).
2290 elsif Ekind (Item_Id) in E_Protected_Type | E_Task_Type then
2291 if Is_CCT_Instance (Item_Id, Spec_Id) then
2293 -- Pragma [Refined_]Global associated with a protected
2294 -- subprogram cannot mention the current instance of a
2295 -- protected type because the instance behaves as a
2296 -- formal parameter.
2298 if Ekind (Item_Id) = E_Protected_Type then
2299 if Scope (Spec_Id) = Item_Id then
2300 Error_Msg_Name_1 := Chars (Item_Id);
2302 (Fix_Msg (Spec_Id, "global item of subprogram & "
2303 & "cannot reference current instance of "
2304 & "protected type %"), Item, Spec_Id);
2308 -- Pragma [Refined_]Global associated with a task type
2309 -- cannot mention the current instance of a task type
2310 -- because the instance behaves as a formal parameter.
2312 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2313 if Spec_Id = Item_Id then
2314 Error_Msg_Name_1 := Chars (Item_Id);
2316 (Fix_Msg (Spec_Id, "global item of subprogram & "
2317 & "cannot reference current instance of task "
2318 & "type %"), Item, Spec_Id);
2323 -- Otherwise the global item denotes a subtype mark that is
2324 -- not a current instance.
2328 ("invalid use of subtype mark in global list", Item);
2332 -- A global item may denote the anonymous object created for a
2333 -- single protected/task type as long as the current instance
2334 -- is the same single type (SPARK RM 6.1.4).
2336 elsif Is_Single_Concurrent_Object (Item_Id)
2337 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2339 -- Pragma [Refined_]Global associated with a protected
2340 -- subprogram cannot mention the current instance of a
2341 -- protected type because the instance behaves as a formal
2344 if Is_Single_Protected_Object (Item_Id) then
2345 if Scope (Spec_Id) = Etype (Item_Id) then
2346 Error_Msg_Name_1 := Chars (Item_Id);
2348 (Fix_Msg (Spec_Id, "global item of subprogram & "
2349 & "cannot reference current instance of protected "
2350 & "type %"), Item, Spec_Id);
2354 -- Pragma [Refined_]Global associated with a task type
2355 -- cannot mention the current instance of a task type
2356 -- because the instance behaves as a formal parameter.
2358 else pragma Assert (Is_Single_Task_Object (Item_Id));
2359 if Spec_Id = Item_Id then
2360 Error_Msg_Name_1 := Chars (Item_Id);
2362 (Fix_Msg (Spec_Id, "global item of subprogram & "
2363 & "cannot reference current instance of task "
2364 & "type %"), Item, Spec_Id);
2369 -- A formal object may act as a global item inside a generic
2371 elsif Is_Formal_Object (Item_Id) then
2374 -- The only legal references are those to abstract states,
2375 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2377 elsif Ekind (Item_Id) not in E_Abstract_State
2383 ("global item must denote object, state or current "
2384 & "instance of concurrent type", Item);
2386 if Is_Named_Number (Item_Id) then
2388 ("\named number & is not an object", Item, Item_Id);
2394 -- State related checks
2396 if Ekind (Item_Id) = E_Abstract_State then
2398 -- Package and subprogram bodies are instantiated
2399 -- individually in a separate compiler pass. Due to this
2400 -- mode of instantiation, the refinement of a state may
2401 -- no longer be visible when a subprogram body contract
2402 -- is instantiated. Since the generic template is legal,
2403 -- do not perform this check in the instance to circumvent
2409 -- An abstract state with visible refinement cannot appear
2410 -- in pragma [Refined_]Global as its place must be taken by
2411 -- some of its constituents (SPARK RM 6.1.4(7)).
2413 elsif Has_Visible_Refinement (Item_Id) then
2415 ("cannot mention state & in global refinement",
2417 SPARK_Msg_N ("\use its constituents instead", Item);
2420 -- An external state cannot appear as a global item of a
2421 -- nonvolatile function (SPARK RM 7.1.3(8)).
2423 elsif Is_External_State (Item_Id)
2424 and then Ekind (Spec_Id) in E_Function | E_Generic_Function
2425 and then not Is_Volatile_Function (Spec_Id)
2428 ("external state & cannot act as global item of "
2429 & "nonvolatile function", Item, Item_Id);
2432 -- If the reference to the abstract state appears in an
2433 -- enclosing package body that will eventually refine the
2434 -- state, record the reference for future checks.
2437 Record_Possible_Body_Reference
2438 (State_Id => Item_Id,
2442 -- Constant related checks
2444 elsif Ekind (Item_Id) = E_Constant
2445 and then not Is_Access_Type (Etype (Item_Id))
2448 -- Unless it is of an access type, a constant is a read-only
2449 -- item, therefore it cannot act as an output.
2451 if Global_Mode in Name_In_Out | Name_Output then
2453 ("constant & cannot act as output", Item, Item_Id);
2457 -- Loop parameter related checks
2459 elsif Ekind (Item_Id) = E_Loop_Parameter then
2461 -- A loop parameter is a read-only item, therefore it cannot
2462 -- act as an output.
2464 if Global_Mode in Name_In_Out | Name_Output then
2466 ("loop parameter & cannot act as output",
2471 -- Variable related checks. These are only relevant when
2472 -- SPARK_Mode is on as they are not standard Ada legality
2475 elsif SPARK_Mode = On
2476 and then Ekind (Item_Id) = E_Variable
2477 and then Is_Effectively_Volatile_For_Reading (Item_Id)
2479 -- The current instance of a protected unit is not an
2480 -- effectively volatile object, unless the protected unit
2481 -- is already volatile for another reason (SPARK RM 7.1.2).
2483 if Is_Single_Protected_Object (Item_Id)
2484 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2485 and then not Is_Effectively_Volatile_For_Reading
2486 (Item_Id, Ignore_Protected => True)
2490 -- An effectively volatile object for reading cannot appear
2491 -- as a global item of a nonvolatile function (SPARK RM
2494 elsif Ekind (Spec_Id) in E_Function | E_Generic_Function
2495 and then not Is_Volatile_Function (Spec_Id)
2498 ("volatile object & cannot act as global item of a "
2499 & "function", Item, Item_Id);
2502 -- An effectively volatile object with external property
2503 -- Effective_Reads set to True must have mode Output or
2504 -- In_Out (SPARK RM 7.1.3(10)).
2506 elsif Effective_Reads_Enabled (Item_Id)
2507 and then Global_Mode = Name_Input
2510 ("volatile object & with property Effective_Reads must "
2511 & "have mode In_Out or Output", Item, Item_Id);
2516 -- When the item renames an entire object, replace the item
2517 -- with a reference to the object.
2519 if Entity (Item) /= Item_Id then
2520 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2524 -- Some form of illegal construct masquerading as a name
2525 -- (SPARK RM 6.1.4(4)).
2529 ("global item must denote object, state or current instance "
2530 & "of concurrent type", Item);
2534 -- Verify that an output does not appear as an input in an
2535 -- enclosing subprogram.
2537 if Global_Mode in Name_In_Out | Name_Output then
2538 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2541 -- The same entity might be referenced through various way.
2542 -- Check the entity of the item rather than the item itself
2543 -- (SPARK RM 6.1.4(10)).
2545 if Contains (Seen, Item_Id) then
2546 SPARK_Msg_N ("duplicate global item", Item);
2548 -- Add the entity of the current item to the list of processed
2552 Append_New_Elmt (Item_Id, Seen);
2554 if Ekind (Item_Id) = E_Abstract_State then
2555 Append_New_Elmt (Item_Id, States_Seen);
2557 -- The variable may eventually become a constituent of a single
2558 -- protected/task type. Record the reference now and verify its
2559 -- legality when analyzing the contract of the variable
2562 elsif Ekind (Item_Id) = E_Variable then
2563 Record_Possible_Part_Of_Reference
2568 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
2569 and then Present (Encapsulating_State (Item_Id))
2571 Append_New_Elmt (Item_Id, Constits_Seen);
2574 end Analyze_Global_Item;
2576 --------------------------
2577 -- Check_Duplicate_Mode --
2578 --------------------------
2580 procedure Check_Duplicate_Mode
2582 Status : in out Boolean)
2586 SPARK_Msg_N ("duplicate global mode", Mode);
2590 end Check_Duplicate_Mode;
2592 -------------------------------------------------
2593 -- Check_Mode_Restriction_In_Enclosing_Context --
2594 -------------------------------------------------
2596 procedure Check_Mode_Restriction_In_Enclosing_Context
2598 Item_Id : Entity_Id)
2600 Context : Entity_Id;
2602 Inputs : Elist_Id := No_Elist;
2603 Outputs : Elist_Id := No_Elist;
2606 -- Traverse the scope stack looking for enclosing subprograms or
2607 -- tasks subject to pragma [Refined_]Global.
2609 Context := Scope (Subp_Id);
2610 while Present (Context) and then Context /= Standard_Standard loop
2612 -- For a single task type, retrieve the corresponding object to
2613 -- which pragma [Refined_]Global is attached.
2615 if Ekind (Context) = E_Task_Type
2616 and then Is_Single_Concurrent_Type (Context)
2618 Context := Anonymous_Object (Context);
2621 if (Is_Subprogram (Context)
2622 or else Ekind (Context) = E_Task_Type
2623 or else Is_Single_Task_Object (Context))
2625 (Present (Get_Pragma (Context, Pragma_Global))
2627 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2629 Collect_Subprogram_Inputs_Outputs
2630 (Subp_Id => Context,
2631 Subp_Inputs => Inputs,
2632 Subp_Outputs => Outputs,
2633 Global_Seen => Dummy);
2635 -- The item is classified as In_Out or Output but appears as
2636 -- an Input in an enclosing subprogram or task unit (SPARK
2639 if Appears_In (Inputs, Item_Id)
2640 and then not Appears_In (Outputs, Item_Id)
2643 ("global item & cannot have mode In_Out or Output",
2646 if Is_Subprogram (Context) then
2648 (Fix_Msg (Subp_Id, "\item already appears as input "
2649 & "of subprogram &"), Item, Context);
2652 (Fix_Msg (Subp_Id, "\item already appears as input "
2653 & "of task &"), Item, Context);
2656 -- Stop the traversal once an error has been detected
2662 Context := Scope (Context);
2664 end Check_Mode_Restriction_In_Enclosing_Context;
2666 ----------------------------------------
2667 -- Check_Mode_Restriction_In_Function --
2668 ----------------------------------------
2670 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2672 if Ekind (Spec_Id) in E_Function | E_Generic_Function then
2674 ("global mode & is not applicable to functions", Mode);
2676 end Check_Mode_Restriction_In_Function;
2684 -- Start of processing for Analyze_Global_List
2687 if Nkind (List) = N_Null then
2688 Set_Analyzed (List);
2690 -- Single global item declaration
2692 elsif Nkind (List) in N_Expanded_Name
2694 | N_Selected_Component
2696 Analyze_Global_Item (List, Global_Mode);
2698 -- Simple global list or moded global list declaration
2700 elsif Nkind (List) = N_Aggregate then
2701 Set_Analyzed (List);
2703 -- The declaration of a simple global list appear as a collection
2706 if Present (Expressions (List)) then
2707 if Present (Component_Associations (List)) then
2709 ("cannot mix moded and non-moded global lists", List);
2712 Item := First (Expressions (List));
2713 while Present (Item) loop
2714 Analyze_Global_Item (Item, Global_Mode);
2718 -- The declaration of a moded global list appears as a collection
2719 -- of component associations where individual choices denote
2722 elsif Present (Component_Associations (List)) then
2723 if Present (Expressions (List)) then
2725 ("cannot mix moded and non-moded global lists", List);
2728 Assoc := First (Component_Associations (List));
2729 while Present (Assoc) loop
2730 Mode := First (Choices (Assoc));
2732 if Nkind (Mode) = N_Identifier then
2733 if Chars (Mode) = Name_In_Out then
2734 Check_Duplicate_Mode (Mode, In_Out_Seen);
2735 Check_Mode_Restriction_In_Function (Mode);
2737 elsif Chars (Mode) = Name_Input then
2738 Check_Duplicate_Mode (Mode, Input_Seen);
2740 elsif Chars (Mode) = Name_Output then
2741 Check_Duplicate_Mode (Mode, Output_Seen);
2742 Check_Mode_Restriction_In_Function (Mode);
2744 elsif Chars (Mode) = Name_Proof_In then
2745 Check_Duplicate_Mode (Mode, Proof_Seen);
2748 SPARK_Msg_N ("invalid mode selector", Mode);
2752 SPARK_Msg_N ("invalid mode selector", Mode);
2755 -- Items in a moded list appear as a collection of
2756 -- expressions. Reuse the existing machinery to analyze
2760 (List => Expression (Assoc),
2761 Global_Mode => Chars (Mode));
2769 raise Program_Error;
2772 -- Any other attempt to declare a global item is illegal. This is a
2773 -- syntax error, always report.
2776 Error_Msg_N ("malformed global list", List);
2778 end Analyze_Global_List;
2782 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2784 Restore_Scope : Boolean := False;
2786 -- Start of processing for Analyze_Global_In_Decl_Part
2789 -- Do not analyze the pragma multiple times
2791 if Is_Analyzed_Pragma (N) then
2795 -- There is nothing to be done for a null global list
2797 if Nkind (Items) = N_Null then
2798 Set_Analyzed (Items);
2800 -- Analyze the various forms of global lists and items. Note that some
2801 -- of these may be malformed in which case the analysis emits error
2805 -- When pragma [Refined_]Global appears on a single concurrent type,
2806 -- it is relocated to the anonymous object.
2808 if Is_Single_Concurrent_Object (Spec_Id) then
2811 -- Ensure that the formal parameters are visible when processing an
2812 -- item. This falls out of the general rule of aspects pertaining to
2813 -- subprogram declarations.
2815 elsif not In_Open_Scopes (Spec_Id) then
2816 Restore_Scope := True;
2817 Push_Scope (Spec_Id);
2819 if Ekind (Spec_Id) = E_Task_Type then
2821 -- Task discriminants cannot appear in the [Refined_]Global
2822 -- contract, but must be present for the analysis so that we
2823 -- can reject them with an informative error message.
2825 if Has_Discriminants (Spec_Id) then
2826 Install_Discriminants (Spec_Id);
2829 elsif Is_Generic_Subprogram (Spec_Id) then
2830 Install_Generic_Formals (Spec_Id);
2833 Install_Formals (Spec_Id);
2837 Analyze_Global_List (Items);
2839 if Restore_Scope then
2844 -- Ensure that a state and a corresponding constituent do not appear
2845 -- together in pragma [Refined_]Global.
2847 Check_State_And_Constituent_Use
2848 (States => States_Seen,
2849 Constits => Constits_Seen,
2852 Set_Is_Analyzed_Pragma (N);
2853 end Analyze_Global_In_Decl_Part;
2855 --------------------------------------------
2856 -- Analyze_Initial_Condition_In_Decl_Part --
2857 --------------------------------------------
2859 -- WARNING: This routine manages Ghost regions. Return statements must be
2860 -- replaced by gotos which jump to the end of the routine and restore the
2863 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2864 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2865 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2866 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2868 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2869 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2870 -- Save the Ghost-related attributes to restore on exit
2873 -- Do not analyze the pragma multiple times
2875 if Is_Analyzed_Pragma (N) then
2879 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2880 -- analysis of the pragma, the Ghost mode at point of declaration and
2881 -- point of analysis may not necessarily be the same. Use the mode in
2882 -- effect at the point of declaration.
2886 -- The expression is preanalyzed because it has not been moved to its
2887 -- final place yet. A direct analysis may generate side effects and this
2888 -- is not desired at this point.
2890 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2891 Set_Is_Analyzed_Pragma (N);
2893 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2894 end Analyze_Initial_Condition_In_Decl_Part;
2896 --------------------------------------
2897 -- Analyze_Initializes_In_Decl_Part --
2898 --------------------------------------
2900 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2901 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2902 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2904 Constits_Seen : Elist_Id := No_Elist;
2905 -- A list containing the entities of all constituents processed so far.
2906 -- It aids in detecting illegal usage of a state and a corresponding
2907 -- constituent in pragma Initializes.
2909 Items_Seen : Elist_Id := No_Elist;
2910 -- A list of all initialization items processed so far. This list is
2911 -- used to detect duplicate items.
2913 States_And_Objs : Elist_Id := No_Elist;
2914 -- A list of all abstract states and objects declared in the visible
2915 -- declarations of the related package. This list is used to detect the
2916 -- legality of initialization items.
2918 States_Seen : Elist_Id := No_Elist;
2919 -- A list containing the entities of all states processed so far. It
2920 -- helps in detecting illegal usage of a state and a corresponding
2921 -- constituent in pragma Initializes.
2923 procedure Analyze_Initialization_Item (Item : Node_Id);
2924 -- Verify the legality of a single initialization item
2926 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2927 -- Verify the legality of a single initialization item followed by a
2928 -- list of input items.
2930 procedure Collect_States_And_Objects (Pack_Decl : Node_Id);
2931 -- Inspect the visible declarations of the related package and gather
2932 -- the entities of all abstract states and objects in States_And_Objs.
2934 ---------------------------------
2935 -- Analyze_Initialization_Item --
2936 ---------------------------------
2938 procedure Analyze_Initialization_Item (Item : Node_Id) is
2939 Item_Id : Entity_Id;
2943 Resolve_State (Item);
2945 if Is_Entity_Name (Item) then
2946 Item_Id := Entity_Of (Item);
2948 if Present (Item_Id)
2949 and then Ekind (Item_Id) in
2950 E_Abstract_State | E_Constant | E_Variable
2952 -- When the initialization item is undefined, it appears as
2953 -- Any_Id. Do not continue with the analysis of the item.
2955 if Item_Id = Any_Id then
2958 -- The state or variable must be declared in the visible
2959 -- declarations of the package (SPARK RM 7.1.5(7)).
2961 elsif not Contains (States_And_Objs, Item_Id) then
2962 Error_Msg_Name_1 := Chars (Pack_Id);
2964 ("initialization item & must appear in the visible "
2965 & "declarations of package %", Item, Item_Id);
2967 -- Detect a duplicate use of the same initialization item
2968 -- (SPARK RM 7.1.5(5)).
2970 elsif Contains (Items_Seen, Item_Id) then
2971 SPARK_Msg_N ("duplicate initialization item", Item);
2973 -- The item is legal, add it to the list of processed states
2977 Append_New_Elmt (Item_Id, Items_Seen);
2979 if Ekind (Item_Id) = E_Abstract_State then
2980 Append_New_Elmt (Item_Id, States_Seen);
2983 if Present (Encapsulating_State (Item_Id)) then
2984 Append_New_Elmt (Item_Id, Constits_Seen);
2988 -- The item references something that is not a state or object
2989 -- (SPARK RM 7.1.5(3)).
2993 ("initialization item must denote object or state", Item);
2996 -- Some form of illegal construct masquerading as a name
2997 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3001 ("initialization item must denote object or state", Item);
3003 end Analyze_Initialization_Item;
3005 ---------------------------------------------
3006 -- Analyze_Initialization_Item_With_Inputs --
3007 ---------------------------------------------
3009 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
3010 Inputs_Seen : Elist_Id := No_Elist;
3011 -- A list of all inputs processed so far. This list is used to detect
3012 -- duplicate uses of an input.
3014 Non_Null_Seen : Boolean := False;
3015 Null_Seen : Boolean := False;
3016 -- Flags used to check the legality of an input list
3018 procedure Analyze_Input_Item (Input : Node_Id);
3019 -- Verify the legality of a single input item
3021 ------------------------
3022 -- Analyze_Input_Item --
3023 ------------------------
3025 procedure Analyze_Input_Item (Input : Node_Id) is
3026 Input_Id : Entity_Id;
3031 if Nkind (Input) = N_Null then
3034 ("multiple null initializations not allowed", Item);
3036 elsif Non_Null_Seen then
3038 ("cannot mix null and non-null initialization item", Item);
3046 Non_Null_Seen := True;
3050 ("cannot mix null and non-null initialization item", Item);
3054 Resolve_State (Input);
3056 if Is_Entity_Name (Input) then
3057 Input_Id := Entity_Of (Input);
3059 if Present (Input_Id)
3060 and then Ekind (Input_Id) in E_Abstract_State
3062 | E_Generic_In_Out_Parameter
3063 | E_Generic_In_Parameter
3065 | E_In_Out_Parameter
3071 -- The input cannot denote states or objects declared
3072 -- within the related package (SPARK RM 7.1.5(4)).
3074 if Within_Scope (Input_Id, Current_Scope) then
3076 -- Do not consider generic formal parameters or their
3077 -- respective mappings to generic formals. Even though
3078 -- the formals appear within the scope of the package,
3079 -- it is allowed for an initialization item to depend
3080 -- on an input item.
3082 if Ekind (Input_Id) in E_Generic_In_Out_Parameter
3083 | E_Generic_In_Parameter
3087 elsif Ekind (Input_Id) in E_Constant | E_Variable
3088 and then Present (Corresponding_Generic_Association
3089 (Declaration_Node (Input_Id)))
3094 Error_Msg_Name_1 := Chars (Pack_Id);
3096 ("input item & cannot denote a visible object or "
3097 & "state of package %", Input, Input_Id);
3102 -- Detect a duplicate use of the same input item
3103 -- (SPARK RM 7.1.5(5)).
3105 if Contains (Inputs_Seen, Input_Id) then
3106 SPARK_Msg_N ("duplicate input item", Input);
3110 -- At this point it is known that the input is legal. Add
3111 -- it to the list of processed inputs.
3113 Append_New_Elmt (Input_Id, Inputs_Seen);
3115 if Ekind (Input_Id) = E_Abstract_State then
3116 Append_New_Elmt (Input_Id, States_Seen);
3119 if Ekind (Input_Id) in E_Abstract_State
3122 and then Present (Encapsulating_State (Input_Id))
3124 Append_New_Elmt (Input_Id, Constits_Seen);
3127 -- The input references something that is not a state or an
3128 -- object (SPARK RM 7.1.5(3)).
3132 ("input item must denote object or state", Input);
3135 -- Some form of illegal construct masquerading as a name
3136 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3140 ("input item must denote object or state", Input);
3143 end Analyze_Input_Item;
3147 Inputs : constant Node_Id := Expression (Item);
3151 Name_Seen : Boolean := False;
3152 -- A flag used to detect multiple item names
3154 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3157 -- Inspect the name of an item with inputs
3159 Elmt := First (Choices (Item));
3160 while Present (Elmt) loop
3162 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3165 Analyze_Initialization_Item (Elmt);
3171 -- Multiple input items appear as an aggregate
3173 if Nkind (Inputs) = N_Aggregate then
3174 if Present (Expressions (Inputs)) then
3175 Input := First (Expressions (Inputs));
3176 while Present (Input) loop
3177 Analyze_Input_Item (Input);
3182 if Present (Component_Associations (Inputs)) then
3184 ("inputs must appear in named association form", Inputs);
3187 -- Single input item
3190 Analyze_Input_Item (Inputs);
3192 end Analyze_Initialization_Item_With_Inputs;
3194 --------------------------------
3195 -- Collect_States_And_Objects --
3196 --------------------------------
3198 procedure Collect_States_And_Objects (Pack_Decl : Node_Id) is
3199 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3200 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3202 State_Elmt : Elmt_Id;
3205 -- Collect the abstract states defined in the package (if any)
3207 if Has_Non_Null_Abstract_State (Pack_Id) then
3208 State_Elmt := First_Elmt (Abstract_States (Pack_Id));
3209 while Present (State_Elmt) loop
3210 Append_New_Elmt (Node (State_Elmt), States_And_Objs);
3211 Next_Elmt (State_Elmt);
3215 -- Collect all objects that appear in the visible declarations of the
3218 if Present (Visible_Declarations (Pack_Spec)) then
3219 Decl := First (Visible_Declarations (Pack_Spec));
3220 while Present (Decl) loop
3221 if Comes_From_Source (Decl)
3222 and then Nkind (Decl) in N_Object_Declaration
3223 | N_Object_Renaming_Declaration
3225 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3227 elsif Nkind (Decl) = N_Package_Declaration then
3228 Collect_States_And_Objects (Decl);
3230 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3232 (Anonymous_Object (Defining_Entity (Decl)),
3239 end Collect_States_And_Objects;
3243 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3246 -- Start of processing for Analyze_Initializes_In_Decl_Part
3249 -- Do not analyze the pragma multiple times
3251 if Is_Analyzed_Pragma (N) then
3255 -- Nothing to do when the initialization list is empty
3257 if Nkind (Inits) = N_Null then
3261 -- Single and multiple initialization clauses appear as an aggregate. If
3262 -- this is not the case, then either the parser or the analysis of the
3263 -- pragma failed to produce an aggregate.
3265 pragma Assert (Nkind (Inits) = N_Aggregate);
3267 -- Initialize the various lists used during analysis
3269 Collect_States_And_Objects (Pack_Decl);
3271 if Present (Expressions (Inits)) then
3272 Init := First (Expressions (Inits));
3273 while Present (Init) loop
3274 Analyze_Initialization_Item (Init);
3279 if Present (Component_Associations (Inits)) then
3280 Init := First (Component_Associations (Inits));
3281 while Present (Init) loop
3282 Analyze_Initialization_Item_With_Inputs (Init);
3287 -- Ensure that a state and a corresponding constituent do not appear
3288 -- together in pragma Initializes.
3290 Check_State_And_Constituent_Use
3291 (States => States_Seen,
3292 Constits => Constits_Seen,
3295 Set_Is_Analyzed_Pragma (N);
3296 end Analyze_Initializes_In_Decl_Part;
3298 ---------------------
3299 -- Analyze_Part_Of --
3300 ---------------------
3302 procedure Analyze_Part_Of
3304 Item_Id : Entity_Id;
3306 Encap_Id : out Entity_Id;
3307 Legal : out Boolean)
3309 procedure Check_Part_Of_Abstract_State;
3310 pragma Inline (Check_Part_Of_Abstract_State);
3311 -- Verify the legality of indicator Part_Of when the encapsulator is an
3314 procedure Check_Part_Of_Concurrent_Type;
3315 pragma Inline (Check_Part_Of_Concurrent_Type);
3316 -- Verify the legality of indicator Part_Of when the encapsulator is a
3317 -- single concurrent type.
3319 ----------------------------------
3320 -- Check_Part_Of_Abstract_State --
3321 ----------------------------------
3323 procedure Check_Part_Of_Abstract_State is
3324 Pack_Id : Entity_Id;
3325 Placement : State_Space_Kind;
3326 Parent_Unit : Entity_Id;
3329 -- Determine where the object, package instantiation or state lives
3330 -- with respect to the enclosing packages or package bodies.
3332 Find_Placement_In_State_Space
3333 (Item_Id => Item_Id,
3334 Placement => Placement,
3335 Pack_Id => Pack_Id);
3337 -- The item appears in a non-package construct with a declarative
3338 -- part (subprogram, block, etc). As such, the item is not allowed
3339 -- to be a part of an encapsulating state because the item is not
3342 if Placement = Not_In_Package then
3344 ("indicator Part_Of cannot appear in this context "
3345 & "(SPARK RM 7.2.6(5))", Indic);
3347 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3349 ("\& is not part of the hidden state of package %",
3353 -- The item appears in the visible state space of some package. In
3354 -- general this scenario does not warrant Part_Of except when the
3355 -- package is a nongeneric private child unit and the encapsulating
3356 -- state is declared in a parent unit or a public descendant of that
3359 elsif Placement = Visible_State_Space then
3360 if Is_Child_Unit (Pack_Id)
3361 and then not Is_Generic_Unit (Pack_Id)
3362 and then Is_Private_Descendant (Pack_Id)
3364 -- A variable or state abstraction which is part of the visible
3365 -- state of a nongeneric private child unit or its public
3366 -- descendants must have its Part_Of indicator specified. The
3367 -- Part_Of indicator must denote a state declared by either the
3368 -- parent unit of the private unit or by a public descendant of
3369 -- that parent unit.
3371 -- Find the nearest private ancestor (which can be the current
3374 Parent_Unit := Pack_Id;
3375 while Present (Parent_Unit) loop
3378 (Parent (Unit_Declaration_Node (Parent_Unit)));
3379 Parent_Unit := Scope (Parent_Unit);
3382 Parent_Unit := Scope (Parent_Unit);
3384 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3386 ("indicator Part_Of must denote abstract state of & or of "
3387 & "its public descendant (SPARK RM 7.2.6(3))",
3388 Indic, Parent_Unit);
3391 elsif Scope (Encap_Id) = Parent_Unit
3393 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3394 and then not Is_Private_Descendant (Scope (Encap_Id)))
3400 ("indicator Part_Of must denote abstract state of & or of "
3401 & "its public descendant (SPARK RM 7.2.6(3))",
3402 Indic, Parent_Unit);
3406 -- Indicator Part_Of is not needed when the related package is
3407 -- not a nongeneric private child unit or a public descendant
3412 ("indicator Part_Of cannot appear in this context "
3413 & "(SPARK RM 7.2.6(5))", Indic);
3415 Error_Msg_Name_1 := Chars (Pack_Id);
3417 ("\& is declared in the visible part of package %",
3422 -- When the item appears in the private state space of a package, the
3423 -- encapsulating state must be declared in the same package.
3425 elsif Placement = Private_State_Space then
3426 if Scope (Encap_Id) /= Pack_Id then
3428 ("indicator Part_Of must denote an abstract state of "
3429 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3431 Error_Msg_Name_1 := Chars (Pack_Id);
3433 ("\& is declared in the private part of package %",
3438 -- Items declared in the body state space of a package do not need
3439 -- Part_Of indicators as the refinement has already been seen.
3443 ("indicator Part_Of cannot appear in this context "
3444 & "(SPARK RM 7.2.6(5))", Indic);
3446 if Scope (Encap_Id) = Pack_Id then
3447 Error_Msg_Name_1 := Chars (Pack_Id);
3449 ("\& is declared in the body of package %", Indic, Item_Id);
3455 -- At this point it is known that the Part_Of indicator is legal
3458 end Check_Part_Of_Abstract_State;
3460 -----------------------------------
3461 -- Check_Part_Of_Concurrent_Type --
3462 -----------------------------------
3464 procedure Check_Part_Of_Concurrent_Type is
3465 function In_Proper_Order
3467 Second : Node_Id) return Boolean;
3468 pragma Inline (In_Proper_Order);
3469 -- Determine whether node First precedes node Second
3471 procedure Placement_Error;
3472 pragma Inline (Placement_Error);
3473 -- Emit an error concerning the illegal placement of the item with
3474 -- respect to the single concurrent type.
3476 ---------------------
3477 -- In_Proper_Order --
3478 ---------------------
3480 function In_Proper_Order
3482 Second : Node_Id) return Boolean
3487 if List_Containing (First) = List_Containing (Second) then
3489 while Present (N) loop
3499 end In_Proper_Order;
3501 ---------------------
3502 -- Placement_Error --
3503 ---------------------
3505 procedure Placement_Error is
3508 ("indicator Part_Of must denote a previously declared single "
3509 & "protected type or single task type", Encap);
3510 end Placement_Error;
3514 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3515 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3516 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3518 Item_Context : Node_Id;
3519 Item_Decl : Node_Id;
3520 Prv_Decls : List_Id;
3521 Vis_Decls : List_Id;
3523 -- Start of processing for Check_Part_Of_Concurrent_Type
3526 -- Only abstract states and variables can act as constituents of an
3527 -- encapsulating single concurrent type.
3529 if Ekind (Item_Id) in E_Abstract_State | E_Variable then
3532 -- The constituent is a constant
3534 elsif Ekind (Item_Id) = E_Constant then
3535 Error_Msg_Name_1 := Chars (Encap_Id);
3537 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3538 & "single protected type %"), Indic, Item_Id);
3541 -- The constituent is a package instantiation
3544 Error_Msg_Name_1 := Chars (Encap_Id);
3546 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3547 & "constituent of single protected type %"), Indic, Item_Id);
3551 -- When the item denotes an abstract state of a nested package, use
3552 -- the declaration of the package to detect proper placement.
3557 -- with Abstract_State => (State with Part_Of => T)
3559 if Ekind (Item_Id) = E_Abstract_State then
3560 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3562 Item_Decl := Declaration_Node (Item_Id);
3565 Item_Context := Parent (Item_Decl);
3567 -- The item and the single concurrent type must appear in the same
3568 -- declarative region, with the item following the declaration of
3569 -- the single concurrent type (SPARK RM 9(3)).
3571 if Item_Context = Encap_Context then
3572 if Nkind (Item_Context) in N_Package_Specification
3573 | N_Protected_Definition
3576 Prv_Decls := Private_Declarations (Item_Context);
3577 Vis_Decls := Visible_Declarations (Item_Context);
3579 -- The placement is OK when the single concurrent type appears
3580 -- within the visible declarations and the item in the private
3586 -- Constit : ... with Part_Of => PO;
3589 if List_Containing (Encap_Decl) = Vis_Decls
3590 and then List_Containing (Item_Decl) = Prv_Decls
3594 -- The placement is illegal when the item appears within the
3595 -- visible declarations and the single concurrent type is in
3596 -- the private declarations.
3599 -- Constit : ... with Part_Of => PO;
3604 elsif List_Containing (Item_Decl) = Vis_Decls
3605 and then List_Containing (Encap_Decl) = Prv_Decls
3610 -- Otherwise both the item and the single concurrent type are
3611 -- in the same list. Ensure that the declaration of the single
3612 -- concurrent type precedes that of the item.
3614 elsif not In_Proper_Order
3615 (First => Encap_Decl,
3616 Second => Item_Decl)
3622 -- Otherwise both the item and the single concurrent type are
3623 -- in the same list. Ensure that the declaration of the single
3624 -- concurrent type precedes that of the item.
3626 elsif not In_Proper_Order
3627 (First => Encap_Decl,
3628 Second => Item_Decl)
3634 -- Otherwise the item and the single concurrent type reside within
3635 -- unrelated regions.
3638 Error_Msg_Name_1 := Chars (Encap_Id);
3640 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3641 & "immediately within the same region as single protected "
3642 & "type %"), Indic, Item_Id);
3646 -- At this point it is known that the Part_Of indicator is legal
3649 end Check_Part_Of_Concurrent_Type;
3651 -- Start of processing for Analyze_Part_Of
3654 -- Assume that the indicator is illegal
3660 N_Expanded_Name | N_Identifier | N_Selected_Component
3663 Resolve_State (Encap);
3665 Encap_Id := Entity (Encap);
3667 -- The encapsulator is an abstract state
3669 if Ekind (Encap_Id) = E_Abstract_State then
3672 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3674 elsif Is_Single_Concurrent_Object (Encap_Id) then
3677 -- Otherwise the encapsulator is not a legal choice
3681 ("indicator Part_Of must denote abstract state, single "
3682 & "protected type or single task type", Encap);
3686 -- This is a syntax error, always report
3690 ("indicator Part_Of must denote abstract state, single protected "
3691 & "type or single task type", Encap);
3695 -- Catch a case where indicator Part_Of denotes the abstract view of a
3696 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3698 if From_Limited_With (Encap_Id)
3699 and then Present (Non_Limited_View (Encap_Id))
3700 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3702 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3703 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3707 -- The encapsulator is an abstract state
3709 if Ekind (Encap_Id) = E_Abstract_State then
3710 Check_Part_Of_Abstract_State;
3712 -- The encapsulator is a single concurrent type
3715 Check_Part_Of_Concurrent_Type;
3717 end Analyze_Part_Of;
3719 ----------------------------------
3720 -- Analyze_Part_Of_In_Decl_Part --
3721 ----------------------------------
3723 procedure Analyze_Part_Of_In_Decl_Part
3725 Freeze_Id : Entity_Id := Empty)
3727 Encap : constant Node_Id :=
3728 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3729 Errors : constant Nat := Serious_Errors_Detected;
3730 Var_Decl : constant Node_Id := Find_Related_Context (N);
3731 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3732 Constits : Elist_Id;
3733 Encap_Id : Entity_Id;
3737 -- Detect any discrepancies between the placement of the variable with
3738 -- respect to general state space and the encapsulating state or single
3745 Encap_Id => Encap_Id,
3748 -- The Part_Of indicator turns the variable into a constituent of the
3749 -- encapsulating state or single concurrent type.
3752 pragma Assert (Present (Encap_Id));
3753 Constits := Part_Of_Constituents (Encap_Id);
3755 if No (Constits) then
3756 Constits := New_Elmt_List;
3757 Set_Part_Of_Constituents (Encap_Id, Constits);
3760 Append_Elmt (Var_Id, Constits);
3761 Set_Encapsulating_State (Var_Id, Encap_Id);
3763 -- A Part_Of constituent partially refines an abstract state. This
3764 -- property does not apply to protected or task units.
3766 if Ekind (Encap_Id) = E_Abstract_State then
3767 Set_Has_Partial_Visible_Refinement (Encap_Id);
3771 -- Emit a clarification message when the encapsulator is undefined,
3772 -- possibly due to contract freezing.
3774 if Errors /= Serious_Errors_Detected
3775 and then Present (Freeze_Id)
3776 and then Has_Undefined_Reference (Encap)
3778 Contract_Freeze_Error (Var_Id, Freeze_Id);
3780 end Analyze_Part_Of_In_Decl_Part;
3782 --------------------
3783 -- Analyze_Pragma --
3784 --------------------
3786 procedure Analyze_Pragma (N : Node_Id) is
3787 Loc : constant Source_Ptr := Sloc (N);
3789 Pname : Name_Id := Pragma_Name (N);
3790 -- Name of the source pragma, or name of the corresponding aspect for
3791 -- pragmas which originate in a source aspect. In the latter case, the
3792 -- name may be different from the pragma name.
3794 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3796 Pragma_Exit : exception;
3797 -- This exception is used to exit pragma processing completely. It
3798 -- is used when an error is detected, and no further processing is
3799 -- required. It is also used if an earlier error has left the tree in
3800 -- a state where the pragma should not be processed.
3803 -- Number of pragma argument associations
3810 -- First five pragma arguments (pragma argument association nodes, or
3811 -- Empty if the corresponding argument does not exist).
3813 type Name_List is array (Natural range <>) of Name_Id;
3814 type Args_List is array (Natural range <>) of Node_Id;
3815 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3817 -----------------------
3818 -- Local Subprograms --
3819 -----------------------
3821 procedure Ada_2005_Pragma;
3822 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3823 -- Ada 95 mode, these are implementation defined pragmas, so should be
3824 -- caught by the No_Implementation_Pragmas restriction.
3826 procedure Ada_2012_Pragma;
3827 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3828 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3829 -- should be caught by the No_Implementation_Pragmas restriction.
3831 procedure Analyze_Depends_Global
3832 (Spec_Id : out Entity_Id;
3833 Subp_Decl : out Node_Id;
3834 Legal : out Boolean);
3835 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3836 -- legality of the placement and related context of the pragma. Spec_Id
3837 -- is the entity of the related subprogram. Subp_Decl is the declaration
3838 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3840 procedure Analyze_If_Present (Id : Pragma_Id);
3841 -- Inspect the remainder of the list containing pragma N and look for
3842 -- a pragma that matches Id. If found, analyze the pragma.
3844 procedure Analyze_Pre_Post_Condition;
3845 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3847 procedure Analyze_Refined_Depends_Global_Post
3848 (Spec_Id : out Entity_Id;
3849 Body_Id : out Entity_Id;
3850 Legal : out Boolean);
3851 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3852 -- Refined_Global and Refined_Post. Verify the legality of the placement
3853 -- and related context of the pragma. Spec_Id is the entity of the
3854 -- related subprogram. Body_Id is the entity of the subprogram body.
3855 -- Flag Legal is set when the pragma is legal.
3857 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3858 -- Perform full analysis of pragma Unmodified and the write aspect of
3859 -- pragma Unused. Flag Is_Unused should be set when verifying the
3860 -- semantics of pragma Unused.
3862 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3863 -- Perform full analysis of pragma Unreferenced and the read aspect of
3864 -- pragma Unused. Flag Is_Unused should be set when verifying the
3865 -- semantics of pragma Unused.
3867 procedure Check_Ada_83_Warning;
3868 -- Issues a warning message for the current pragma if operating in Ada
3869 -- 83 mode (used for language pragmas that are not a standard part of
3870 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3873 procedure Check_Arg_Count (Required : Nat);
3874 -- Check argument count for pragma is equal to given parameter. If not,
3875 -- then issue an error message and raise Pragma_Exit.
3877 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3878 -- Arg which can either be a pragma argument association, in which case
3879 -- the check is applied to the expression of the association or an
3880 -- expression directly.
3882 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3883 -- Check that an argument has the right form for an EXTERNAL_NAME
3884 -- parameter of an extended import/export pragma. The rule is that the
3885 -- name must be an identifier or string literal (in Ada 83 mode) or a
3886 -- static string expression (in Ada 95 mode).
3888 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3889 -- Check the specified argument Arg to make sure that it is an
3890 -- identifier. If not give error and raise Pragma_Exit.
3892 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3893 -- Check the specified argument Arg to make sure that it is an integer
3894 -- literal. If not give error and raise Pragma_Exit.
3896 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3897 -- Check the specified argument Arg to make sure that it has the proper
3898 -- syntactic form for a local name and meets the semantic requirements
3899 -- for a local name. The local name is analyzed as part of the
3900 -- processing for this call. In addition, the local name is required
3901 -- to represent an entity at the library level.
3903 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3904 -- Check the specified argument Arg to make sure that it has the proper
3905 -- syntactic form for a local name and meets the semantic requirements
3906 -- for a local name. The local name is analyzed as part of the
3907 -- processing for this call.
3909 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3910 -- Check the specified argument Arg to make sure that it is a valid
3911 -- locking policy name. If not give error and raise Pragma_Exit.
3913 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3914 -- Check the specified argument Arg to make sure that it is a valid
3915 -- elaboration policy name. If not give error and raise Pragma_Exit.
3917 procedure Check_Arg_Is_One_Of
3920 procedure Check_Arg_Is_One_Of
3922 N1, N2, N3 : Name_Id);
3923 procedure Check_Arg_Is_One_Of
3925 N1, N2, N3, N4 : Name_Id);
3926 procedure Check_Arg_Is_One_Of
3928 N1, N2, N3, N4, N5 : Name_Id);
3929 -- Check the specified argument Arg to make sure that it is an
3930 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3931 -- present). If not then give error and raise Pragma_Exit.
3933 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3934 -- Check the specified argument Arg to make sure that it is a valid
3935 -- queuing policy name. If not give error and raise Pragma_Exit.
3937 procedure Check_Arg_Is_OK_Static_Expression
3939 Typ : Entity_Id := Empty);
3940 -- Check the specified argument Arg to make sure that it is a static
3941 -- expression of the given type (i.e. it will be analyzed and resolved
3942 -- using this type, which can be any valid argument to Resolve, e.g.
3943 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3944 -- Typ is left Empty, then any static expression is allowed. Includes
3945 -- checking that the argument does not raise Constraint_Error.
3947 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3948 -- Check the specified argument Arg to make sure that it is a valid task
3949 -- dispatching policy name. If not give error and raise Pragma_Exit.
3951 procedure Check_Arg_Order (Names : Name_List);
3952 -- Checks for an instance of two arguments with identifiers for the
3953 -- current pragma which are not in the sequence indicated by Names,
3954 -- and if so, generates a fatal message about bad order of arguments.
3956 procedure Check_At_Least_N_Arguments (N : Nat);
3957 -- Check there are at least N arguments present
3959 procedure Check_At_Most_N_Arguments (N : Nat);
3960 -- Check there are no more than N arguments present
3962 procedure Check_Component
3965 In_Variant_Part : Boolean := False);
3966 -- Examine an Unchecked_Union component for correct use of per-object
3967 -- constrained subtypes, and for restrictions on finalizable components.
3968 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3969 -- should be set when Comp comes from a record variant.
3971 procedure Check_Duplicate_Pragma (E : Entity_Id);
3972 -- Check if a rep item of the same name as the current pragma is already
3973 -- chained as a rep pragma to the given entity. If so give a message
3974 -- about the duplicate, and then raise Pragma_Exit so does not return.
3975 -- Note that if E is a type, then this routine avoids flagging a pragma
3976 -- which applies to a parent type from which E is derived.
3978 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3979 -- Nam is an N_String_Literal node containing the external name set by
3980 -- an Import or Export pragma (or extended Import or Export pragma).
3981 -- This procedure checks for possible duplications if this is the export
3982 -- case, and if found, issues an appropriate error message.
3984 procedure Check_Expr_Is_OK_Static_Expression
3986 Typ : Entity_Id := Empty);
3987 -- Check the specified expression Expr to make sure that it is a static
3988 -- expression of the given type (i.e. it will be analyzed and resolved
3989 -- using this type, which can be any valid argument to Resolve, e.g.
3990 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3991 -- Typ is left Empty, then any static expression is allowed. Includes
3992 -- checking that the expression does not raise Constraint_Error.
3994 procedure Check_First_Subtype (Arg : Node_Id);
3995 -- Checks that Arg, whose expression is an entity name, references a
3998 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3999 -- Checks that the given argument has an identifier, and if so, requires
4000 -- it to match the given identifier name. If there is no identifier, or
4001 -- a non-matching identifier, then an error message is given and
4002 -- Pragma_Exit is raised.
4004 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
4005 -- Checks that the given argument has an identifier, and if so, requires
4006 -- it to match one of the given identifier names. If there is no
4007 -- identifier, or a non-matching identifier, then an error message is
4008 -- given and Pragma_Exit is raised.
4010 procedure Check_In_Main_Program;
4011 -- Common checks for pragmas that appear within a main program
4012 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4014 procedure Check_Interrupt_Or_Attach_Handler;
4015 -- Common processing for first argument of pragma Interrupt_Handler or
4016 -- pragma Attach_Handler.
4018 procedure Check_Loop_Pragma_Placement;
4019 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4020 -- appear immediately within a construct restricted to loops, and that
4021 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4023 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
4024 -- Check that pragma appears in a declarative part, or in a package
4025 -- specification, i.e. that it does not occur in a statement sequence
4028 procedure Check_No_Identifier (Arg : Node_Id);
4029 -- Checks that the given argument does not have an identifier. If
4030 -- an identifier is present, then an error message is issued, and
4031 -- Pragma_Exit is raised.
4033 procedure Check_No_Identifiers;
4034 -- Checks that none of the arguments to the pragma has an identifier.
4035 -- If any argument has an identifier, then an error message is issued,
4036 -- and Pragma_Exit is raised.
4038 procedure Check_No_Link_Name;
4039 -- Checks that no link name is specified
4041 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
4042 -- Checks if the given argument has an identifier, and if so, requires
4043 -- it to match the given identifier name. If there is a non-matching
4044 -- identifier, then an error message is given and Pragma_Exit is raised.
4046 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
4047 -- Checks if the given argument has an identifier, and if so, requires
4048 -- it to match the given identifier name. If there is a non-matching
4049 -- identifier, then an error message is given and Pragma_Exit is raised.
4050 -- In this version of the procedure, the identifier name is given as
4051 -- a string with lower case letters.
4053 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4054 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4055 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4056 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4057 -- is an OK static boolean expression. Emit an error if this is not the
4060 procedure Check_Static_Constraint (Constr : Node_Id);
4061 -- Constr is a constraint from an N_Subtype_Indication node from a
4062 -- component constraint in an Unchecked_Union type. This routine checks
4063 -- that the constraint is static as required by the restrictions for
4066 procedure Check_Valid_Configuration_Pragma;
4067 -- Legality checks for placement of a configuration pragma
4069 procedure Check_Valid_Library_Unit_Pragma;
4070 -- Legality checks for library unit pragmas. A special case arises for
4071 -- pragmas in generic instances that come from copies of the original
4072 -- library unit pragmas in the generic templates. In the case of other
4073 -- than library level instantiations these can appear in contexts which
4074 -- would normally be invalid (they only apply to the original template
4075 -- and to library level instantiations), and they are simply ignored,
4076 -- which is implemented by rewriting them as null statements and raising
4077 -- exception to terminate analysis.
4079 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4080 -- Check an Unchecked_Union variant for lack of nested variants and
4081 -- presence of at least one component. UU_Typ is the related Unchecked_
4084 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4085 -- Subsidiary routine to the processing of pragmas Abstract_State,
4086 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4087 -- Refined_Global, Refined_State and Subprogram_Variant. Transform
4088 -- argument Arg into an aggregate if not one already. N_Null is never
4089 -- transformed. Arg may denote an aspect specification or a pragma
4090 -- argument association.
4092 procedure Error_Pragma (Msg : String);
4093 pragma No_Return (Error_Pragma);
4094 -- Outputs error message for current pragma. The message contains a %
4095 -- that will be replaced with the pragma name, and the flag is placed
4096 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4097 -- calls Fix_Error (see spec of that procedure for details).
4099 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4100 pragma No_Return (Error_Pragma_Arg);
4101 -- Outputs error message for current pragma. The message may contain
4102 -- a % that will be replaced with the pragma name. The parameter Arg
4103 -- may either be a pragma argument association, in which case the flag
4104 -- is placed on the expression of this association, or an expression,
4105 -- in which case the flag is placed directly on the expression. The
4106 -- message is placed using Error_Msg_N, so the message may also contain
4107 -- an & insertion character which will reference the given Arg value.
4108 -- After placing the message, Pragma_Exit is raised. Note: this routine
4109 -- calls Fix_Error (see spec of that procedure for details).
4111 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4112 pragma No_Return (Error_Pragma_Arg);
4113 -- Similar to above form of Error_Pragma_Arg except that two messages
4114 -- are provided, the second is a continuation comment starting with \.
4116 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4117 pragma No_Return (Error_Pragma_Arg_Ident);
4118 -- Outputs error message for current pragma. The message may contain a %
4119 -- that will be replaced with the pragma name. The parameter Arg must be
4120 -- a pragma argument association with a non-empty identifier (i.e. its
4121 -- Chars field must be set), and the error message is placed on the
4122 -- identifier. The message is placed using Error_Msg_N so the message
4123 -- may also contain an & insertion character which will reference
4124 -- the identifier. After placing the message, Pragma_Exit is raised.
4125 -- Note: this routine calls Fix_Error (see spec of that procedure for
4128 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4129 pragma No_Return (Error_Pragma_Ref);
4130 -- Outputs error message for current pragma. The message may contain
4131 -- a % that will be replaced with the pragma name. The parameter Ref
4132 -- must be an entity whose name can be referenced by & and sloc by #.
4133 -- After placing the message, Pragma_Exit is raised. Note: this routine
4134 -- calls Fix_Error (see spec of that procedure for details).
4136 function Find_Lib_Unit_Name return Entity_Id;
4137 -- Used for a library unit pragma to find the entity to which the
4138 -- library unit pragma applies, returns the entity found.
4140 procedure Find_Program_Unit_Name (Id : Node_Id);
4141 -- If the pragma is a compilation unit pragma, the id must denote the
4142 -- compilation unit in the same compilation, and the pragma must appear
4143 -- in the list of preceding or trailing pragmas. If it is a program
4144 -- unit pragma that is not a compilation unit pragma, then the
4145 -- identifier must be visible.
4147 function Find_Unique_Parameterless_Procedure
4149 Arg : Node_Id) return Entity_Id;
4150 -- Used for a procedure pragma to find the unique parameterless
4151 -- procedure identified by Name, returns it if it exists, otherwise
4152 -- errors out and uses Arg as the pragma argument for the message.
4154 function Fix_Error (Msg : String) return String;
4155 -- This is called prior to issuing an error message. Msg is the normal
4156 -- error message issued in the pragma case. This routine checks for the
4157 -- case of a pragma coming from an aspect in the source, and returns a
4158 -- message suitable for the aspect case as follows:
4160 -- Each substring "pragma" is replaced by "aspect"
4162 -- If "argument of" is at the start of the error message text, it is
4163 -- replaced by "entity for".
4165 -- If "argument" is at the start of the error message text, it is
4166 -- replaced by "entity".
4168 -- So for example, "argument of pragma X must be discrete type"
4169 -- returns "entity for aspect X must be a discrete type".
4171 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4172 -- be different from the pragma name). If the current pragma results
4173 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4174 -- original pragma name.
4176 procedure Gather_Associations
4178 Args : out Args_List);
4179 -- This procedure is used to gather the arguments for a pragma that
4180 -- permits arbitrary ordering of parameters using the normal rules
4181 -- for named and positional parameters. The Names argument is a list
4182 -- of Name_Id values that corresponds to the allowed pragma argument
4183 -- association identifiers in order. The result returned in Args is
4184 -- a list of corresponding expressions that are the pragma arguments.
4185 -- Note that this is a list of expressions, not of pragma argument
4186 -- associations (Gather_Associations has completely checked all the
4187 -- optional identifiers when it returns). An entry in Args is Empty
4188 -- on return if the corresponding argument is not present.
4190 procedure GNAT_Pragma;
4191 -- Called for all GNAT defined pragmas to check the relevant restriction
4192 -- (No_Implementation_Pragmas).
4194 function Is_Before_First_Decl
4195 (Pragma_Node : Node_Id;
4196 Decls : List_Id) return Boolean;
4197 -- Return True if Pragma_Node is before the first declarative item in
4198 -- Decls where Decls is the list of declarative items.
4200 function Is_Configuration_Pragma return Boolean;
4201 -- Determines if the placement of the current pragma is appropriate
4202 -- for a configuration pragma.
4204 function Is_In_Context_Clause return Boolean;
4205 -- Returns True if pragma appears within the context clause of a unit,
4206 -- and False for any other placement (does not generate any messages).
4208 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4209 -- Analyzes the argument, and determines if it is a static string
4210 -- expression, returns True if so, False if non-static or not String.
4211 -- A special case is that a string literal returns True in Ada 83 mode
4212 -- (which has no such thing as static string expressions). Note that
4213 -- the call analyzes its argument, so this cannot be used for the case
4214 -- where an identifier might not be declared.
4216 procedure Pragma_Misplaced;
4217 pragma No_Return (Pragma_Misplaced);
4218 -- Issue fatal error message for misplaced pragma
4220 procedure Process_Atomic_Independent_Shared_Volatile;
4221 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4222 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4223 -- and treated as being identical in effect to pragma Atomic.
4225 procedure Process_Compile_Time_Warning_Or_Error;
4226 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4228 procedure Process_Convention
4229 (C : out Convention_Id;
4230 Ent : out Entity_Id);
4231 -- Common processing for Convention, Interface, Import and Export.
4232 -- Checks first two arguments of pragma, and sets the appropriate
4233 -- convention value in the specified entity or entities. On return
4234 -- C is the convention, Ent is the referenced entity.
4236 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4237 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4238 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4240 procedure Process_Extended_Import_Export_Object_Pragma
4241 (Arg_Internal : Node_Id;
4242 Arg_External : Node_Id;
4243 Arg_Size : Node_Id);
4244 -- Common processing for the pragmas Import/Export_Object. The three
4245 -- arguments correspond to the three named parameters of the pragmas. An
4246 -- argument is empty if the corresponding parameter is not present in
4249 procedure Process_Extended_Import_Export_Internal_Arg
4250 (Arg_Internal : Node_Id := Empty);
4251 -- Common processing for all extended Import and Export pragmas. The
4252 -- argument is the pragma parameter for the Internal argument. If
4253 -- Arg_Internal is empty or inappropriate, an error message is posted.
4254 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4255 -- set to identify the referenced entity.
4257 procedure Process_Extended_Import_Export_Subprogram_Pragma
4258 (Arg_Internal : Node_Id;
4259 Arg_External : Node_Id;
4260 Arg_Parameter_Types : Node_Id;
4261 Arg_Result_Type : Node_Id := Empty;
4262 Arg_Mechanism : Node_Id;
4263 Arg_Result_Mechanism : Node_Id := Empty);
4264 -- Common processing for all extended Import and Export pragmas applying
4265 -- to subprograms. The caller omits any arguments that do not apply to
4266 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4267 -- only in the Import_Function and Export_Function cases). The argument
4268 -- names correspond to the allowed pragma association identifiers.
4270 procedure Process_Generic_List;
4271 -- Common processing for Share_Generic and Inline_Generic
4273 procedure Process_Import_Or_Interface;
4274 -- Common processing for Import or Interface
4276 procedure Process_Import_Predefined_Type;
4277 -- Processing for completing a type with pragma Import. This is used
4278 -- to declare types that match predefined C types, especially for cases
4279 -- without corresponding Ada predefined type.
4281 type Inline_Status is (Suppressed, Disabled, Enabled);
4282 -- Inline status of a subprogram, indicated as follows:
4283 -- Suppressed: inlining is suppressed for the subprogram
4284 -- Disabled: no inlining is requested for the subprogram
4285 -- Enabled: inlining is requested/required for the subprogram
4287 procedure Process_Inline (Status : Inline_Status);
4288 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4289 -- indicates the inline status specified by the pragma.
4291 procedure Process_Interface_Name
4292 (Subprogram_Def : Entity_Id;
4296 -- Given the last two arguments of pragma Import, pragma Export, or
4297 -- pragma Interface_Name, performs validity checks and sets the
4298 -- Interface_Name field of the given subprogram entity to the
4299 -- appropriate external or link name, depending on the arguments given.
4300 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4301 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4302 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4303 -- nor Link_Arg is present, the interface name is set to the default
4304 -- from the subprogram name. In addition, the pragma itself is passed
4305 -- to analyze any expressions in the case the pragma came from an aspect
4308 procedure Process_Interrupt_Or_Attach_Handler;
4309 -- Common processing for Interrupt and Attach_Handler pragmas
4311 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4312 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4313 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4314 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4315 -- is not set in the Restrictions case.
4317 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4318 -- Common processing for Suppress and Unsuppress. The boolean parameter
4319 -- Suppress_Case is True for the Suppress case, and False for the
4322 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4323 -- Subsidiary to the analysis of pragmas Independent[_Components].
4324 -- Record such a pragma N applied to entity E for future checks.
4326 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4327 -- This procedure sets the Is_Exported flag for the given entity,
4328 -- checking that the entity was not previously imported. Arg is
4329 -- the argument that specified the entity. A check is also made
4330 -- for exporting inappropriate entities.
4332 procedure Set_Extended_Import_Export_External_Name
4333 (Internal_Ent : Entity_Id;
4334 Arg_External : Node_Id);
4335 -- Common processing for all extended import export pragmas. The first
4336 -- argument, Internal_Ent, is the internal entity, which has already
4337 -- been checked for validity by the caller. Arg_External is from the
4338 -- Import or Export pragma, and may be null if no External parameter
4339 -- was present. If Arg_External is present and is a non-null string
4340 -- (a null string is treated as the default), then the Interface_Name
4341 -- field of Internal_Ent is set appropriately.
4343 procedure Set_Imported (E : Entity_Id);
4344 -- This procedure sets the Is_Imported flag for the given entity,
4345 -- checking that it is not previously exported or imported.
4347 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4348 -- Mech is a parameter passing mechanism (see Import_Function syntax
4349 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4350 -- has the right form, and if not issues an error message. If the
4351 -- argument has the right form then the Mechanism field of Ent is
4352 -- set appropriately.
4354 procedure Set_Rational_Profile;
4355 -- Activate the set of configuration pragmas and permissions that make
4356 -- up the Rational profile.
4358 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4359 -- Activate the set of configuration pragmas and restrictions that make
4360 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4361 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4362 -- pragma node, which is used for error messages on any constructs
4363 -- violating the profile.
4365 ---------------------
4366 -- Ada_2005_Pragma --
4367 ---------------------
4369 procedure Ada_2005_Pragma is
4371 if Ada_Version <= Ada_95 then
4372 Check_Restriction (No_Implementation_Pragmas, N);
4374 end Ada_2005_Pragma;
4376 ---------------------
4377 -- Ada_2012_Pragma --
4378 ---------------------
4380 procedure Ada_2012_Pragma is
4382 if Ada_Version <= Ada_2005 then
4383 Check_Restriction (No_Implementation_Pragmas, N);
4385 end Ada_2012_Pragma;
4387 ----------------------------
4388 -- Analyze_Depends_Global --
4389 ----------------------------
4391 procedure Analyze_Depends_Global
4392 (Spec_Id : out Entity_Id;
4393 Subp_Decl : out Node_Id;
4394 Legal : out Boolean)
4397 -- Assume that the pragma is illegal
4404 Check_Arg_Count (1);
4406 -- Ensure the proper placement of the pragma. Depends/Global must be
4407 -- associated with a subprogram declaration or a body that acts as a
4410 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4414 if Nkind (Subp_Decl) = N_Entry_Declaration then
4417 -- Generic subprogram
4419 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4422 -- Object declaration of a single concurrent type
4424 elsif Nkind (Subp_Decl) = N_Object_Declaration
4425 and then Is_Single_Concurrent_Object
4426 (Unique_Defining_Entity (Subp_Decl))
4432 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4435 -- Subprogram body acts as spec
4437 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4438 and then No (Corresponding_Spec (Subp_Decl))
4442 -- Subprogram body stub acts as spec
4444 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4445 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4449 -- Subprogram declaration
4451 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4453 -- Pragmas Global and Depends are forbidden on null procedures
4454 -- (SPARK RM 6.1.2(2)).
4456 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4457 and then Null_Present (Specification (Subp_Decl))
4459 Error_Msg_N (Fix_Error
4460 ("pragma % cannot apply to null procedure"), N);
4466 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4474 -- If we get here, then the pragma is legal
4477 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4479 -- When the related context is an entry, the entry must belong to a
4480 -- protected unit (SPARK RM 6.1.4(6)).
4482 if Is_Entry_Declaration (Spec_Id)
4483 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4488 -- When the related context is an anonymous object created for a
4489 -- simple concurrent type, the type must be a task
4490 -- (SPARK RM 6.1.4(6)).
4492 elsif Is_Single_Concurrent_Object (Spec_Id)
4493 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4499 -- A pragma that applies to a Ghost entity becomes Ghost for the
4500 -- purposes of legality checks and removal of ignored Ghost code.
4502 Mark_Ghost_Pragma (N, Spec_Id);
4503 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4504 end Analyze_Depends_Global;
4506 ------------------------
4507 -- Analyze_If_Present --
4508 ------------------------
4510 procedure Analyze_If_Present (Id : Pragma_Id) is
4514 pragma Assert (Is_List_Member (N));
4516 -- Inspect the declarations or statements following pragma N looking
4517 -- for another pragma whose Id matches the caller's request. If it is
4518 -- available, analyze it.
4521 while Present (Stmt) loop
4522 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4523 Analyze_Pragma (Stmt);
4526 -- The first source declaration or statement immediately following
4527 -- N ends the region where a pragma may appear.
4529 elsif Comes_From_Source (Stmt) then
4535 end Analyze_If_Present;
4537 --------------------------------
4538 -- Analyze_Pre_Post_Condition --
4539 --------------------------------
4541 procedure Analyze_Pre_Post_Condition is
4542 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4543 Subp_Decl : Node_Id;
4544 Subp_Id : Entity_Id;
4546 Duplicates_OK : Boolean := False;
4547 -- Flag set when a pre/postcondition allows multiple pragmas of the
4550 In_Body_OK : Boolean := False;
4551 -- Flag set when a pre/postcondition is allowed to appear on a body
4552 -- even though the subprogram may have a spec.
4554 Is_Pre_Post : Boolean := False;
4555 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4558 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4559 -- Implement rules in AI12-0131: an overriding operation can have
4560 -- a class-wide precondition only if one of its ancestors has an
4561 -- explicit class-wide precondition.
4563 -----------------------------
4564 -- Inherits_Class_Wide_Pre --
4565 -----------------------------
4567 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4568 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4571 Prev : Entity_Id := Overridden_Operation (E);
4574 -- Check ancestors on the overriding operation to examine the
4575 -- preconditions that may apply to them.
4577 while Present (Prev) loop
4578 Cont := Contract (Prev);
4579 if Present (Cont) then
4580 Prag := Pre_Post_Conditions (Cont);
4581 while Present (Prag) loop
4582 if Pragma_Name (Prag) = Name_Precondition
4583 and then Class_Present (Prag)
4588 Prag := Next_Pragma (Prag);
4592 -- For a type derived from a generic formal type, the operation
4593 -- inheriting the condition is a renaming, not an overriding of
4594 -- the operation of the formal. Ditto for an inherited
4595 -- operation which has no explicit contracts.
4597 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4598 or else not Comes_From_Source (Prev)
4600 Prev := Alias (Prev);
4602 Prev := Overridden_Operation (Prev);
4606 -- If the controlling type of the subprogram has progenitors, an
4607 -- interface operation implemented by the current operation may
4608 -- have a class-wide precondition.
4610 if Has_Interfaces (Typ) then
4615 Prim_Elmt : Elmt_Id;
4616 Prim_List : Elist_Id;
4619 Collect_Interfaces (Typ, Ints);
4620 Elmt := First_Elmt (Ints);
4622 -- Iterate over the primitive operations of each interface
4624 while Present (Elmt) loop
4625 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4626 Prim_Elmt := First_Elmt (Prim_List);
4627 while Present (Prim_Elmt) loop
4628 Prim := Node (Prim_Elmt);
4629 if Chars (Prim) = Chars (E)
4630 and then Present (Contract (Prim))
4631 and then Class_Present
4632 (Pre_Post_Conditions (Contract (Prim)))
4637 Next_Elmt (Prim_Elmt);
4646 end Inherits_Class_Wide_Pre;
4648 -- Start of processing for Analyze_Pre_Post_Condition
4651 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4652 -- offer uniformity among the various kinds of pre/postconditions by
4653 -- rewriting the pragma identifier. This allows the retrieval of the
4654 -- original pragma name by routine Original_Aspect_Pragma_Name.
4656 if Comes_From_Source (N) then
4657 if Pname in Name_Pre | Name_Pre_Class then
4658 Is_Pre_Post := True;
4659 Set_Class_Present (N, Pname = Name_Pre_Class);
4660 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4662 elsif Pname in Name_Post | Name_Post_Class then
4663 Is_Pre_Post := True;
4664 Set_Class_Present (N, Pname = Name_Post_Class);
4665 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4669 -- Determine the semantics with respect to duplicates and placement
4670 -- in a body. Pragmas Precondition and Postcondition were introduced
4671 -- before aspects and are not subject to the same aspect-like rules.
4673 if Pname in Name_Precondition | Name_Postcondition then
4674 Duplicates_OK := True;
4680 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4681 -- argument without an identifier.
4684 Check_Arg_Count (1);
4685 Check_No_Identifiers;
4687 -- Pragmas Precondition and Postcondition have complex argument
4691 Check_At_Least_N_Arguments (1);
4692 Check_At_Most_N_Arguments (2);
4693 Check_Optional_Identifier (Arg1, Name_Check);
4695 if Present (Arg2) then
4696 Check_Optional_Identifier (Arg2, Name_Message);
4697 Preanalyze_Spec_Expression
4698 (Get_Pragma_Arg (Arg2), Standard_String);
4702 -- For a pragma PPC in the extended main source unit, record enabled
4704 -- ??? nothing checks that the pragma is in the main source unit
4706 if Is_Checked (N) and then not Split_PPC (N) then
4707 Set_SCO_Pragma_Enabled (Loc);
4710 -- Ensure the proper placement of the pragma
4713 Find_Related_Declaration_Or_Body
4714 (N, Do_Checks => not Duplicates_OK);
4716 -- When a pre/postcondition pragma applies to an abstract subprogram,
4717 -- its original form must be an aspect with 'Class.
4719 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4720 if not From_Aspect_Specification (N) then
4722 ("pragma % cannot be applied to abstract subprogram");
4724 elsif not Class_Present (N) then
4726 ("aspect % requires ''Class for abstract subprogram");
4729 -- Entry declaration
4731 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4734 -- Generic subprogram declaration
4736 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4741 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4742 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4746 -- Subprogram body stub
4748 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4749 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4753 -- Subprogram declaration
4755 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4757 -- AI05-0230: When a pre/postcondition pragma applies to a null
4758 -- procedure, its original form must be an aspect with 'Class.
4760 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4761 and then Null_Present (Specification (Subp_Decl))
4762 and then From_Aspect_Specification (N)
4763 and then not Class_Present (N)
4765 Error_Pragma ("aspect % requires ''Class for null procedure");
4768 -- Implement the legality checks mandated by AI12-0131:
4769 -- Pre'Class shall not be specified for an overriding primitive
4770 -- subprogram of a tagged type T unless the Pre'Class aspect is
4771 -- specified for the corresponding primitive subprogram of some
4775 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4778 if Class_Present (N)
4779 and then Pragma_Name (N) = Name_Precondition
4780 and then Present (Overridden_Operation (E))
4781 and then not Inherits_Class_Wide_Pre (E)
4784 ("illegal class-wide precondition on overriding operation",
4785 Corresponding_Aspect (N));
4789 -- A renaming declaration may inherit a generated pragma, its
4790 -- placement comes from expansion, not from source.
4792 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4793 and then not Comes_From_Source (N)
4797 -- For Ada 2020, pre/postconditions can appear on formal subprograms
4799 elsif Nkind (Subp_Decl) = N_Formal_Concrete_Subprogram_Declaration
4800 and then Ada_Version >= Ada_2020
4804 -- An access-to-subprogram type can have pre/postconditions, but
4805 -- these are transferred to the generated subprogram wrapper and
4808 -- Otherwise the placement of the pragma is illegal
4815 Subp_Id := Defining_Entity (Subp_Decl);
4817 -- A pragma that applies to a Ghost entity becomes Ghost for the
4818 -- purposes of legality checks and removal of ignored Ghost code.
4820 Mark_Ghost_Pragma (N, Subp_Id);
4822 -- Chain the pragma on the contract for further processing by
4823 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4825 Add_Contract_Item (N, Subp_Id);
4827 -- Fully analyze the pragma when it appears inside an entry or
4828 -- subprogram body because it cannot benefit from forward references.
4830 if Nkind (Subp_Decl) in N_Entry_Body
4832 | N_Subprogram_Body_Stub
4834 -- The legality checks of pragmas Precondition and Postcondition
4835 -- are affected by the SPARK mode in effect and the volatility of
4836 -- the context. Analyze all pragmas in a specific order.
4838 Analyze_If_Present (Pragma_SPARK_Mode);
4839 Analyze_If_Present (Pragma_Volatile_Function);
4840 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4842 end Analyze_Pre_Post_Condition;
4844 -----------------------------------------
4845 -- Analyze_Refined_Depends_Global_Post --
4846 -----------------------------------------
4848 procedure Analyze_Refined_Depends_Global_Post
4849 (Spec_Id : out Entity_Id;
4850 Body_Id : out Entity_Id;
4851 Legal : out Boolean)
4853 Body_Decl : Node_Id;
4854 Spec_Decl : Node_Id;
4857 -- Assume that the pragma is illegal
4864 Check_Arg_Count (1);
4865 Check_No_Identifiers;
4867 -- Verify the placement of the pragma and check for duplicates. The
4868 -- pragma must apply to a subprogram body [stub].
4870 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4872 if Nkind (Body_Decl) not in
4873 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
4874 N_Task_Body | N_Task_Body_Stub
4880 Body_Id := Defining_Entity (Body_Decl);
4881 Spec_Id := Unique_Defining_Entity (Body_Decl);
4883 -- The pragma must apply to the second declaration of a subprogram.
4884 -- In other words, the body [stub] cannot acts as a spec.
4886 if No (Spec_Id) then
4887 Error_Pragma ("pragma % cannot apply to a stand alone body");
4890 -- Catch the case where the subprogram body is a subunit and acts as
4891 -- the third declaration of the subprogram.
4893 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4894 Error_Pragma ("pragma % cannot apply to a subunit");
4898 -- A refined pragma can only apply to the body [stub] of a subprogram
4899 -- declared in the visible part of a package. Retrieve the context of
4900 -- the subprogram declaration.
4902 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4904 -- When dealing with protected entries or protected subprograms, use
4905 -- the enclosing protected type as the proper context.
4907 if Ekind (Spec_Id) in E_Entry
4911 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4913 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4916 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4918 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4919 & "subprogram declared in a package specification"));
4923 -- If we get here, then the pragma is legal
4927 -- A pragma that applies to a Ghost entity becomes Ghost for the
4928 -- purposes of legality checks and removal of ignored Ghost code.
4930 Mark_Ghost_Pragma (N, Spec_Id);
4932 if Pname in Name_Refined_Depends | Name_Refined_Global then
4933 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4935 end Analyze_Refined_Depends_Global_Post;
4937 ----------------------------------
4938 -- Analyze_Unmodified_Or_Unused --
4939 ----------------------------------
4941 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4946 Ghost_Error_Posted : Boolean := False;
4947 -- Flag set when an error concerning the illegal mix of Ghost and
4948 -- non-Ghost variables is emitted.
4950 Ghost_Id : Entity_Id := Empty;
4951 -- The entity of the first Ghost variable encountered while
4952 -- processing the arguments of the pragma.
4956 Check_At_Least_N_Arguments (1);
4958 -- Loop through arguments
4961 while Present (Arg) loop
4962 Check_No_Identifier (Arg);
4964 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4965 -- in fact generate reference, so that the entity will have a
4966 -- reference, which will inhibit any warnings about it not
4967 -- being referenced, and also properly show up in the ali file
4968 -- as a reference. But this reference is recorded before the
4969 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4970 -- generated for this reference.
4972 Check_Arg_Is_Local_Name (Arg);
4973 Arg_Expr := Get_Pragma_Arg (Arg);
4975 if Is_Entity_Name (Arg_Expr) then
4976 Arg_Id := Entity (Arg_Expr);
4978 -- Skip processing the argument if already flagged
4980 if Is_Assignable (Arg_Id)
4981 and then not Has_Pragma_Unmodified (Arg_Id)
4982 and then not Has_Pragma_Unused (Arg_Id)
4984 Set_Has_Pragma_Unmodified (Arg_Id);
4987 Set_Has_Pragma_Unused (Arg_Id);
4990 -- A pragma that applies to a Ghost entity becomes Ghost for
4991 -- the purposes of legality checks and removal of ignored
4994 Mark_Ghost_Pragma (N, Arg_Id);
4996 -- Capture the entity of the first Ghost variable being
4997 -- processed for error detection purposes.
4999 if Is_Ghost_Entity (Arg_Id) then
5000 if No (Ghost_Id) then
5004 -- Otherwise the variable is non-Ghost. It is illegal to mix
5005 -- references to Ghost and non-Ghost entities
5008 elsif Present (Ghost_Id)
5009 and then not Ghost_Error_Posted
5011 Ghost_Error_Posted := True;
5013 Error_Msg_Name_1 := Pname;
5015 ("pragma % cannot mention ghost and non-ghost "
5018 Error_Msg_Sloc := Sloc (Ghost_Id);
5019 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5021 Error_Msg_Sloc := Sloc (Arg_Id);
5022 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5025 -- Warn if already flagged as Unused or Unmodified
5027 elsif Has_Pragma_Unmodified (Arg_Id) then
5028 if Has_Pragma_Unused (Arg_Id) then
5030 ("??pragma Unused already given for &!", Arg_Expr,
5034 ("??pragma Unmodified already given for &!", Arg_Expr,
5038 -- Otherwise the pragma referenced an illegal entity
5042 ("pragma% can only be applied to a variable", Arg_Expr);
5048 end Analyze_Unmodified_Or_Unused;
5050 ------------------------------------
5051 -- Analyze_Unreferenced_Or_Unused --
5052 ------------------------------------
5054 procedure Analyze_Unreferenced_Or_Unused
5055 (Is_Unused : Boolean := False)
5062 Ghost_Error_Posted : Boolean := False;
5063 -- Flag set when an error concerning the illegal mix of Ghost and
5064 -- non-Ghost names is emitted.
5066 Ghost_Id : Entity_Id := Empty;
5067 -- The entity of the first Ghost name encountered while processing
5068 -- the arguments of the pragma.
5072 Check_At_Least_N_Arguments (1);
5074 -- Check case of appearing within context clause
5076 if not Is_Unused and then Is_In_Context_Clause then
5078 -- The arguments must all be units mentioned in a with clause in
5079 -- the same context clause. Note that Par.Prag already checked
5080 -- that the arguments are either identifiers or selected
5084 while Present (Arg) loop
5085 Citem := First (List_Containing (N));
5086 while Citem /= N loop
5087 Arg_Expr := Get_Pragma_Arg (Arg);
5089 if Nkind (Citem) = N_With_Clause
5090 and then Same_Name (Name (Citem), Arg_Expr)
5092 Set_Has_Pragma_Unreferenced
5095 (Library_Unit (Citem))));
5096 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5105 ("argument of pragma% is not withed unit", Arg);
5111 -- Case of not in list of context items
5115 while Present (Arg) loop
5116 Check_No_Identifier (Arg);
5118 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5119 -- in fact generate reference, so that the entity will have a
5120 -- reference, which will inhibit any warnings about it not
5121 -- being referenced, and also properly show up in the ali file
5122 -- as a reference. But this reference is recorded before the
5123 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5124 -- generated for this reference.
5126 Check_Arg_Is_Local_Name (Arg);
5127 Arg_Expr := Get_Pragma_Arg (Arg);
5129 if Is_Entity_Name (Arg_Expr) then
5130 Arg_Id := Entity (Arg_Expr);
5132 -- Warn if already flagged as Unused or Unreferenced and
5133 -- skip processing the argument.
5135 if Has_Pragma_Unreferenced (Arg_Id) then
5136 if Has_Pragma_Unused (Arg_Id) then
5138 ("??pragma Unused already given for &!", Arg_Expr,
5142 ("??pragma Unreferenced already given for &!",
5146 -- Apply Unreferenced to the entity
5149 -- If the entity is overloaded, the pragma applies to the
5150 -- most recent overloading, as documented. In this case,
5151 -- name resolution does not generate a reference, so it
5152 -- must be done here explicitly.
5154 if Is_Overloaded (Arg_Expr) then
5155 Generate_Reference (Arg_Id, N);
5158 Set_Has_Pragma_Unreferenced (Arg_Id);
5161 Set_Has_Pragma_Unused (Arg_Id);
5164 -- A pragma that applies to a Ghost entity becomes Ghost
5165 -- for the purposes of legality checks and removal of
5166 -- ignored Ghost code.
5168 Mark_Ghost_Pragma (N, Arg_Id);
5170 -- Capture the entity of the first Ghost name being
5171 -- processed for error detection purposes.
5173 if Is_Ghost_Entity (Arg_Id) then
5174 if No (Ghost_Id) then
5178 -- Otherwise the name is non-Ghost. It is illegal to mix
5179 -- references to Ghost and non-Ghost entities
5182 elsif Present (Ghost_Id)
5183 and then not Ghost_Error_Posted
5185 Ghost_Error_Posted := True;
5187 Error_Msg_Name_1 := Pname;
5189 ("pragma % cannot mention ghost and non-ghost "
5192 Error_Msg_Sloc := Sloc (Ghost_Id);
5194 ("\& # declared as ghost", N, Ghost_Id);
5196 Error_Msg_Sloc := Sloc (Arg_Id);
5198 ("\& # declared as non-ghost", N, Arg_Id);
5206 end Analyze_Unreferenced_Or_Unused;
5208 --------------------------
5209 -- Check_Ada_83_Warning --
5210 --------------------------
5212 procedure Check_Ada_83_Warning is
5214 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5215 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5217 end Check_Ada_83_Warning;
5219 ---------------------
5220 -- Check_Arg_Count --
5221 ---------------------
5223 procedure Check_Arg_Count (Required : Nat) is
5225 if Arg_Count /= Required then
5226 Error_Pragma ("wrong number of arguments for pragma%");
5228 end Check_Arg_Count;
5230 --------------------------------
5231 -- Check_Arg_Is_External_Name --
5232 --------------------------------
5234 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5235 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5238 if Nkind (Argx) = N_Identifier then
5242 Analyze_And_Resolve (Argx, Standard_String);
5244 if Is_OK_Static_Expression (Argx) then
5247 elsif Etype (Argx) = Any_Type then
5250 -- An interesting special case, if we have a string literal and
5251 -- we are in Ada 83 mode, then we allow it even though it will
5252 -- not be flagged as static. This allows expected Ada 83 mode
5253 -- use of external names which are string literals, even though
5254 -- technically these are not static in Ada 83.
5256 elsif Ada_Version = Ada_83
5257 and then Nkind (Argx) = N_String_Literal
5261 -- Here we have a real error (non-static expression)
5264 Error_Msg_Name_1 := Pname;
5265 Flag_Non_Static_Expr
5266 (Fix_Error ("argument for pragma% must be a identifier or "
5267 & "static string expression!"), Argx);
5272 end Check_Arg_Is_External_Name;
5274 -----------------------------
5275 -- Check_Arg_Is_Identifier --
5276 -----------------------------
5278 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5279 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5281 if Nkind (Argx) /= N_Identifier then
5282 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5284 end Check_Arg_Is_Identifier;
5286 ----------------------------------
5287 -- Check_Arg_Is_Integer_Literal --
5288 ----------------------------------
5290 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5291 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5293 if Nkind (Argx) /= N_Integer_Literal then
5295 ("argument for pragma% must be integer literal", Argx);
5297 end Check_Arg_Is_Integer_Literal;
5299 -------------------------------------------
5300 -- Check_Arg_Is_Library_Level_Local_Name --
5301 -------------------------------------------
5305 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5306 -- | library_unit_NAME
5308 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5310 Check_Arg_Is_Local_Name (Arg);
5312 -- If it came from an aspect, we want to give the error just as if it
5313 -- came from source.
5315 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5316 and then (Comes_From_Source (N)
5317 or else Present (Corresponding_Aspect (Parent (Arg))))
5320 ("argument for pragma% must be library level entity", Arg);
5322 end Check_Arg_Is_Library_Level_Local_Name;
5324 -----------------------------
5325 -- Check_Arg_Is_Local_Name --
5326 -----------------------------
5330 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5331 -- | library_unit_NAME
5333 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5334 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5337 -- If this pragma came from an aspect specification, we don't want to
5338 -- check for this error, because that would cause spurious errors, in
5339 -- case a type is frozen in a scope more nested than the type. The
5340 -- aspect itself of course can't be anywhere but on the declaration
5343 if Nkind (Arg) = N_Pragma_Argument_Association then
5344 if From_Aspect_Specification (Parent (Arg)) then
5348 -- Arg is the Expression of an N_Pragma_Argument_Association
5351 if From_Aspect_Specification (Parent (Parent (Arg))) then
5358 if Nkind (Argx) not in N_Direct_Name
5359 and then (Nkind (Argx) /= N_Attribute_Reference
5360 or else Present (Expressions (Argx))
5361 or else Nkind (Prefix (Argx)) /= N_Identifier)
5362 and then (not Is_Entity_Name (Argx)
5363 or else not Is_Compilation_Unit (Entity (Argx)))
5365 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5368 -- No further check required if not an entity name
5370 if not Is_Entity_Name (Argx) then
5376 Ent : constant Entity_Id := Entity (Argx);
5377 Scop : constant Entity_Id := Scope (Ent);
5380 -- Case of a pragma applied to a compilation unit: pragma must
5381 -- occur immediately after the program unit in the compilation.
5383 if Is_Compilation_Unit (Ent) then
5385 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5388 -- Case of pragma placed immediately after spec
5390 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5393 -- Case of pragma placed immediately after body
5395 elsif Nkind (Decl) = N_Subprogram_Declaration
5396 and then Present (Corresponding_Body (Decl))
5400 (Parent (Unit_Declaration_Node
5401 (Corresponding_Body (Decl))));
5403 -- All other cases are illegal
5410 -- Special restricted placement rule from 10.2.1(11.8/2)
5412 elsif Is_Generic_Formal (Ent)
5413 and then Prag_Id = Pragma_Preelaborable_Initialization
5415 OK := List_Containing (N) =
5416 Generic_Formal_Declarations
5417 (Unit_Declaration_Node (Scop));
5419 -- If this is an aspect applied to a subprogram body, the
5420 -- pragma is inserted in its declarative part.
5422 elsif From_Aspect_Specification (N)
5423 and then Ent = Current_Scope
5425 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5429 -- If the aspect is a predicate (possibly others ???) and the
5430 -- context is a record type, this is a discriminant expression
5431 -- within a type declaration, that freezes the predicated
5434 elsif From_Aspect_Specification (N)
5435 and then Prag_Id = Pragma_Predicate
5436 and then Ekind (Current_Scope) = E_Record_Type
5437 and then Scop = Scope (Current_Scope)
5441 -- Default case, just check that the pragma occurs in the scope
5442 -- of the entity denoted by the name.
5445 OK := Current_Scope = Scop;
5450 ("pragma% argument must be in same declarative part", Arg);
5454 end Check_Arg_Is_Local_Name;
5456 ---------------------------------
5457 -- Check_Arg_Is_Locking_Policy --
5458 ---------------------------------
5460 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5461 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5464 Check_Arg_Is_Identifier (Argx);
5466 if not Is_Locking_Policy_Name (Chars (Argx)) then
5467 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5469 end Check_Arg_Is_Locking_Policy;
5471 -----------------------------------------------
5472 -- Check_Arg_Is_Partition_Elaboration_Policy --
5473 -----------------------------------------------
5475 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5476 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5479 Check_Arg_Is_Identifier (Argx);
5481 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5483 ("& is not a valid partition elaboration policy name", Argx);
5485 end Check_Arg_Is_Partition_Elaboration_Policy;
5487 -------------------------
5488 -- Check_Arg_Is_One_Of --
5489 -------------------------
5491 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5492 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5495 Check_Arg_Is_Identifier (Argx);
5497 if Chars (Argx) not in N1 | N2 then
5498 Error_Msg_Name_2 := N1;
5499 Error_Msg_Name_3 := N2;
5500 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5502 end Check_Arg_Is_One_Of;
5504 procedure Check_Arg_Is_One_Of
5506 N1, N2, N3 : Name_Id)
5508 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5511 Check_Arg_Is_Identifier (Argx);
5513 if Chars (Argx) not in N1 | N2 | N3 then
5514 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5516 end Check_Arg_Is_One_Of;
5518 procedure Check_Arg_Is_One_Of
5520 N1, N2, N3, N4 : Name_Id)
5522 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5525 Check_Arg_Is_Identifier (Argx);
5527 if Chars (Argx) not in N1 | N2 | N3 | N4 then
5528 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5530 end Check_Arg_Is_One_Of;
5532 procedure Check_Arg_Is_One_Of
5534 N1, N2, N3, N4, N5 : Name_Id)
5536 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5539 Check_Arg_Is_Identifier (Argx);
5541 if Chars (Argx) not in N1 | N2 | N3 | N4 | N5 then
5542 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5544 end Check_Arg_Is_One_Of;
5546 ---------------------------------
5547 -- Check_Arg_Is_Queuing_Policy --
5548 ---------------------------------
5550 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5551 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5554 Check_Arg_Is_Identifier (Argx);
5556 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5557 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5559 end Check_Arg_Is_Queuing_Policy;
5561 ---------------------------------------
5562 -- Check_Arg_Is_OK_Static_Expression --
5563 ---------------------------------------
5565 procedure Check_Arg_Is_OK_Static_Expression
5567 Typ : Entity_Id := Empty)
5570 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5571 end Check_Arg_Is_OK_Static_Expression;
5573 ------------------------------------------
5574 -- Check_Arg_Is_Task_Dispatching_Policy --
5575 ------------------------------------------
5577 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5578 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5581 Check_Arg_Is_Identifier (Argx);
5583 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5585 ("& is not an allowed task dispatching policy name", Argx);
5587 end Check_Arg_Is_Task_Dispatching_Policy;
5589 ---------------------
5590 -- Check_Arg_Order --
5591 ---------------------
5593 procedure Check_Arg_Order (Names : Name_List) is
5596 Highest_So_Far : Natural := 0;
5597 -- Highest index in Names seen do far
5601 for J in 1 .. Arg_Count loop
5602 if Chars (Arg) /= No_Name then
5603 for K in Names'Range loop
5604 if Chars (Arg) = Names (K) then
5605 if K < Highest_So_Far then
5606 Error_Msg_Name_1 := Pname;
5608 ("parameters out of order for pragma%", Arg);
5609 Error_Msg_Name_1 := Names (K);
5610 Error_Msg_Name_2 := Names (Highest_So_Far);
5611 Error_Msg_N ("\% must appear before %", Arg);
5615 Highest_So_Far := K;
5623 end Check_Arg_Order;
5625 --------------------------------
5626 -- Check_At_Least_N_Arguments --
5627 --------------------------------
5629 procedure Check_At_Least_N_Arguments (N : Nat) is
5631 if Arg_Count < N then
5632 Error_Pragma ("too few arguments for pragma%");
5634 end Check_At_Least_N_Arguments;
5636 -------------------------------
5637 -- Check_At_Most_N_Arguments --
5638 -------------------------------
5640 procedure Check_At_Most_N_Arguments (N : Nat) is
5643 if Arg_Count > N then
5645 for J in 1 .. N loop
5647 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5650 end Check_At_Most_N_Arguments;
5652 ---------------------
5653 -- Check_Component --
5654 ---------------------
5656 procedure Check_Component
5659 In_Variant_Part : Boolean := False)
5661 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5662 Sindic : constant Node_Id :=
5663 Subtype_Indication (Component_Definition (Comp));
5664 Typ : constant Entity_Id := Etype (Comp_Id);
5667 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5668 -- object constraint, then the component type shall be an Unchecked_
5671 if Nkind (Sindic) = N_Subtype_Indication
5672 and then Has_Per_Object_Constraint (Comp_Id)
5673 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5676 ("component subtype subject to per-object constraint "
5677 & "must be an Unchecked_Union", Comp);
5679 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5680 -- the body of a generic unit, or within the body of any of its
5681 -- descendant library units, no part of the type of a component
5682 -- declared in a variant_part of the unchecked union type shall be of
5683 -- a formal private type or formal private extension declared within
5684 -- the formal part of the generic unit.
5686 elsif Ada_Version >= Ada_2012
5687 and then In_Generic_Body (UU_Typ)
5688 and then In_Variant_Part
5689 and then Is_Private_Type (Typ)
5690 and then Is_Generic_Type (Typ)
5693 ("component of unchecked union cannot be of generic type", Comp);
5695 elsif Needs_Finalization (Typ) then
5697 ("component of unchecked union cannot be controlled", Comp);
5699 elsif Has_Task (Typ) then
5701 ("component of unchecked union cannot have tasks", Comp);
5703 end Check_Component;
5705 ----------------------------
5706 -- Check_Duplicate_Pragma --
5707 ----------------------------
5709 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5710 Id : Entity_Id := E;
5714 -- Nothing to do if this pragma comes from an aspect specification,
5715 -- since we could not be duplicating a pragma, and we dealt with the
5716 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5718 if From_Aspect_Specification (N) then
5722 -- Otherwise current pragma may duplicate previous pragma or a
5723 -- previously given aspect specification or attribute definition
5724 -- clause for the same pragma.
5726 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5730 -- If the entity is a type, then we have to make sure that the
5731 -- ostensible duplicate is not for a parent type from which this
5735 if Nkind (P) = N_Pragma then
5737 Args : constant List_Id :=
5738 Pragma_Argument_Associations (P);
5741 and then Is_Entity_Name (Expression (First (Args)))
5742 and then Is_Type (Entity (Expression (First (Args))))
5743 and then Entity (Expression (First (Args))) /= E
5749 elsif Nkind (P) = N_Aspect_Specification
5750 and then Is_Type (Entity (P))
5751 and then Entity (P) /= E
5757 -- Here we have a definite duplicate
5759 Error_Msg_Name_1 := Pragma_Name (N);
5760 Error_Msg_Sloc := Sloc (P);
5762 -- For a single protected or a single task object, the error is
5763 -- issued on the original entity.
5765 if Ekind (Id) in E_Task_Type | E_Protected_Type then
5766 Id := Defining_Identifier (Original_Node (Parent (Id)));
5769 if Nkind (P) = N_Aspect_Specification
5770 or else From_Aspect_Specification (P)
5772 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5774 -- If -gnatwr is set, warn in case of a duplicate pragma
5775 -- [No_]Inline which is suspicious but not an error, generate
5776 -- an error for other pragmas.
5778 if Pragma_Name (N) in Name_Inline | Name_No_Inline then
5779 if Warn_On_Redundant_Constructs then
5781 ("?r?pragma% for & duplicates pragma#", N, Id);
5784 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5790 end Check_Duplicate_Pragma;
5792 ----------------------------------
5793 -- Check_Duplicated_Export_Name --
5794 ----------------------------------
5796 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5797 String_Val : constant String_Id := Strval (Nam);
5800 -- We are only interested in the export case, and in the case of
5801 -- generics, it is the instance, not the template, that is the
5802 -- problem (the template will generate a warning in any case).
5804 if not Inside_A_Generic
5805 and then (Prag_Id = Pragma_Export
5807 Prag_Id = Pragma_Export_Procedure
5809 Prag_Id = Pragma_Export_Valued_Procedure
5811 Prag_Id = Pragma_Export_Function)
5813 for J in Externals.First .. Externals.Last loop
5814 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5815 Error_Msg_Sloc := Sloc (Externals.Table (J));
5816 Error_Msg_N ("external name duplicates name given#", Nam);
5821 Externals.Append (Nam);
5823 end Check_Duplicated_Export_Name;
5825 ----------------------------------------
5826 -- Check_Expr_Is_OK_Static_Expression --
5827 ----------------------------------------
5829 procedure Check_Expr_Is_OK_Static_Expression
5831 Typ : Entity_Id := Empty)
5834 if Present (Typ) then
5835 Analyze_And_Resolve (Expr, Typ);
5837 Analyze_And_Resolve (Expr);
5840 -- An expression cannot be considered static if its resolution failed
5841 -- or if it's erroneous. Stop the analysis of the related pragma.
5843 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5846 elsif Is_OK_Static_Expression (Expr) then
5849 -- An interesting special case, if we have a string literal and we
5850 -- are in Ada 83 mode, then we allow it even though it will not be
5851 -- flagged as static. This allows the use of Ada 95 pragmas like
5852 -- Import in Ada 83 mode. They will of course be flagged with
5853 -- warnings as usual, but will not cause errors.
5855 elsif Ada_Version = Ada_83
5856 and then Nkind (Expr) = N_String_Literal
5860 -- Finally, we have a real error
5863 Error_Msg_Name_1 := Pname;
5864 Flag_Non_Static_Expr
5865 (Fix_Error ("argument for pragma% must be a static expression!"),
5869 end Check_Expr_Is_OK_Static_Expression;
5871 -------------------------
5872 -- Check_First_Subtype --
5873 -------------------------
5875 procedure Check_First_Subtype (Arg : Node_Id) is
5876 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5877 Ent : constant Entity_Id := Entity (Argx);
5880 if Is_First_Subtype (Ent) then
5883 elsif Is_Type (Ent) then
5885 ("pragma% cannot apply to subtype", Argx);
5887 elsif Is_Object (Ent) then
5889 ("pragma% cannot apply to object, requires a type", Argx);
5893 ("pragma% cannot apply to&, requires a type", Argx);
5895 end Check_First_Subtype;
5897 ----------------------
5898 -- Check_Identifier --
5899 ----------------------
5901 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5904 and then Nkind (Arg) = N_Pragma_Argument_Association
5906 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5907 Error_Msg_Name_1 := Pname;
5908 Error_Msg_Name_2 := Id;
5909 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5913 end Check_Identifier;
5915 --------------------------------
5916 -- Check_Identifier_Is_One_Of --
5917 --------------------------------
5919 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5922 and then Nkind (Arg) = N_Pragma_Argument_Association
5924 if Chars (Arg) = No_Name then
5925 Error_Msg_Name_1 := Pname;
5926 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5929 elsif Chars (Arg) /= N1
5930 and then Chars (Arg) /= N2
5932 Error_Msg_Name_1 := Pname;
5933 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5937 end Check_Identifier_Is_One_Of;
5939 ---------------------------
5940 -- Check_In_Main_Program --
5941 ---------------------------
5943 procedure Check_In_Main_Program is
5944 P : constant Node_Id := Parent (N);
5947 -- Must be in subprogram body
5949 if Nkind (P) /= N_Subprogram_Body then
5950 Error_Pragma ("% pragma allowed only in subprogram");
5952 -- Otherwise warn if obviously not main program
5954 elsif Present (Parameter_Specifications (Specification (P)))
5955 or else not Is_Compilation_Unit (Defining_Entity (P))
5957 Error_Msg_Name_1 := Pname;
5959 ("??pragma% is only effective in main program", N);
5961 end Check_In_Main_Program;
5963 ---------------------------------------
5964 -- Check_Interrupt_Or_Attach_Handler --
5965 ---------------------------------------
5967 procedure Check_Interrupt_Or_Attach_Handler is
5968 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5969 Handler_Proc, Proc_Scope : Entity_Id;
5974 if Prag_Id = Pragma_Interrupt_Handler then
5975 Check_Restriction (No_Dynamic_Attachment, N);
5978 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5979 Proc_Scope := Scope (Handler_Proc);
5981 if Ekind (Proc_Scope) /= E_Protected_Type then
5983 ("argument of pragma% must be protected procedure", Arg1);
5986 -- For pragma case (as opposed to access case), check placement.
5987 -- We don't need to do that for aspects, because we have the
5988 -- check that they aspect applies an appropriate procedure.
5990 if not From_Aspect_Specification (N)
5991 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5993 Error_Pragma ("pragma% must be in protected definition");
5996 if not Is_Library_Level_Entity (Proc_Scope) then
5998 ("argument for pragma% must be library level entity", Arg1);
6001 -- AI05-0033: A pragma cannot appear within a generic body, because
6002 -- instance can be in a nested scope. The check that protected type
6003 -- is itself a library-level declaration is done elsewhere.
6005 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6006 -- handle code prior to AI-0033. Analysis tools typically are not
6007 -- interested in this pragma in any case, so no need to worry too
6008 -- much about its placement.
6010 if Inside_A_Generic then
6011 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6012 and then In_Package_Body (Scope (Current_Scope))
6013 and then not Relaxed_RM_Semantics
6015 Error_Pragma ("pragma% cannot be used inside a generic");
6018 end Check_Interrupt_Or_Attach_Handler;
6020 ---------------------------------
6021 -- Check_Loop_Pragma_Placement --
6022 ---------------------------------
6024 procedure Check_Loop_Pragma_Placement is
6025 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6026 -- Verify whether the current pragma is properly grouped with other
6027 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6028 -- related loop where the pragma appears.
6030 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6031 -- Determine whether an arbitrary statement Stmt denotes pragma
6032 -- Loop_Invariant or Loop_Variant.
6034 procedure Placement_Error (Constr : Node_Id);
6035 pragma No_Return (Placement_Error);
6036 -- Node Constr denotes the last loop restricted construct before we
6037 -- encountered an illegal relation between enclosing constructs. Emit
6038 -- an error depending on what Constr was.
6040 --------------------------------
6041 -- Check_Loop_Pragma_Grouping --
6042 --------------------------------
6044 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6045 Stop_Search : exception;
6046 -- This exception is used to terminate the recursive descent of
6047 -- routine Check_Grouping.
6049 procedure Check_Grouping (L : List_Id);
6050 -- Find the first group of pragmas in list L and if successful,
6051 -- ensure that the current pragma is part of that group. The
6052 -- routine raises Stop_Search once such a check is performed to
6053 -- halt the recursive descent.
6055 procedure Grouping_Error (Prag : Node_Id);
6056 pragma No_Return (Grouping_Error);
6057 -- Emit an error concerning the current pragma indicating that it
6058 -- should be placed after pragma Prag.
6060 --------------------
6061 -- Check_Grouping --
6062 --------------------
6064 procedure Check_Grouping (L : List_Id) is
6067 Prag : Node_Id := Empty; -- init to avoid warning
6070 -- Inspect the list of declarations or statements looking for
6071 -- the first grouping of pragmas:
6074 -- pragma Loop_Invariant ...;
6075 -- pragma Loop_Variant ...;
6077 -- pragma Loop_Variant ...; -- current pragma
6079 -- If the current pragma is not in the grouping, then it must
6080 -- either appear in a different declarative or statement list
6081 -- or the construct at (1) is separating the pragma from the
6085 while Present (Stmt) loop
6087 -- First pragma of the first topmost grouping has been found
6089 if Is_Loop_Pragma (Stmt) then
6091 -- The group and the current pragma are not in the same
6092 -- declarative or statement list.
6094 if not In_Same_List (Stmt, N) then
6095 Grouping_Error (Stmt);
6097 -- Try to reach the current pragma from the first pragma
6098 -- of the grouping while skipping other members:
6100 -- pragma Loop_Invariant ...; -- first pragma
6101 -- pragma Loop_Variant ...; -- member
6103 -- pragma Loop_Variant ...; -- current pragma
6106 while Present (Stmt) loop
6107 -- The current pragma is either the first pragma
6108 -- of the group or is a member of the group.
6109 -- Stop the search as the placement is legal.
6114 -- Skip group members, but keep track of the
6115 -- last pragma in the group.
6117 elsif Is_Loop_Pragma (Stmt) then
6120 -- Skip declarations and statements generated by
6121 -- the compiler during expansion. Note that some
6122 -- source statements (e.g. pragma Assert) may have
6123 -- been transformed so that they do not appear as
6124 -- coming from source anymore, so we instead look
6125 -- at their Original_Node.
6127 elsif not Comes_From_Source (Original_Node (Stmt))
6131 -- A non-pragma is separating the group from the
6132 -- current pragma, the placement is illegal.
6135 Grouping_Error (Prag);
6141 -- If the traversal did not reach the current pragma,
6142 -- then the list must be malformed.
6144 raise Program_Error;
6147 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6148 -- inside a loop or a block housed inside a loop. Inspect
6149 -- the declarations and statements of the block as they may
6150 -- contain the first grouping. This case follows the one for
6151 -- loop pragmas, as block statements which originate in a
6152 -- loop pragma (and so Is_Loop_Pragma will return True on
6153 -- that block statement) should be treated in the previous
6156 elsif Nkind (Stmt) = N_Block_Statement then
6157 HSS := Handled_Statement_Sequence (Stmt);
6159 Check_Grouping (Declarations (Stmt));
6161 if Present (HSS) then
6162 Check_Grouping (Statements (HSS));
6170 --------------------
6171 -- Grouping_Error --
6172 --------------------
6174 procedure Grouping_Error (Prag : Node_Id) is
6176 Error_Msg_Sloc := Sloc (Prag);
6177 Error_Pragma ("pragma% must appear next to pragma#");
6180 -- Start of processing for Check_Loop_Pragma_Grouping
6183 -- Inspect the statements of the loop or nested blocks housed
6184 -- within to determine whether the current pragma is part of the
6185 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6187 Check_Grouping (Statements (Loop_Stmt));
6190 when Stop_Search => null;
6191 end Check_Loop_Pragma_Grouping;
6193 --------------------
6194 -- Is_Loop_Pragma --
6195 --------------------
6197 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6198 Original_Stmt : constant Node_Id := Original_Node (Stmt);
6201 -- Inspect the original node as Loop_Invariant and Loop_Variant
6202 -- pragmas are rewritten to null when assertions are disabled.
6204 return Nkind (Original_Stmt) = N_Pragma
6205 and then Pragma_Name_Unmapped (Original_Stmt)
6206 in Name_Loop_Invariant | Name_Loop_Variant;
6209 ---------------------
6210 -- Placement_Error --
6211 ---------------------
6213 procedure Placement_Error (Constr : Node_Id) is
6214 LA : constant String := " with Loop_Entry";
6217 if Prag_Id = Pragma_Assert then
6218 Error_Msg_String (1 .. LA'Length) := LA;
6219 Error_Msg_Strlen := LA'Length;
6221 Error_Msg_Strlen := 0;
6224 if Nkind (Constr) = N_Pragma then
6226 ("pragma %~ must appear immediately within the statements "
6230 ("block containing pragma %~ must appear immediately within "
6231 & "the statements of a loop", Constr);
6233 end Placement_Error;
6235 -- Local declarations
6240 -- Start of processing for Check_Loop_Pragma_Placement
6243 -- Check that pragma appears immediately within a loop statement,
6244 -- ignoring intervening block statements.
6248 while Present (Stmt) loop
6250 -- The pragma or previous block must appear immediately within the
6251 -- current block's declarative or statement part.
6253 if Nkind (Stmt) = N_Block_Statement then
6254 if (No (Declarations (Stmt))
6255 or else List_Containing (Prev) /= Declarations (Stmt))
6257 List_Containing (Prev) /=
6258 Statements (Handled_Statement_Sequence (Stmt))
6260 Placement_Error (Prev);
6263 -- Keep inspecting the parents because we are now within a
6264 -- chain of nested blocks.
6268 Stmt := Parent (Stmt);
6271 -- The pragma or previous block must appear immediately within the
6272 -- statements of the loop.
6274 elsif Nkind (Stmt) = N_Loop_Statement then
6275 if List_Containing (Prev) /= Statements (Stmt) then
6276 Placement_Error (Prev);
6279 -- Stop the traversal because we reached the innermost loop
6280 -- regardless of whether we encountered an error or not.
6284 -- Ignore a handled statement sequence. Note that this node may
6285 -- be related to a subprogram body in which case we will emit an
6286 -- error on the next iteration of the search.
6288 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6289 Stmt := Parent (Stmt);
6291 -- Any other statement breaks the chain from the pragma to the
6295 Placement_Error (Prev);
6300 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6301 -- grouped together with other such pragmas.
6303 if Is_Loop_Pragma (N) then
6305 -- The previous check should have located the related loop
6307 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6308 Check_Loop_Pragma_Grouping (Stmt);
6310 end Check_Loop_Pragma_Placement;
6312 -------------------------------------------
6313 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6314 -------------------------------------------
6316 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6325 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6328 elsif Nkind (P) in N_Package_Specification | N_Block_Statement then
6331 -- Note: the following tests seem a little peculiar, because
6332 -- they test for bodies, but if we were in the statement part
6333 -- of the body, we would already have hit the handled statement
6334 -- sequence, so the only way we get here is by being in the
6335 -- declarative part of the body.
6338 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6346 Error_Pragma ("pragma% is not in declarative part or package spec");
6347 end Check_Is_In_Decl_Part_Or_Package_Spec;
6349 -------------------------
6350 -- Check_No_Identifier --
6351 -------------------------
6353 procedure Check_No_Identifier (Arg : Node_Id) is
6355 if Nkind (Arg) = N_Pragma_Argument_Association
6356 and then Chars (Arg) /= No_Name
6358 Error_Pragma_Arg_Ident
6359 ("pragma% does not permit identifier& here", Arg);
6361 end Check_No_Identifier;
6363 --------------------------
6364 -- Check_No_Identifiers --
6365 --------------------------
6367 procedure Check_No_Identifiers is
6371 for J in 1 .. Arg_Count loop
6372 Check_No_Identifier (Arg_Node);
6375 end Check_No_Identifiers;
6377 ------------------------
6378 -- Check_No_Link_Name --
6379 ------------------------
6381 procedure Check_No_Link_Name is
6383 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6387 if Present (Arg4) then
6389 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6391 end Check_No_Link_Name;
6393 -------------------------------
6394 -- Check_Optional_Identifier --
6395 -------------------------------
6397 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6400 and then Nkind (Arg) = N_Pragma_Argument_Association
6401 and then Chars (Arg) /= No_Name
6403 if Chars (Arg) /= Id then
6404 Error_Msg_Name_1 := Pname;
6405 Error_Msg_Name_2 := Id;
6406 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6410 end Check_Optional_Identifier;
6412 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6414 Check_Optional_Identifier (Arg, Name_Find (Id));
6415 end Check_Optional_Identifier;
6417 -------------------------------------
6418 -- Check_Static_Boolean_Expression --
6419 -------------------------------------
6421 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6423 if Present (Expr) then
6424 Analyze_And_Resolve (Expr, Standard_Boolean);
6426 if not Is_OK_Static_Expression (Expr) then
6428 ("expression of pragma % must be static", Expr);
6431 end Check_Static_Boolean_Expression;
6433 -----------------------------
6434 -- Check_Static_Constraint --
6435 -----------------------------
6437 -- Note: for convenience in writing this procedure, in addition to
6438 -- the officially (i.e. by spec) allowed argument which is always a
6439 -- constraint, it also allows ranges and discriminant associations.
6440 -- Above is not clear ???
6442 procedure Check_Static_Constraint (Constr : Node_Id) is
6444 procedure Require_Static (E : Node_Id);
6445 -- Require given expression to be static expression
6447 --------------------
6448 -- Require_Static --
6449 --------------------
6451 procedure Require_Static (E : Node_Id) is
6453 if not Is_OK_Static_Expression (E) then
6454 Flag_Non_Static_Expr
6455 ("non-static constraint not allowed in Unchecked_Union!", E);
6460 -- Start of processing for Check_Static_Constraint
6463 case Nkind (Constr) is
6464 when N_Discriminant_Association =>
6465 Require_Static (Expression (Constr));
6468 Require_Static (Low_Bound (Constr));
6469 Require_Static (High_Bound (Constr));
6471 when N_Attribute_Reference =>
6472 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6473 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6475 when N_Range_Constraint =>
6476 Check_Static_Constraint (Range_Expression (Constr));
6478 when N_Index_Or_Discriminant_Constraint =>
6482 IDC := First (Constraints (Constr));
6483 while Present (IDC) loop
6484 Check_Static_Constraint (IDC);
6492 end Check_Static_Constraint;
6494 --------------------------------------
6495 -- Check_Valid_Configuration_Pragma --
6496 --------------------------------------
6498 -- A configuration pragma must appear in the context clause of a
6499 -- compilation unit, and only other pragmas may precede it. Note that
6500 -- the test also allows use in a configuration pragma file.
6502 procedure Check_Valid_Configuration_Pragma is
6504 if not Is_Configuration_Pragma then
6505 Error_Pragma ("incorrect placement for configuration pragma%");
6507 end Check_Valid_Configuration_Pragma;
6509 -------------------------------------
6510 -- Check_Valid_Library_Unit_Pragma --
6511 -------------------------------------
6513 procedure Check_Valid_Library_Unit_Pragma is
6515 Parent_Node : Node_Id;
6516 Unit_Name : Entity_Id;
6517 Unit_Kind : Node_Kind;
6518 Unit_Node : Node_Id;
6519 Sindex : Source_File_Index;
6522 if not Is_List_Member (N) then
6526 Plist := List_Containing (N);
6527 Parent_Node := Parent (Plist);
6529 if Parent_Node = Empty then
6532 -- Case of pragma appearing after a compilation unit. In this case
6533 -- it must have an argument with the corresponding name and must
6534 -- be part of the following pragmas of its parent.
6536 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6537 if Plist /= Pragmas_After (Parent_Node) then
6540 elsif Arg_Count = 0 then
6542 ("argument required if outside compilation unit");
6545 Check_No_Identifiers;
6546 Check_Arg_Count (1);
6547 Unit_Node := Unit (Parent (Parent_Node));
6548 Unit_Kind := Nkind (Unit_Node);
6550 Analyze (Get_Pragma_Arg (Arg1));
6552 if Unit_Kind = N_Generic_Subprogram_Declaration
6553 or else Unit_Kind = N_Subprogram_Declaration
6555 Unit_Name := Defining_Entity (Unit_Node);
6557 elsif Unit_Kind in N_Generic_Instantiation then
6558 Unit_Name := Defining_Entity (Unit_Node);
6561 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6564 if Chars (Unit_Name) /=
6565 Chars (Entity (Get_Pragma_Arg (Arg1)))
6568 ("pragma% argument is not current unit name", Arg1);
6571 if Ekind (Unit_Name) = E_Package
6572 and then Present (Renamed_Entity (Unit_Name))
6574 Error_Pragma ("pragma% not allowed for renamed package");
6578 -- Pragma appears other than after a compilation unit
6581 -- Here we check for the generic instantiation case and also
6582 -- for the case of processing a generic formal package. We
6583 -- detect these cases by noting that the Sloc on the node
6584 -- does not belong to the current compilation unit.
6586 Sindex := Source_Index (Current_Sem_Unit);
6588 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6589 Rewrite (N, Make_Null_Statement (Loc));
6592 -- If before first declaration, the pragma applies to the
6593 -- enclosing unit, and the name if present must be this name.
6595 elsif Is_Before_First_Decl (N, Plist) then
6596 Unit_Node := Unit_Declaration_Node (Current_Scope);
6597 Unit_Kind := Nkind (Unit_Node);
6599 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6602 elsif Unit_Kind = N_Subprogram_Body
6603 and then not Acts_As_Spec (Unit_Node)
6607 elsif Nkind (Parent_Node) = N_Package_Body then
6610 elsif Nkind (Parent_Node) = N_Package_Specification
6611 and then Plist = Private_Declarations (Parent_Node)
6615 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6616 or else Nkind (Parent_Node) =
6617 N_Generic_Subprogram_Declaration)
6618 and then Plist = Generic_Formal_Declarations (Parent_Node)
6622 elsif Arg_Count > 0 then
6623 Analyze (Get_Pragma_Arg (Arg1));
6625 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6627 ("name in pragma% must be enclosing unit", Arg1);
6630 -- It is legal to have no argument in this context
6636 -- Error if not before first declaration. This is because a
6637 -- library unit pragma argument must be the name of a library
6638 -- unit (RM 10.1.5(7)), but the only names permitted in this
6639 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6640 -- generic subprogram declarations or generic instantiations.
6644 ("pragma% misplaced, must be before first declaration");
6648 end Check_Valid_Library_Unit_Pragma;
6654 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6655 Clist : constant Node_Id := Component_List (Variant);
6659 Comp := First_Non_Pragma (Component_Items (Clist));
6660 while Present (Comp) loop
6661 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6662 Next_Non_Pragma (Comp);
6666 ---------------------------
6667 -- Ensure_Aggregate_Form --
6668 ---------------------------
6670 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6671 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6672 Expr : constant Node_Id := Expression (Arg);
6673 Loc : constant Source_Ptr := Sloc (Expr);
6674 Comps : List_Id := No_List;
6675 Exprs : List_Id := No_List;
6676 Nam : Name_Id := No_Name;
6677 Nam_Loc : Source_Ptr;
6680 -- The pragma argument is in positional form:
6682 -- pragma Depends (Nam => ...)
6686 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6687 -- argument association.
6689 if Nkind (Arg) = N_Pragma_Argument_Association then
6691 Nam_Loc := Sloc (Arg);
6693 -- Remove the pragma argument name as this will be captured in the
6696 Set_Chars (Arg, No_Name);
6699 -- The argument is already in aggregate form, but the presence of a
6700 -- name causes this to be interpreted as named association which in
6701 -- turn must be converted into an aggregate.
6703 -- pragma Global (In_Out => (A, B, C))
6707 -- pragma Global ((In_Out => (A, B, C)))
6709 -- aggregate aggregate
6711 if Nkind (Expr) = N_Aggregate then
6712 if Nam = No_Name then
6716 -- Do not transform a null argument into an aggregate as N_Null has
6717 -- special meaning in formal verification pragmas.
6719 elsif Nkind (Expr) = N_Null then
6723 -- Everything comes from source if the original comes from source
6725 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6727 -- Positional argument is transformed into an aggregate with an
6728 -- Expressions list.
6730 if Nam = No_Name then
6731 Exprs := New_List (Relocate_Node (Expr));
6733 -- An associative argument is transformed into an aggregate with
6734 -- Component_Associations.
6738 Make_Component_Association (Loc,
6739 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6740 Expression => Relocate_Node (Expr)));
6743 Set_Expression (Arg,
6744 Make_Aggregate (Loc,
6745 Component_Associations => Comps,
6746 Expressions => Exprs));
6748 -- Restore Comes_From_Source default
6750 Set_Comes_From_Source_Default (CFSD);
6751 end Ensure_Aggregate_Form;
6757 procedure Error_Pragma (Msg : String) is
6759 Error_Msg_Name_1 := Pname;
6760 Error_Msg_N (Fix_Error (Msg), N);
6764 ----------------------
6765 -- Error_Pragma_Arg --
6766 ----------------------
6768 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6770 Error_Msg_Name_1 := Pname;
6771 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6773 end Error_Pragma_Arg;
6775 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6777 Error_Msg_Name_1 := Pname;
6778 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6779 Error_Pragma_Arg (Msg2, Arg);
6780 end Error_Pragma_Arg;
6782 ----------------------------
6783 -- Error_Pragma_Arg_Ident --
6784 ----------------------------
6786 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6788 Error_Msg_Name_1 := Pname;
6789 Error_Msg_N (Fix_Error (Msg), Arg);
6791 end Error_Pragma_Arg_Ident;
6793 ----------------------
6794 -- Error_Pragma_Ref --
6795 ----------------------
6797 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6799 Error_Msg_Name_1 := Pname;
6800 Error_Msg_Sloc := Sloc (Ref);
6801 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6803 end Error_Pragma_Ref;
6805 ------------------------
6806 -- Find_Lib_Unit_Name --
6807 ------------------------
6809 function Find_Lib_Unit_Name return Entity_Id is
6811 -- Return inner compilation unit entity, for case of nested
6812 -- categorization pragmas. This happens in generic unit.
6814 if Nkind (Parent (N)) = N_Package_Specification
6815 and then Defining_Entity (Parent (N)) /= Current_Scope
6817 return Defining_Entity (Parent (N));
6819 return Current_Scope;
6821 end Find_Lib_Unit_Name;
6823 ----------------------------
6824 -- Find_Program_Unit_Name --
6825 ----------------------------
6827 procedure Find_Program_Unit_Name (Id : Node_Id) is
6828 Unit_Name : Entity_Id;
6829 Unit_Kind : Node_Kind;
6830 P : constant Node_Id := Parent (N);
6833 if Nkind (P) = N_Compilation_Unit then
6834 Unit_Kind := Nkind (Unit (P));
6836 if Unit_Kind in N_Subprogram_Declaration
6837 | N_Package_Declaration
6838 | N_Generic_Declaration
6840 Unit_Name := Defining_Entity (Unit (P));
6842 if Chars (Id) = Chars (Unit_Name) then
6843 Set_Entity (Id, Unit_Name);
6844 Set_Etype (Id, Etype (Unit_Name));
6846 Set_Etype (Id, Any_Type);
6848 ("cannot find program unit referenced by pragma%");
6852 Set_Etype (Id, Any_Type);
6853 Error_Pragma ("pragma% inapplicable to this unit");
6859 end Find_Program_Unit_Name;
6861 -----------------------------------------
6862 -- Find_Unique_Parameterless_Procedure --
6863 -----------------------------------------
6865 function Find_Unique_Parameterless_Procedure
6867 Arg : Node_Id) return Entity_Id
6869 Proc : Entity_Id := Empty;
6872 -- The body of this procedure needs some comments ???
6874 if not Is_Entity_Name (Name) then
6876 ("argument of pragma% must be entity name", Arg);
6878 elsif not Is_Overloaded (Name) then
6879 Proc := Entity (Name);
6881 if Ekind (Proc) /= E_Procedure
6882 or else Present (First_Formal (Proc))
6885 ("argument of pragma% must be parameterless procedure", Arg);
6890 Found : Boolean := False;
6892 Index : Interp_Index;
6895 Get_First_Interp (Name, Index, It);
6896 while Present (It.Nam) loop
6899 if Ekind (Proc) = E_Procedure
6900 and then No (First_Formal (Proc))
6904 Set_Entity (Name, Proc);
6905 Set_Is_Overloaded (Name, False);
6908 ("ambiguous handler name for pragma% ", Arg);
6912 Get_Next_Interp (Index, It);
6917 ("argument of pragma% must be parameterless procedure",
6920 Proc := Entity (Name);
6926 end Find_Unique_Parameterless_Procedure;
6932 function Fix_Error (Msg : String) return String is
6933 Res : String (Msg'Range) := Msg;
6934 Res_Last : Natural := Msg'Last;
6938 -- If we have a rewriting of another pragma, go to that pragma
6940 if Is_Rewrite_Substitution (N)
6941 and then Nkind (Original_Node (N)) = N_Pragma
6943 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6946 -- Case where pragma comes from an aspect specification
6948 if From_Aspect_Specification (N) then
6950 -- Change appearence of "pragma" in message to "aspect"
6953 while J <= Res_Last - 5 loop
6954 if Res (J .. J + 5) = "pragma" then
6955 Res (J .. J + 5) := "aspect";
6963 -- Change "argument of" at start of message to "entity for"
6966 and then Res (Res'First .. Res'First + 10) = "argument of"
6968 Res (Res'First .. Res'First + 9) := "entity for";
6969 Res (Res'First + 10 .. Res_Last - 1) :=
6970 Res (Res'First + 11 .. Res_Last);
6971 Res_Last := Res_Last - 1;
6974 -- Change "argument" at start of message to "entity"
6977 and then Res (Res'First .. Res'First + 7) = "argument"
6979 Res (Res'First .. Res'First + 5) := "entity";
6980 Res (Res'First + 6 .. Res_Last - 2) :=
6981 Res (Res'First + 8 .. Res_Last);
6982 Res_Last := Res_Last - 2;
6985 -- Get name from corresponding aspect
6987 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6990 -- Return possibly modified message
6992 return Res (Res'First .. Res_Last);
6995 -------------------------
6996 -- Gather_Associations --
6997 -------------------------
6999 procedure Gather_Associations
7001 Args : out Args_List)
7006 -- Initialize all parameters to Empty
7008 for J in Args'Range loop
7012 -- That's all we have to do if there are no argument associations
7014 if No (Pragma_Argument_Associations (N)) then
7018 -- Otherwise first deal with any positional parameters present
7020 Arg := First (Pragma_Argument_Associations (N));
7021 for Index in Args'Range loop
7022 exit when No (Arg) or else Chars (Arg) /= No_Name;
7023 Args (Index) := Get_Pragma_Arg (Arg);
7027 -- Positional parameters all processed, if any left, then we
7028 -- have too many positional parameters.
7030 if Present (Arg) and then Chars (Arg) = No_Name then
7032 ("too many positional associations for pragma%", Arg);
7035 -- Process named parameters if any are present
7037 while Present (Arg) loop
7038 if Chars (Arg) = No_Name then
7040 ("positional association cannot follow named association",
7044 for Index in Names'Range loop
7045 if Names (Index) = Chars (Arg) then
7046 if Present (Args (Index)) then
7048 ("duplicate argument association for pragma%", Arg);
7050 Args (Index) := Get_Pragma_Arg (Arg);
7055 if Index = Names'Last then
7056 Error_Msg_Name_1 := Pname;
7057 Error_Msg_N ("pragma% does not allow & argument", Arg);
7059 -- Check for possible misspelling
7061 for Index1 in Names'Range loop
7062 if Is_Bad_Spelling_Of
7063 (Chars (Arg), Names (Index1))
7065 Error_Msg_Name_1 := Names (Index1);
7066 Error_Msg_N -- CODEFIX
7067 ("\possible misspelling of%", Arg);
7079 end Gather_Associations;
7085 procedure GNAT_Pragma is
7087 -- We need to check the No_Implementation_Pragmas restriction for
7088 -- the case of a pragma from source. Note that the case of aspects
7089 -- generating corresponding pragmas marks these pragmas as not being
7090 -- from source, so this test also catches that case.
7092 if Comes_From_Source (N) then
7093 Check_Restriction (No_Implementation_Pragmas, N);
7097 --------------------------
7098 -- Is_Before_First_Decl --
7099 --------------------------
7101 function Is_Before_First_Decl
7102 (Pragma_Node : Node_Id;
7103 Decls : List_Id) return Boolean
7105 Item : Node_Id := First (Decls);
7108 -- Only other pragmas can come before this pragma, but they might
7109 -- have been rewritten so check the original node.
7112 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then
7115 elsif Item = Pragma_Node then
7121 end Is_Before_First_Decl;
7123 -----------------------------
7124 -- Is_Configuration_Pragma --
7125 -----------------------------
7127 -- A configuration pragma must appear in the context clause of a
7128 -- compilation unit, and only other pragmas may precede it. Note that
7129 -- the test below also permits use in a configuration pragma file.
7131 function Is_Configuration_Pragma return Boolean is
7132 Lis : constant List_Id := List_Containing (N);
7133 Par : constant Node_Id := Parent (N);
7137 -- If no parent, then we are in the configuration pragma file,
7138 -- so the placement is definitely appropriate.
7143 -- Otherwise we must be in the context clause of a compilation unit
7144 -- and the only thing allowed before us in the context list is more
7145 -- configuration pragmas.
7147 elsif Nkind (Par) = N_Compilation_Unit
7148 and then Context_Items (Par) = Lis
7155 elsif Nkind (Prg) /= N_Pragma then
7165 end Is_Configuration_Pragma;
7167 --------------------------
7168 -- Is_In_Context_Clause --
7169 --------------------------
7171 function Is_In_Context_Clause return Boolean is
7173 Parent_Node : Node_Id;
7176 if not Is_List_Member (N) then
7180 Plist := List_Containing (N);
7181 Parent_Node := Parent (Plist);
7183 if Parent_Node = Empty
7184 or else Nkind (Parent_Node) /= N_Compilation_Unit
7185 or else Context_Items (Parent_Node) /= Plist
7192 end Is_In_Context_Clause;
7194 ---------------------------------
7195 -- Is_Static_String_Expression --
7196 ---------------------------------
7198 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7199 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7200 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7203 Analyze_And_Resolve (Argx);
7205 -- Special case Ada 83, where the expression will never be static,
7206 -- but we will return true if we had a string literal to start with.
7208 if Ada_Version = Ada_83 then
7211 -- Normal case, true only if we end up with a string literal that
7212 -- is marked as being the result of evaluating a static expression.
7215 return Is_OK_Static_Expression (Argx)
7216 and then Nkind (Argx) = N_String_Literal;
7219 end Is_Static_String_Expression;
7221 ----------------------
7222 -- Pragma_Misplaced --
7223 ----------------------
7225 procedure Pragma_Misplaced is
7227 Error_Pragma ("incorrect placement of pragma%");
7228 end Pragma_Misplaced;
7230 ------------------------------------------------
7231 -- Process_Atomic_Independent_Shared_Volatile --
7232 ------------------------------------------------
7234 procedure Process_Atomic_Independent_Shared_Volatile is
7235 procedure Check_Full_Access_Only (Ent : Entity_Id);
7236 -- Apply legality checks to type or object Ent subject to the
7237 -- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)).
7239 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7240 -- Appropriately set flags on the given entity, either an array or
7241 -- record component, or an object declaration) according to the
7244 procedure Mark_Type (Ent : Entity_Id);
7245 -- Appropriately set flags on the given entity, a type
7247 procedure Set_Atomic_VFA (Ent : Entity_Id);
7248 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7249 -- no explicit alignment was given, set alignment to unknown, since
7250 -- back end knows what the alignment requirements are for atomic and
7251 -- full access arrays. Note: this is necessary for derived types.
7253 -------------------------
7254 -- Check_Full_Access_Only --
7255 -------------------------
7257 procedure Check_Full_Access_Only (Ent : Entity_Id) is
7260 Full_Access_Subcomponent : exception;
7261 -- Exception raised if a full access subcomponent is found
7263 Generic_Type_Subcomponent : exception;
7264 -- Exception raised if a subcomponent with generic type is found
7266 procedure Check_Subcomponents (Typ : Entity_Id);
7267 -- Apply checks to subcomponents recursively
7269 -------------------------
7270 -- Check_Subcomponents --
7271 -------------------------
7273 procedure Check_Subcomponents (Typ : Entity_Id) is
7277 if Is_Array_Type (Typ) then
7278 Comp := Component_Type (Typ);
7280 if Has_Atomic_Components (Typ)
7281 or else Is_Full_Access (Comp)
7283 raise Full_Access_Subcomponent;
7285 elsif Is_Generic_Type (Comp) then
7286 raise Generic_Type_Subcomponent;
7289 -- Recurse on the component type
7291 Check_Subcomponents (Comp);
7293 elsif Is_Record_Type (Typ) then
7294 Comp := First_Component_Or_Discriminant (Typ);
7295 while Present (Comp) loop
7297 if Is_Full_Access (Comp)
7298 or else Is_Full_Access (Etype (Comp))
7300 raise Full_Access_Subcomponent;
7302 elsif Is_Generic_Type (Etype (Comp)) then
7303 raise Generic_Type_Subcomponent;
7306 -- Recurse on the component type
7308 Check_Subcomponents (Etype (Comp));
7310 Next_Component_Or_Discriminant (Comp);
7313 end Check_Subcomponents;
7315 -- Start of processing for Check_Full_Access_Only
7318 -- Fetch the type in case we are dealing with an object or
7321 if Is_Type (Ent) then
7324 pragma Assert (Is_Object (Ent)
7326 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7331 if not Is_Volatile (Ent) and then not Is_Volatile (Typ) then
7333 ("cannot have Full_Access_Only without Volatile/Atomic "
7338 -- Check all the subcomponents of the type recursively, if any
7340 Check_Subcomponents (Typ);
7343 when Full_Access_Subcomponent =>
7345 ("cannot have Full_Access_Only with full access subcomponent "
7348 when Generic_Type_Subcomponent =>
7350 ("cannot have Full_Access_Only with subcomponent of generic "
7351 & "type (RM C.6(8.2))");
7353 end Check_Full_Access_Only;
7355 ------------------------------
7356 -- Mark_Component_Or_Object --
7357 ------------------------------
7359 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7361 if Prag_Id = Pragma_Atomic
7362 or else Prag_Id = Pragma_Shared
7363 or else Prag_Id = Pragma_Volatile_Full_Access
7365 if Prag_Id = Pragma_Volatile_Full_Access then
7366 Set_Is_Volatile_Full_Access (Ent);
7368 Set_Is_Atomic (Ent);
7371 -- If the object declaration has an explicit initialization, a
7372 -- temporary may have to be created to hold the expression, to
7373 -- ensure that access to the object remains atomic.
7375 if Nkind (Parent (Ent)) = N_Object_Declaration
7376 and then Present (Expression (Parent (Ent)))
7378 Set_Has_Delayed_Freeze (Ent);
7382 -- Atomic/Shared/Volatile_Full_Access imply Independent
7384 if Prag_Id /= Pragma_Volatile then
7385 Set_Is_Independent (Ent);
7387 if Prag_Id = Pragma_Independent then
7388 Record_Independence_Check (N, Ent);
7392 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7394 if Prag_Id /= Pragma_Independent then
7395 Set_Is_Volatile (Ent);
7396 Set_Treat_As_Volatile (Ent);
7398 end Mark_Component_Or_Object;
7404 procedure Mark_Type (Ent : Entity_Id) is
7406 -- Attribute belongs on the base type. If the view of the type is
7407 -- currently private, it also belongs on the underlying type.
7409 -- In Ada 2020, the pragma can apply to a formal type, for which
7410 -- there may be no underlying type.
7412 if Prag_Id = Pragma_Atomic
7413 or else Prag_Id = Pragma_Shared
7414 or else Prag_Id = Pragma_Volatile_Full_Access
7416 Set_Atomic_VFA (Ent);
7417 Set_Atomic_VFA (Base_Type (Ent));
7419 if not Is_Generic_Type (Ent) then
7420 Set_Atomic_VFA (Underlying_Type (Ent));
7424 -- Atomic/Shared/Volatile_Full_Access imply Independent
7426 if Prag_Id /= Pragma_Volatile then
7427 Set_Is_Independent (Ent);
7428 Set_Is_Independent (Base_Type (Ent));
7430 if not Is_Generic_Type (Ent) then
7431 Set_Is_Independent (Underlying_Type (Ent));
7433 if Prag_Id = Pragma_Independent then
7434 Record_Independence_Check (N, Base_Type (Ent));
7439 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7441 if Prag_Id /= Pragma_Independent then
7442 Set_Is_Volatile (Ent);
7443 Set_Is_Volatile (Base_Type (Ent));
7445 if not Is_Generic_Type (Ent) then
7446 Set_Is_Volatile (Underlying_Type (Ent));
7447 Set_Treat_As_Volatile (Underlying_Type (Ent));
7450 Set_Treat_As_Volatile (Ent);
7453 -- Apply Volatile to the composite type's individual components,
7456 if Prag_Id = Pragma_Volatile
7457 and then Is_Record_Type (Etype (Ent))
7462 Comp := First_Component (Ent);
7463 while Present (Comp) loop
7464 Mark_Component_Or_Object (Comp);
7466 Next_Component (Comp);
7472 --------------------
7473 -- Set_Atomic_VFA --
7474 --------------------
7476 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7478 if Prag_Id = Pragma_Volatile_Full_Access then
7479 Set_Is_Volatile_Full_Access (Ent);
7481 Set_Is_Atomic (Ent);
7484 if not Has_Alignment_Clause (Ent) then
7485 Set_Alignment (Ent, Uint_0);
7495 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7498 Check_Ada_83_Warning;
7499 Check_No_Identifiers;
7500 Check_Arg_Count (1);
7501 Check_Arg_Is_Local_Name (Arg1);
7502 E_Arg := Get_Pragma_Arg (Arg1);
7504 if Etype (E_Arg) = Any_Type then
7508 E := Entity (E_Arg);
7509 Decl := Declaration_Node (E);
7511 -- A pragma that applies to a Ghost entity becomes Ghost for the
7512 -- purposes of legality checks and removal of ignored Ghost code.
7514 Mark_Ghost_Pragma (N, E);
7516 -- Check duplicate before we chain ourselves
7518 Check_Duplicate_Pragma (E);
7520 -- Check the constraints of Full_Access_Only in Ada 2020. Note that
7521 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
7522 -- aspect subsumes the Volatile aspect and 2) nesting is supported
7523 -- for this aspect and the outermost enclosing VFA object prevails.
7525 -- Note also that we used to forbid specifying both Atomic and VFA on
7526 -- the same type or object, but the restriction has been lifted in
7527 -- light of the semantics of Full_Access_Only and Atomic in Ada 2020.
7529 if Prag_Id = Pragma_Volatile_Full_Access
7530 and then From_Aspect_Specification (N)
7532 Get_Aspect_Id (Corresponding_Aspect (N)) = Aspect_Full_Access_Only
7534 Check_Full_Access_Only (E);
7537 -- The following check is only relevant when SPARK_Mode is on as
7538 -- this is not a standard Ada legality rule. Pragma Volatile can
7539 -- only apply to a full type declaration or an object declaration
7540 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7541 -- untagged derived types that are rewritten as subtypes of their
7542 -- respective root types.
7545 and then Prag_Id = Pragma_Volatile
7546 and then Nkind (Original_Node (Decl)) not in
7547 N_Full_Type_Declaration |
7548 N_Formal_Type_Declaration |
7549 N_Object_Declaration |
7550 N_Single_Protected_Declaration |
7551 N_Single_Task_Declaration
7554 ("argument of pragma % must denote a full type or object "
7555 & "declaration", Arg1);
7558 -- Deal with the case where the pragma/attribute is applied to a type
7561 if Rep_Item_Too_Early (E, N)
7562 or else Rep_Item_Too_Late (E, N)
7566 Check_First_Subtype (Arg1);
7571 -- Deal with the case where the pragma/attribute applies to a
7572 -- component or object declaration.
7574 elsif Nkind (Decl) = N_Object_Declaration
7575 or else (Nkind (Decl) = N_Component_Declaration
7576 and then Original_Record_Component (E) = E)
7578 if Rep_Item_Too_Late (E, N) then
7582 Mark_Component_Or_Object (E);
7584 -- In other cases give an error
7587 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7589 end Process_Atomic_Independent_Shared_Volatile;
7591 -------------------------------------------
7592 -- Process_Compile_Time_Warning_Or_Error --
7593 -------------------------------------------
7595 procedure Process_Compile_Time_Warning_Or_Error is
7596 P : Node_Id := Parent (N);
7597 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7600 Check_Arg_Count (2);
7601 Check_No_Identifiers;
7602 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7603 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7605 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7606 -- a Check pragma in GNATprove mode, handled as an assumption in
7607 -- GNATprove. This is correct as the compiler will issue an error
7608 -- if the condition cannot be statically evaluated to False.
7609 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7610 -- same information as the compiler (in particular regarding size of
7611 -- objects decided in gigi) so it makes no sense to issue a warning
7614 if GNATprove_Mode then
7615 if Prag_Id = Pragma_Compile_Time_Error then
7619 -- Implement Compile_Time_Error by generating
7620 -- a corresponding Check pragma:
7622 -- pragma Check (name, condition);
7624 -- where name is the identifier matching the pragma name. So
7625 -- rewrite pragma in this manner and analyze the result.
7627 New_Args := New_List
7628 (Make_Pragma_Argument_Association
7630 Expression => Make_Identifier (Loc, Pname)),
7631 Make_Pragma_Argument_Association
7633 Expression => Arg1x));
7635 -- Rewrite as Check pragma
7639 Chars => Name_Check,
7640 Pragma_Argument_Associations => New_Args));
7646 Rewrite (N, Make_Null_Statement (Loc));
7652 -- If the condition is known at compile time (now), validate it now.
7653 -- Otherwise, register the expression for validation after the back
7654 -- end has been called, because it might be known at compile time
7655 -- then. For example, if the expression is "Record_Type'Size /= 32"
7656 -- it might be known after the back end has determined the size of
7657 -- Record_Type. We do not defer validation if we're inside a generic
7658 -- unit, because we will have more information in the instances.
7660 if Compile_Time_Known_Value (Arg1x) then
7661 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7663 while Present (P) and then Nkind (P) not in N_Generic_Declaration
7665 if Nkind (P) in N_Package_Body | N_Subprogram_Body then
7666 P := Corresponding_Spec (P);
7673 Defer_Compile_Time_Warning_Error_To_BE (N);
7676 end Process_Compile_Time_Warning_Or_Error;
7678 ------------------------
7679 -- Process_Convention --
7680 ------------------------
7682 procedure Process_Convention
7683 (C : out Convention_Id;
7684 Ent : out Entity_Id)
7688 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7689 -- Called if we have more than one Export/Import/Convention pragma.
7690 -- This is generally illegal, but we have a special case of allowing
7691 -- Import and Interface to coexist if they specify the convention in
7692 -- a consistent manner. We are allowed to do this, since Interface is
7693 -- an implementation defined pragma, and we choose to do it since we
7694 -- know Rational allows this combination. S is the entity id of the
7695 -- subprogram in question. This procedure also sets the special flag
7696 -- Import_Interface_Present in both pragmas in the case where we do
7697 -- have matching Import and Interface pragmas.
7699 procedure Set_Convention_From_Pragma (E : Entity_Id);
7700 -- Set convention in entity E, and also flag that the entity has a
7701 -- convention pragma. If entity is for a private or incomplete type,
7702 -- also set convention and flag on underlying type. This procedure
7703 -- also deals with the special case of C_Pass_By_Copy convention,
7704 -- and error checks for inappropriate convention specification.
7706 -------------------------------
7707 -- Diagnose_Multiple_Pragmas --
7708 -------------------------------
7710 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7711 Pdec : constant Node_Id := Declaration_Node (S);
7715 function Same_Convention (Decl : Node_Id) return Boolean;
7716 -- Decl is a pragma node. This function returns True if this
7717 -- pragma has a first argument that is an identifier with a
7718 -- Chars field corresponding to the Convention_Id C.
7720 function Same_Name (Decl : Node_Id) return Boolean;
7721 -- Decl is a pragma node. This function returns True if this
7722 -- pragma has a second argument that is an identifier with a
7723 -- Chars field that matches the Chars of the current subprogram.
7725 ---------------------
7726 -- Same_Convention --
7727 ---------------------
7729 function Same_Convention (Decl : Node_Id) return Boolean is
7730 Arg1 : constant Node_Id :=
7731 First (Pragma_Argument_Associations (Decl));
7734 if Present (Arg1) then
7736 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7738 if Nkind (Arg) = N_Identifier
7739 and then Is_Convention_Name (Chars (Arg))
7740 and then Get_Convention_Id (Chars (Arg)) = C
7748 end Same_Convention;
7754 function Same_Name (Decl : Node_Id) return Boolean is
7755 Arg1 : constant Node_Id :=
7756 First (Pragma_Argument_Associations (Decl));
7764 Arg2 := Next (Arg1);
7771 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7773 if Nkind (Arg) = N_Identifier
7774 and then Chars (Arg) = Chars (S)
7783 -- Start of processing for Diagnose_Multiple_Pragmas
7788 -- Definitely give message if we have Convention/Export here
7790 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7793 -- If we have an Import or Export, scan back from pragma to
7794 -- find any previous pragma applying to the same procedure.
7795 -- The scan will be terminated by the start of the list, or
7796 -- hitting the subprogram declaration. This won't allow one
7797 -- pragma to appear in the public part and one in the private
7798 -- part, but that seems very unlikely in practice.
7802 while Present (Decl) and then Decl /= Pdec loop
7804 -- Look for pragma with same name as us
7806 if Nkind (Decl) = N_Pragma
7807 and then Same_Name (Decl)
7809 -- Give error if same as our pragma or Export/Convention
7811 if Pragma_Name_Unmapped (Decl)
7814 | Pragma_Name_Unmapped (N)
7818 -- Case of Import/Interface or the other way round
7820 elsif Pragma_Name_Unmapped (Decl)
7821 in Name_Interface | Name_Import
7823 -- Here we know that we have Import and Interface. It
7824 -- doesn't matter which way round they are. See if
7825 -- they specify the same convention. If so, all OK,
7826 -- and set special flags to stop other messages
7828 if Same_Convention (Decl) then
7829 Set_Import_Interface_Present (N);
7830 Set_Import_Interface_Present (Decl);
7833 -- If different conventions, special message
7836 Error_Msg_Sloc := Sloc (Decl);
7838 ("convention differs from that given#", Arg1);
7848 -- Give message if needed if we fall through those tests
7849 -- except on Relaxed_RM_Semantics where we let go: either this
7850 -- is a case accepted/ignored by other Ada compilers (e.g.
7851 -- a mix of Convention and Import), or another error will be
7852 -- generated later (e.g. using both Import and Export).
7854 if Err and not Relaxed_RM_Semantics then
7856 ("at most one Convention/Export/Import pragma is allowed",
7859 end Diagnose_Multiple_Pragmas;
7861 --------------------------------
7862 -- Set_Convention_From_Pragma --
7863 --------------------------------
7865 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7867 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7868 -- for an overridden dispatching operation. Technically this is
7869 -- an amendment and should only be done in Ada 2005 mode. However,
7870 -- this is clearly a mistake, since the problem that is addressed
7871 -- by this AI is that there is a clear gap in the RM.
7873 if Is_Dispatching_Operation (E)
7874 and then Present (Overridden_Operation (E))
7875 and then C /= Convention (Overridden_Operation (E))
7878 ("cannot change convention for overridden dispatching "
7879 & "operation", Arg1);
7881 -- Special check for convention Stdcall: a dispatching call is not
7882 -- allowed. A dispatching subprogram cannot be used to interface
7883 -- to the Win32 API, so this check actually does not impose any
7884 -- effective restriction.
7886 elsif Is_Dispatching_Operation (E)
7887 and then C = Convention_Stdcall
7889 -- Note: make this unconditional so that if there is more
7890 -- than one call to which the pragma applies, we get a
7891 -- message for each call. Also don't use Error_Pragma,
7892 -- so that we get multiple messages.
7894 Error_Msg_Sloc := Sloc (E);
7896 ("dispatching subprogram# cannot use Stdcall convention!",
7897 Get_Pragma_Arg (Arg1));
7900 -- Set the convention
7902 Set_Convention (E, C);
7903 Set_Has_Convention_Pragma (E);
7905 -- For the case of a record base type, also set the convention of
7906 -- any anonymous access types declared in the record which do not
7907 -- currently have a specified convention.
7908 -- Similarly for an array base type and anonymous access types
7911 if Is_Base_Type (E) then
7912 if Is_Record_Type (E) then
7917 Comp := First_Component (E);
7918 while Present (Comp) loop
7919 if Present (Etype (Comp))
7921 Ekind (Etype (Comp)) in
7922 E_Anonymous_Access_Type |
7923 E_Anonymous_Access_Subprogram_Type
7924 and then not Has_Convention_Pragma (Comp)
7926 Set_Convention (Comp, C);
7929 Next_Component (Comp);
7933 elsif Is_Array_Type (E)
7934 and then Ekind (Component_Type (E)) in
7935 E_Anonymous_Access_Type |
7936 E_Anonymous_Access_Subprogram_Type
7938 Set_Convention (Designated_Type (Component_Type (E)), C);
7942 -- Deal with incomplete/private type case, where underlying type
7943 -- is available, so set convention of that underlying type.
7945 if Is_Incomplete_Or_Private_Type (E)
7946 and then Present (Underlying_Type (E))
7948 Set_Convention (Underlying_Type (E), C);
7949 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7952 -- A class-wide type should inherit the convention of the specific
7953 -- root type (although this isn't specified clearly by the RM).
7955 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7956 Set_Convention (Class_Wide_Type (E), C);
7959 -- If the entity is a record type, then check for special case of
7960 -- C_Pass_By_Copy, which is treated the same as C except that the
7961 -- special record flag is set. This convention is only permitted
7962 -- on record types (see AI95-00131).
7964 if Cname = Name_C_Pass_By_Copy then
7965 if Is_Record_Type (E) then
7966 Set_C_Pass_By_Copy (Base_Type (E));
7967 elsif Is_Incomplete_Or_Private_Type (E)
7968 and then Is_Record_Type (Underlying_Type (E))
7970 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7973 ("C_Pass_By_Copy convention allowed only for record type",
7978 -- If the entity is a derived boolean type, check for the special
7979 -- case of convention C, C++, or Fortran, where we consider any
7980 -- nonzero value to represent true.
7982 if Is_Discrete_Type (E)
7983 and then Root_Type (Etype (E)) = Standard_Boolean
7989 C = Convention_Fortran)
7991 Set_Nonzero_Is_True (Base_Type (E));
7993 end Set_Convention_From_Pragma;
7997 Comp_Unit : Unit_Number_Type;
8003 -- Start of processing for Process_Convention
8006 Check_At_Least_N_Arguments (2);
8007 Check_Optional_Identifier (Arg1, Name_Convention);
8008 Check_Arg_Is_Identifier (Arg1);
8009 Cname := Chars (Get_Pragma_Arg (Arg1));
8011 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8012 -- tested again below to set the critical flag).
8014 if Cname = Name_C_Pass_By_Copy then
8017 -- Otherwise we must have something in the standard convention list
8019 elsif Is_Convention_Name (Cname) then
8020 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8022 -- Otherwise warn on unrecognized convention
8025 if Warn_On_Export_Import then
8027 ("??unrecognized convention name, C assumed",
8028 Get_Pragma_Arg (Arg1));
8034 Check_Optional_Identifier (Arg2, Name_Entity);
8035 Check_Arg_Is_Local_Name (Arg2);
8037 Id := Get_Pragma_Arg (Arg2);
8040 if not Is_Entity_Name (Id) then
8041 Error_Pragma_Arg ("entity name required", Arg2);
8046 -- Set entity to return
8050 -- Ada_Pass_By_Copy special checking
8052 if C = Convention_Ada_Pass_By_Copy then
8053 if not Is_First_Subtype (E) then
8055 ("convention `Ada_Pass_By_Copy` only allowed for types",
8059 if Is_By_Reference_Type (E) then
8061 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8065 -- Ada_Pass_By_Reference special checking
8067 elsif C = Convention_Ada_Pass_By_Reference then
8068 if not Is_First_Subtype (E) then
8070 ("convention `Ada_Pass_By_Reference` only allowed for types",
8074 if Is_By_Copy_Type (E) then
8076 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8081 -- Go to renamed subprogram if present, since convention applies to
8082 -- the actual renamed entity, not to the renaming entity. If the
8083 -- subprogram is inherited, go to parent subprogram.
8085 if Is_Subprogram (E)
8086 and then Present (Alias (E))
8088 if Nkind (Parent (Declaration_Node (E))) =
8089 N_Subprogram_Renaming_Declaration
8091 if Scope (E) /= Scope (Alias (E)) then
8093 ("cannot apply pragma% to non-local entity&#", E);
8098 elsif Nkind (Parent (E)) in
8099 N_Full_Type_Declaration | N_Private_Extension_Declaration
8100 and then Scope (E) = Scope (Alias (E))
8104 -- Return the parent subprogram the entity was inherited from
8110 -- Check that we are not applying this to a specless body. Relax this
8111 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8113 if Is_Subprogram (E)
8114 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8115 and then not Relaxed_RM_Semantics
8118 ("pragma% requires separate spec and must come before body");
8121 -- Check that we are not applying this to a named constant
8123 if Is_Named_Number (E) then
8124 Error_Msg_Name_1 := Pname;
8126 ("cannot apply pragma% to named constant!",
8127 Get_Pragma_Arg (Arg2));
8129 ("\supply appropriate type for&!", Arg2);
8132 if Ekind (E) = E_Enumeration_Literal then
8133 Error_Pragma ("enumeration literal not allowed for pragma%");
8136 -- Check for rep item appearing too early or too late
8138 if Etype (E) = Any_Type
8139 or else Rep_Item_Too_Early (E, N)
8143 elsif Present (Underlying_Type (E)) then
8144 E := Underlying_Type (E);
8147 if Rep_Item_Too_Late (E, N) then
8151 if Has_Convention_Pragma (E) then
8152 Diagnose_Multiple_Pragmas (E);
8154 elsif Convention (E) = Convention_Protected
8155 or else Ekind (Scope (E)) = E_Protected_Type
8158 ("a protected operation cannot be given a different convention",
8162 -- For Intrinsic, a subprogram is required
8164 if C = Convention_Intrinsic
8165 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8167 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8169 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8170 if From_Aspect_Specification (N) then
8172 ("entity for aspect% must be a subprogram", Arg2);
8175 ("second argument of pragma% must be a subprogram", Arg2);
8179 -- Special checks for C_Variadic_n
8181 elsif C in Convention_C_Variadic then
8183 -- Several allowed cases
8185 if Is_Subprogram_Or_Generic_Subprogram (E) then
8188 -- An access to subprogram is also allowed
8190 elsif Is_Access_Type (E)
8191 and then Ekind (Designated_Type (E)) = E_Subprogram_Type
8193 Subp := Designated_Type (E);
8195 -- Allow internal call to set convention of subprogram type
8197 elsif Ekind (E) = E_Subprogram_Type then
8202 ("argument of pragma% must be subprogram or access type",
8207 -- ISO C requires a named parameter before the ellipsis, so a
8208 -- variadic C function taking 0 fixed parameter cannot exist.
8210 if C = Convention_C_Variadic_0 then
8213 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8214 Get_Pragma_Arg (Arg2));
8216 -- Now check the number of parameters of the subprogram and give
8217 -- an error if it is lower than n.
8219 elsif Present (Subp) then
8221 Minimum : constant Nat :=
8222 Convention_Id'Pos (C) -
8223 Convention_Id'Pos (Convention_C_Variadic_0);
8230 Formal := First_Formal (Subp);
8231 while Present (Formal) loop
8233 Next_Formal (Formal);
8236 if Count < Minimum then
8237 Error_Msg_Uint_1 := UI_From_Int (Minimum);
8239 ("argument of pragma% must have at least"
8240 & "^ parameters", Arg2);
8245 -- Special checks for Stdcall
8247 elsif C = Convention_Stdcall then
8249 -- Several allowed cases
8251 if Is_Subprogram_Or_Generic_Subprogram (E)
8255 or else Ekind (E) = E_Variable
8257 -- A component as well. The entity does not have its Ekind
8258 -- set until the enclosing record declaration is fully
8261 or else Nkind (Parent (E)) = N_Component_Declaration
8263 -- An access to subprogram is also allowed
8267 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
8269 -- Allow internal call to set convention of subprogram type
8271 or else Ekind (E) = E_Subprogram_Type
8277 ("argument of pragma% must be subprogram or access type",
8282 Set_Convention_From_Pragma (E);
8284 -- Deal with non-subprogram cases
8286 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8289 -- The pragma must apply to a first subtype, but it can also
8290 -- apply to a generic type in a generic formal part, in which
8291 -- case it will also appear in the corresponding instance.
8293 if Is_Generic_Type (E) or else In_Instance then
8296 Check_First_Subtype (Arg2);
8299 Set_Convention_From_Pragma (Base_Type (E));
8301 -- For access subprograms, we must set the convention on the
8302 -- internally generated directly designated type as well.
8304 if Ekind (E) = E_Access_Subprogram_Type then
8305 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8309 -- For the subprogram case, set proper convention for all homonyms
8310 -- in same scope and the same declarative part, i.e. the same
8311 -- compilation unit.
8314 -- Treat a pragma Import as an implicit body, and pragma import
8315 -- as implicit reference (for navigation in GNAT Studio).
8317 if Prag_Id = Pragma_Import then
8318 Generate_Reference (E, Id, 'b');
8320 -- For exported entities we restrict the generation of references
8321 -- to entities exported to foreign languages since entities
8322 -- exported to Ada do not provide further information to
8323 -- GNAT Studio and add undesired references to the output of the
8326 elsif Prag_Id = Pragma_Export
8327 and then Convention (E) /= Convention_Ada
8329 Generate_Reference (E, Id, 'i');
8332 -- If the pragma comes from an aspect, it only applies to the
8333 -- given entity, not its homonyms.
8335 if From_Aspect_Specification (N) then
8336 if C = Convention_Intrinsic
8337 and then Nkind (Ent) = N_Defining_Operator_Symbol
8339 if Is_Fixed_Point_Type (Etype (Ent))
8340 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8341 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8344 ("no intrinsic operator available for this fixed-point "
8347 ("\use expression functions with the desired "
8348 & "conversions made explicit", N);
8355 -- Otherwise Loop through the homonyms of the pragma argument's
8356 -- entity, an apply convention to those in the current scope.
8358 Comp_Unit := Get_Source_Unit (E);
8363 exit when No (E1) or else Scope (E1) /= Current_Scope;
8365 -- Ignore entry for which convention is already set
8367 if Has_Convention_Pragma (E1) then
8371 if Is_Subprogram (E1)
8372 and then Nkind (Parent (Declaration_Node (E1))) =
8374 and then not Relaxed_RM_Semantics
8376 Set_Has_Completion (E); -- to prevent cascaded error
8378 ("pragma% requires separate spec and must come before "
8382 -- Do not set the pragma on inherited operations or on formal
8385 if Comes_From_Source (E1)
8386 and then Comp_Unit = Get_Source_Unit (E1)
8387 and then not Is_Formal_Subprogram (E1)
8388 and then Nkind (Original_Node (Parent (E1))) /=
8389 N_Full_Type_Declaration
8391 if Present (Alias (E1))
8392 and then Scope (E1) /= Scope (Alias (E1))
8395 ("cannot apply pragma% to non-local entity& declared#",
8399 Set_Convention_From_Pragma (E1);
8401 if Prag_Id = Pragma_Import then
8402 Generate_Reference (E1, Id, 'b');
8410 end Process_Convention;
8412 ----------------------------------------
8413 -- Process_Disable_Enable_Atomic_Sync --
8414 ----------------------------------------
8416 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8418 Check_No_Identifiers;
8419 Check_At_Most_N_Arguments (1);
8421 -- Modeled internally as
8422 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8427 Pragma_Argument_Associations => New_List (
8428 Make_Pragma_Argument_Association (Loc,
8430 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8432 if Present (Arg1) then
8433 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8437 end Process_Disable_Enable_Atomic_Sync;
8439 -------------------------------------------------
8440 -- Process_Extended_Import_Export_Internal_Arg --
8441 -------------------------------------------------
8443 procedure Process_Extended_Import_Export_Internal_Arg
8444 (Arg_Internal : Node_Id := Empty)
8447 if No (Arg_Internal) then
8448 Error_Pragma ("Internal parameter required for pragma%");
8451 if Nkind (Arg_Internal) = N_Identifier then
8454 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8455 and then (Prag_Id = Pragma_Import_Function
8457 Prag_Id = Pragma_Export_Function)
8463 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8466 Check_Arg_Is_Local_Name (Arg_Internal);
8467 end Process_Extended_Import_Export_Internal_Arg;
8469 --------------------------------------------------
8470 -- Process_Extended_Import_Export_Object_Pragma --
8471 --------------------------------------------------
8473 procedure Process_Extended_Import_Export_Object_Pragma
8474 (Arg_Internal : Node_Id;
8475 Arg_External : Node_Id;
8481 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8482 Def_Id := Entity (Arg_Internal);
8484 if Ekind (Def_Id) not in E_Constant | E_Variable then
8486 ("pragma% must designate an object", Arg_Internal);
8489 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8491 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8494 ("previous Common/Psect_Object applies, pragma % not permitted",
8498 if Rep_Item_Too_Late (Def_Id, N) then
8502 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8504 if Present (Arg_Size) then
8505 Check_Arg_Is_External_Name (Arg_Size);
8508 -- Export_Object case
8510 if Prag_Id = Pragma_Export_Object then
8511 if not Is_Library_Level_Entity (Def_Id) then
8513 ("argument for pragma% must be library level entity",
8517 if Ekind (Current_Scope) = E_Generic_Package then
8518 Error_Pragma ("pragma& cannot appear in a generic unit");
8521 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8523 ("exported object must have compile time known size",
8527 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8528 Error_Msg_N ("??duplicate Export_Object pragma", N);
8530 Set_Exported (Def_Id, Arg_Internal);
8533 -- Import_Object case
8536 if Is_Concurrent_Type (Etype (Def_Id)) then
8538 ("cannot use pragma% for task/protected object",
8542 if Ekind (Def_Id) = E_Constant then
8544 ("cannot import a constant", Arg_Internal);
8547 if Warn_On_Export_Import
8548 and then Has_Discriminants (Etype (Def_Id))
8551 ("imported value must be initialized??", Arg_Internal);
8554 if Warn_On_Export_Import
8555 and then Is_Access_Type (Etype (Def_Id))
8558 ("cannot import object of an access type??", Arg_Internal);
8561 if Warn_On_Export_Import
8562 and then Is_Imported (Def_Id)
8564 Error_Msg_N ("??duplicate Import_Object pragma", N);
8566 -- Check for explicit initialization present. Note that an
8567 -- initialization generated by the code generator, e.g. for an
8568 -- access type, does not count here.
8570 elsif Present (Expression (Parent (Def_Id)))
8573 (Original_Node (Expression (Parent (Def_Id))))
8575 Error_Msg_Sloc := Sloc (Def_Id);
8577 ("imported entities cannot be initialized (RM B.1(24))",
8578 "\no initialization allowed for & declared#", Arg1);
8580 Set_Imported (Def_Id);
8581 Note_Possible_Modification (Arg_Internal, Sure => False);
8584 end Process_Extended_Import_Export_Object_Pragma;
8586 ------------------------------------------------------
8587 -- Process_Extended_Import_Export_Subprogram_Pragma --
8588 ------------------------------------------------------
8590 procedure Process_Extended_Import_Export_Subprogram_Pragma
8591 (Arg_Internal : Node_Id;
8592 Arg_External : Node_Id;
8593 Arg_Parameter_Types : Node_Id;
8594 Arg_Result_Type : Node_Id := Empty;
8595 Arg_Mechanism : Node_Id;
8596 Arg_Result_Mechanism : Node_Id := Empty)
8602 Ambiguous : Boolean;
8605 function Same_Base_Type
8607 Formal : Entity_Id) return Boolean;
8608 -- Determines if Ptype references the type of Formal. Note that only
8609 -- the base types need to match according to the spec. Ptype here is
8610 -- the argument from the pragma, which is either a type name, or an
8611 -- access attribute.
8613 --------------------
8614 -- Same_Base_Type --
8615 --------------------
8617 function Same_Base_Type
8619 Formal : Entity_Id) return Boolean
8621 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8625 -- Case where pragma argument is typ'Access
8627 if Nkind (Ptype) = N_Attribute_Reference
8628 and then Attribute_Name (Ptype) = Name_Access
8630 Pref := Prefix (Ptype);
8633 if not Is_Entity_Name (Pref)
8634 or else Entity (Pref) = Any_Type
8639 -- We have a match if the corresponding argument is of an
8640 -- anonymous access type, and its designated type matches the
8641 -- type of the prefix of the access attribute
8643 return Ekind (Ftyp) = E_Anonymous_Access_Type
8644 and then Base_Type (Entity (Pref)) =
8645 Base_Type (Etype (Designated_Type (Ftyp)));
8647 -- Case where pragma argument is a type name
8652 if not Is_Entity_Name (Ptype)
8653 or else Entity (Ptype) = Any_Type
8658 -- We have a match if the corresponding argument is of the type
8659 -- given in the pragma (comparing base types)
8661 return Base_Type (Entity (Ptype)) = Ftyp;
8665 -- Start of processing for
8666 -- Process_Extended_Import_Export_Subprogram_Pragma
8669 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8673 -- Loop through homonyms (overloadings) of the entity
8675 Hom_Id := Entity (Arg_Internal);
8676 while Present (Hom_Id) loop
8677 Def_Id := Get_Base_Subprogram (Hom_Id);
8679 -- We need a subprogram in the current scope
8681 if not Is_Subprogram (Def_Id)
8682 or else Scope (Def_Id) /= Current_Scope
8689 -- Pragma cannot apply to subprogram body
8691 if Is_Subprogram (Def_Id)
8692 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8696 ("pragma% requires separate spec and must come before "
8700 -- Test result type if given, note that the result type
8701 -- parameter can only be present for the function cases.
8703 if Present (Arg_Result_Type)
8704 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8708 elsif Etype (Def_Id) /= Standard_Void_Type
8710 Pname in Name_Export_Procedure | Name_Import_Procedure
8714 -- Test parameter types if given. Note that this parameter has
8715 -- not been analyzed (and must not be, since it is semantic
8716 -- nonsense), so we get it as the parser left it.
8718 elsif Present (Arg_Parameter_Types) then
8719 Check_Matching_Types : declare
8724 Formal := First_Formal (Def_Id);
8726 if Nkind (Arg_Parameter_Types) = N_Null then
8727 if Present (Formal) then
8731 -- A list of one type, e.g. (List) is parsed as a
8732 -- parenthesized expression.
8734 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8735 and then Paren_Count (Arg_Parameter_Types) = 1
8738 or else Present (Next_Formal (Formal))
8743 Same_Base_Type (Arg_Parameter_Types, Formal);
8746 -- A list of more than one type is parsed as a aggregate
8748 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8749 and then Paren_Count (Arg_Parameter_Types) = 0
8751 Ptype := First (Expressions (Arg_Parameter_Types));
8752 while Present (Ptype) or else Present (Formal) loop
8755 or else not Same_Base_Type (Ptype, Formal)
8760 Next_Formal (Formal);
8765 -- Anything else is of the wrong form
8769 ("wrong form for Parameter_Types parameter",
8770 Arg_Parameter_Types);
8772 end Check_Matching_Types;
8775 -- Match is now False if the entry we found did not match
8776 -- either a supplied Parameter_Types or Result_Types argument
8782 -- Ambiguous case, the flag Ambiguous shows if we already
8783 -- detected this and output the initial messages.
8786 if not Ambiguous then
8788 Error_Msg_Name_1 := Pname;
8790 ("pragma% does not uniquely identify subprogram!",
8792 Error_Msg_Sloc := Sloc (Ent);
8793 Error_Msg_N ("matching subprogram #!", N);
8797 Error_Msg_Sloc := Sloc (Def_Id);
8798 Error_Msg_N ("matching subprogram #!", N);
8803 Hom_Id := Homonym (Hom_Id);
8806 -- See if we found an entry
8809 if not Ambiguous then
8810 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8812 ("pragma% cannot be given for generic subprogram");
8815 ("pragma% does not identify local subprogram");
8822 -- Import pragmas must be for imported entities
8824 if Prag_Id = Pragma_Import_Function
8826 Prag_Id = Pragma_Import_Procedure
8828 Prag_Id = Pragma_Import_Valued_Procedure
8830 if not Is_Imported (Ent) then
8832 ("pragma Import or Interface must precede pragma%");
8835 -- Here we have the Export case which can set the entity as exported
8837 -- But does not do so if the specified external name is null, since
8838 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8839 -- compatible) to request no external name.
8841 elsif Nkind (Arg_External) = N_String_Literal
8842 and then String_Length (Strval (Arg_External)) = 0
8846 -- In all other cases, set entity as exported
8849 Set_Exported (Ent, Arg_Internal);
8852 -- Special processing for Valued_Procedure cases
8854 if Prag_Id = Pragma_Import_Valued_Procedure
8856 Prag_Id = Pragma_Export_Valued_Procedure
8858 Formal := First_Formal (Ent);
8861 Error_Pragma ("at least one parameter required for pragma%");
8863 elsif Ekind (Formal) /= E_Out_Parameter then
8864 Error_Pragma ("first parameter must have mode out for pragma%");
8867 Set_Is_Valued_Procedure (Ent);
8871 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8873 -- Process Result_Mechanism argument if present. We have already
8874 -- checked that this is only allowed for the function case.
8876 if Present (Arg_Result_Mechanism) then
8877 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8880 -- Process Mechanism parameter if present. Note that this parameter
8881 -- is not analyzed, and must not be analyzed since it is semantic
8882 -- nonsense, so we get it in exactly as the parser left it.
8884 if Present (Arg_Mechanism) then
8892 -- A single mechanism association without a formal parameter
8893 -- name is parsed as a parenthesized expression. All other
8894 -- cases are parsed as aggregates, so we rewrite the single
8895 -- parameter case as an aggregate for consistency.
8897 if Nkind (Arg_Mechanism) /= N_Aggregate
8898 and then Paren_Count (Arg_Mechanism) = 1
8900 Rewrite (Arg_Mechanism,
8901 Make_Aggregate (Sloc (Arg_Mechanism),
8902 Expressions => New_List (
8903 Relocate_Node (Arg_Mechanism))));
8906 -- Case of only mechanism name given, applies to all formals
8908 if Nkind (Arg_Mechanism) /= N_Aggregate then
8909 Formal := First_Formal (Ent);
8910 while Present (Formal) loop
8911 Set_Mechanism_Value (Formal, Arg_Mechanism);
8912 Next_Formal (Formal);
8915 -- Case of list of mechanism associations given
8918 if Null_Record_Present (Arg_Mechanism) then
8920 ("inappropriate form for Mechanism parameter",
8924 -- Deal with positional ones first
8926 Formal := First_Formal (Ent);
8928 if Present (Expressions (Arg_Mechanism)) then
8929 Mname := First (Expressions (Arg_Mechanism));
8930 while Present (Mname) loop
8933 ("too many mechanism associations", Mname);
8936 Set_Mechanism_Value (Formal, Mname);
8937 Next_Formal (Formal);
8942 -- Deal with named entries
8944 if Present (Component_Associations (Arg_Mechanism)) then
8945 Massoc := First (Component_Associations (Arg_Mechanism));
8946 while Present (Massoc) loop
8947 Choice := First (Choices (Massoc));
8949 if Nkind (Choice) /= N_Identifier
8950 or else Present (Next (Choice))
8953 ("incorrect form for mechanism association",
8957 Formal := First_Formal (Ent);
8961 ("parameter name & not present", Choice);
8964 if Chars (Choice) = Chars (Formal) then
8966 (Formal, Expression (Massoc));
8968 -- Set entity on identifier for proper tree
8971 Set_Entity (Choice, Formal);
8976 Next_Formal (Formal);
8985 end Process_Extended_Import_Export_Subprogram_Pragma;
8987 --------------------------
8988 -- Process_Generic_List --
8989 --------------------------
8991 procedure Process_Generic_List is
8996 Check_No_Identifiers;
8997 Check_At_Least_N_Arguments (1);
8999 -- Check all arguments are names of generic units or instances
9002 while Present (Arg) loop
9003 Exp := Get_Pragma_Arg (Arg);
9006 if not Is_Entity_Name (Exp)
9008 (not Is_Generic_Instance (Entity (Exp))
9010 not Is_Generic_Unit (Entity (Exp)))
9013 ("pragma% argument must be name of generic unit/instance",
9019 end Process_Generic_List;
9021 ------------------------------------
9022 -- Process_Import_Predefined_Type --
9023 ------------------------------------
9025 procedure Process_Import_Predefined_Type is
9026 Loc : constant Source_Ptr := Sloc (N);
9028 Ftyp : Node_Id := Empty;
9034 Nam := String_To_Name (Strval (Expression (Arg3)));
9036 Elmt := First_Elmt (Predefined_Float_Types);
9037 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
9041 Ftyp := Node (Elmt);
9043 if Present (Ftyp) then
9045 -- Don't build a derived type declaration, because predefined C
9046 -- types have no declaration anywhere, so cannot really be named.
9047 -- Instead build a full type declaration, starting with an
9048 -- appropriate type definition is built
9050 if Is_Floating_Point_Type (Ftyp) then
9051 Def := Make_Floating_Point_Definition (Loc,
9052 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
9053 Make_Real_Range_Specification (Loc,
9054 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
9055 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
9057 -- Should never have a predefined type we cannot handle
9060 raise Program_Error;
9063 -- Build and insert a Full_Type_Declaration, which will be
9064 -- analyzed as soon as this list entry has been analyzed.
9066 Decl := Make_Full_Type_Declaration (Loc,
9067 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
9068 Type_Definition => Def);
9070 Insert_After (N, Decl);
9071 Mark_Rewrite_Insertion (Decl);
9074 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
9076 end Process_Import_Predefined_Type;
9078 ---------------------------------
9079 -- Process_Import_Or_Interface --
9080 ---------------------------------
9082 procedure Process_Import_Or_Interface is
9088 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9089 -- pragma Import (Entity, "external name");
9091 if Relaxed_RM_Semantics
9092 and then Arg_Count = 2
9093 and then Prag_Id = Pragma_Import
9094 and then Nkind (Expression (Arg2)) = N_String_Literal
9097 Def_Id := Get_Pragma_Arg (Arg1);
9100 if not Is_Entity_Name (Def_Id) then
9101 Error_Pragma_Arg ("entity name required", Arg1);
9104 Def_Id := Entity (Def_Id);
9105 Kill_Size_Check_Code (Def_Id);
9106 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9109 Process_Convention (C, Def_Id);
9111 -- A pragma that applies to a Ghost entity becomes Ghost for the
9112 -- purposes of legality checks and removal of ignored Ghost code.
9114 Mark_Ghost_Pragma (N, Def_Id);
9115 Kill_Size_Check_Code (Def_Id);
9116 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9119 -- Various error checks
9121 if Ekind (Def_Id) in E_Variable | E_Constant then
9123 -- We do not permit Import to apply to a renaming declaration
9125 if Present (Renamed_Object (Def_Id)) then
9127 ("pragma% not allowed for object renaming", Arg2);
9129 -- User initialization is not allowed for imported object, but
9130 -- the object declaration may contain a default initialization,
9131 -- that will be discarded. Note that an explicit initialization
9132 -- only counts if it comes from source, otherwise it is simply
9133 -- the code generator making an implicit initialization explicit.
9135 elsif Present (Expression (Parent (Def_Id)))
9136 and then Comes_From_Source
9137 (Original_Node (Expression (Parent (Def_Id))))
9139 -- Set imported flag to prevent cascaded errors
9141 Set_Is_Imported (Def_Id);
9143 Error_Msg_Sloc := Sloc (Def_Id);
9145 ("no initialization allowed for declaration of& #",
9146 "\imported entities cannot be initialized (RM B.1(24))",
9150 -- If the pragma comes from an aspect specification the
9151 -- Is_Imported flag has already been set.
9153 if not From_Aspect_Specification (N) then
9154 Set_Imported (Def_Id);
9157 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9159 -- Note that we do not set Is_Public here. That's because we
9160 -- only want to set it if there is no address clause, and we
9161 -- don't know that yet, so we delay that processing till
9164 -- pragma Import completes deferred constants
9166 if Ekind (Def_Id) = E_Constant then
9167 Set_Has_Completion (Def_Id);
9170 -- It is not possible to import a constant of an unconstrained
9171 -- array type (e.g. string) because there is no simple way to
9172 -- write a meaningful subtype for it.
9174 if Is_Array_Type (Etype (Def_Id))
9175 and then not Is_Constrained (Etype (Def_Id))
9178 ("imported constant& must have a constrained subtype",
9183 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9185 -- If the name is overloaded, pragma applies to all of the denoted
9186 -- entities in the same declarative part, unless the pragma comes
9187 -- from an aspect specification or was generated by the compiler
9188 -- (such as for pragma Provide_Shift_Operators).
9191 while Present (Hom_Id) loop
9193 Def_Id := Get_Base_Subprogram (Hom_Id);
9195 -- Ignore inherited subprograms because the pragma will apply
9196 -- to the parent operation, which is the one called.
9198 if Is_Overloadable (Def_Id)
9199 and then Present (Alias (Def_Id))
9203 -- If it is not a subprogram, it must be in an outer scope and
9204 -- pragma does not apply.
9206 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9209 -- The pragma does not apply to primitives of interfaces
9211 elsif Is_Dispatching_Operation (Def_Id)
9212 and then Present (Find_Dispatching_Type (Def_Id))
9213 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9217 -- Verify that the homonym is in the same declarative part (not
9218 -- just the same scope). If the pragma comes from an aspect
9219 -- specification we know that it is part of the declaration.
9221 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9222 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9223 and then not From_Aspect_Specification (N)
9228 -- If the pragma comes from an aspect specification the
9229 -- Is_Imported flag has already been set.
9231 if not From_Aspect_Specification (N) then
9232 Set_Imported (Def_Id);
9235 -- Reject an Import applied to an abstract subprogram
9237 if Is_Subprogram (Def_Id)
9238 and then Is_Abstract_Subprogram (Def_Id)
9240 Error_Msg_Sloc := Sloc (Def_Id);
9242 ("cannot import abstract subprogram& declared#",
9246 -- Special processing for Convention_Intrinsic
9248 if C = Convention_Intrinsic then
9250 -- Link_Name argument not allowed for intrinsic
9254 Set_Is_Intrinsic_Subprogram (Def_Id);
9256 -- If no external name is present, then check that this
9257 -- is a valid intrinsic subprogram. If an external name
9258 -- is present, then this is handled by the back end.
9261 Check_Intrinsic_Subprogram
9262 (Def_Id, Get_Pragma_Arg (Arg2));
9266 -- Verify that the subprogram does not have a completion
9267 -- through a renaming declaration. For other completions the
9268 -- pragma appears as a too late representation.
9271 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9275 and then Nkind (Decl) = N_Subprogram_Declaration
9276 and then Present (Corresponding_Body (Decl))
9277 and then Nkind (Unit_Declaration_Node
9278 (Corresponding_Body (Decl))) =
9279 N_Subprogram_Renaming_Declaration
9281 Error_Msg_Sloc := Sloc (Def_Id);
9283 ("cannot import&, renaming already provided for "
9284 & "declaration #", N, Def_Id);
9288 -- If the pragma comes from an aspect specification, there
9289 -- must be an Import aspect specified as well. In the rare
9290 -- case where Import is set to False, the suprogram needs to
9291 -- have a local completion.
9294 Imp_Aspect : constant Node_Id :=
9295 Find_Aspect (Def_Id, Aspect_Import);
9299 if Present (Imp_Aspect)
9300 and then Present (Expression (Imp_Aspect))
9302 Expr := Expression (Imp_Aspect);
9303 Analyze_And_Resolve (Expr, Standard_Boolean);
9305 if Is_Entity_Name (Expr)
9306 and then Entity (Expr) = Standard_True
9308 Set_Has_Completion (Def_Id);
9311 -- If there is no expression, the default is True, as for
9312 -- all boolean aspects. Same for the older pragma.
9315 Set_Has_Completion (Def_Id);
9319 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9322 if Is_Compilation_Unit (Hom_Id) then
9324 -- Its possible homonyms are not affected by the pragma.
9325 -- Such homonyms might be present in the context of other
9326 -- units being compiled.
9330 elsif From_Aspect_Specification (N) then
9333 -- If the pragma was created by the compiler, then we don't
9334 -- want it to apply to other homonyms. This kind of case can
9335 -- occur when using pragma Provide_Shift_Operators, which
9336 -- generates implicit shift and rotate operators with Import
9337 -- pragmas that might apply to earlier explicit or implicit
9338 -- declarations marked with Import (for example, coming from
9339 -- an earlier pragma Provide_Shift_Operators for another type),
9340 -- and we don't generally want other homonyms being treated
9341 -- as imported or the pragma flagged as an illegal duplicate.
9343 elsif not Comes_From_Source (N) then
9347 Hom_Id := Homonym (Hom_Id);
9351 -- Import a CPP class
9353 elsif C = Convention_CPP
9354 and then (Is_Record_Type (Def_Id)
9355 or else Ekind (Def_Id) = E_Incomplete_Type)
9357 if Ekind (Def_Id) = E_Incomplete_Type then
9358 if Present (Full_View (Def_Id)) then
9359 Def_Id := Full_View (Def_Id);
9363 ("cannot import 'C'P'P type before full declaration seen",
9364 Get_Pragma_Arg (Arg2));
9366 -- Although we have reported the error we decorate it as
9367 -- CPP_Class to avoid reporting spurious errors
9369 Set_Is_CPP_Class (Def_Id);
9374 -- Types treated as CPP classes must be declared limited (note:
9375 -- this used to be a warning but there is no real benefit to it
9376 -- since we did effectively intend to treat the type as limited
9379 if not Is_Limited_Type (Def_Id) then
9381 ("imported 'C'P'P type must be limited",
9382 Get_Pragma_Arg (Arg2));
9385 if Etype (Def_Id) /= Def_Id
9386 and then not Is_CPP_Class (Root_Type (Def_Id))
9388 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9391 Set_Is_CPP_Class (Def_Id);
9393 -- Imported CPP types must not have discriminants (because C++
9394 -- classes do not have discriminants).
9396 if Has_Discriminants (Def_Id) then
9398 ("imported 'C'P'P type cannot have discriminants",
9399 First (Discriminant_Specifications
9400 (Declaration_Node (Def_Id))));
9403 -- Check that components of imported CPP types do not have default
9404 -- expressions. For private types this check is performed when the
9405 -- full view is analyzed (see Process_Full_View).
9407 if not Is_Private_Type (Def_Id) then
9408 Check_CPP_Type_Has_No_Defaults (Def_Id);
9411 -- Import a CPP exception
9413 elsif C = Convention_CPP
9414 and then Ekind (Def_Id) = E_Exception
9418 ("'External_'Name arguments is required for 'Cpp exception",
9421 -- As only a string is allowed, Check_Arg_Is_External_Name
9424 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9427 if Present (Arg4) then
9429 ("Link_Name argument not allowed for imported Cpp exception",
9433 -- Do not call Set_Interface_Name as the name of the exception
9434 -- shouldn't be modified (and in particular it shouldn't be
9435 -- the External_Name). For exceptions, the External_Name is the
9436 -- name of the RTTI structure.
9438 -- ??? Emit an error if pragma Import/Export_Exception is present
9440 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9442 Check_Arg_Count (3);
9443 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9445 Process_Import_Predefined_Type;
9448 if From_Aspect_Specification (N) then
9450 ("entity for aspect% must be object, subprogram "
9451 & "or incomplete type",
9455 ("second argument of pragma% must be object, subprogram "
9456 & "or incomplete type",
9461 -- If this pragma applies to a compilation unit, then the unit, which
9462 -- is a subprogram, does not require (or allow) a body. We also do
9463 -- not need to elaborate imported procedures.
9465 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9467 Cunit : constant Node_Id := Parent (Parent (N));
9469 Set_Body_Required (Cunit, False);
9472 end Process_Import_Or_Interface;
9474 --------------------
9475 -- Process_Inline --
9476 --------------------
9478 procedure Process_Inline (Status : Inline_Status) is
9485 Ghost_Error_Posted : Boolean := False;
9486 -- Flag set when an error concerning the illegal mix of Ghost and
9487 -- non-Ghost subprograms is emitted.
9489 Ghost_Id : Entity_Id := Empty;
9490 -- The entity of the first Ghost subprogram encountered while
9491 -- processing the arguments of the pragma.
9493 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9494 -- Verify the placement of pragma Inline_Always with respect to the
9495 -- initial declaration of subprogram Spec_Id.
9497 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9498 -- Returns True if it can be determined at this stage that inlining
9499 -- is not possible, for example if the body is available and contains
9500 -- exception handlers, we prevent inlining, since otherwise we can
9501 -- get undefined symbols at link time. This function also emits a
9502 -- warning if the pragma appears too late.
9504 -- ??? is business with link symbols still valid, or does it relate
9505 -- to front end ZCX which is being phased out ???
9507 procedure Make_Inline (Subp : Entity_Id);
9508 -- Subp is the defining unit name of the subprogram declaration. If
9509 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9510 -- the corresponding body, if there is one present.
9512 procedure Set_Inline_Flags (Subp : Entity_Id);
9513 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9514 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9516 -----------------------------------
9517 -- Check_Inline_Always_Placement --
9518 -----------------------------------
9520 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9521 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9523 function Compilation_Unit_OK return Boolean;
9524 pragma Inline (Compilation_Unit_OK);
9525 -- Determine whether pragma Inline_Always applies to a compatible
9526 -- compilation unit denoted by Spec_Id.
9528 function Declarative_List_OK return Boolean;
9529 pragma Inline (Declarative_List_OK);
9530 -- Determine whether the initial declaration of subprogram Spec_Id
9531 -- and the pragma appear in compatible declarative lists.
9533 function Subprogram_Body_OK return Boolean;
9534 pragma Inline (Subprogram_Body_OK);
9535 -- Determine whether pragma Inline_Always applies to a compatible
9536 -- subprogram body denoted by Spec_Id.
9538 -------------------------
9539 -- Compilation_Unit_OK --
9540 -------------------------
9542 function Compilation_Unit_OK return Boolean is
9543 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9546 -- The pragma appears after the initial declaration of a
9547 -- compilation unit.
9549 -- procedure Comp_Unit;
9550 -- pragma Inline_Always (Comp_Unit);
9552 -- Note that for compatibility reasons, the following case is
9555 -- procedure Stand_Alone_Body_Comp_Unit is
9557 -- end Stand_Alone_Body_Comp_Unit;
9558 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9561 Nkind (Comp_Unit) = N_Compilation_Unit
9562 and then Present (Aux_Decls_Node (Comp_Unit))
9563 and then Is_List_Member (N)
9564 and then List_Containing (N) =
9565 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9566 end Compilation_Unit_OK;
9568 -------------------------
9569 -- Declarative_List_OK --
9570 -------------------------
9572 function Declarative_List_OK return Boolean is
9573 Context : constant Node_Id := Parent (Spec_Decl);
9575 Init_Decl : Node_Id;
9576 Init_List : List_Id;
9577 Prag_List : List_Id;
9580 -- Determine the proper initial declaration. In general this is
9581 -- the declaration node of the subprogram except when the input
9582 -- denotes a generic instantiation.
9584 -- procedure Inst is new Gen;
9585 -- pragma Inline_Always (Inst);
9587 -- In this case the original subprogram is moved inside an
9588 -- anonymous package while pragma Inline_Always remains at the
9589 -- level of the anonymous package. Use the declaration of the
9590 -- package because it reflects the placement of the original
9593 -- package Anon_Pack is
9594 -- procedure Inst is ... end Inst; -- original
9597 -- procedure Inst renames Anon_Pack.Inst;
9598 -- pragma Inline_Always (Inst);
9600 if Is_Generic_Instance (Spec_Id) then
9601 Init_Decl := Parent (Parent (Spec_Decl));
9602 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9604 Init_Decl := Spec_Decl;
9607 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9608 Init_List := List_Containing (Init_Decl);
9609 Prag_List := List_Containing (N);
9611 -- The pragma and then initial declaration appear within the
9612 -- same declarative list.
9614 if Init_List = Prag_List then
9617 -- A special case of the above is when both the pragma and
9618 -- the initial declaration appear in different lists of a
9619 -- package spec, protected definition, or a task definition.
9624 -- pragma Inline_Always (Proc);
9627 elsif Nkind (Context) in N_Package_Specification
9628 | N_Protected_Definition
9630 and then Init_List = Visible_Declarations (Context)
9631 and then Prag_List = Private_Declarations (Context)
9638 end Declarative_List_OK;
9640 ------------------------
9641 -- Subprogram_Body_OK --
9642 ------------------------
9644 function Subprogram_Body_OK return Boolean is
9645 Body_Decl : Node_Id;
9648 -- The pragma appears within the declarative list of a stand-
9649 -- alone subprogram body.
9651 -- procedure Stand_Alone_Body is
9652 -- pragma Inline_Always (Stand_Alone_Body);
9655 -- end Stand_Alone_Body;
9657 -- The compiler creates a dummy spec in this case, however the
9658 -- pragma remains within the declarative list of the body.
9660 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9661 and then not Comes_From_Source (Spec_Decl)
9662 and then Present (Corresponding_Body (Spec_Decl))
9665 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9667 if Present (Declarations (Body_Decl))
9668 and then Is_List_Member (N)
9669 and then List_Containing (N) = Declarations (Body_Decl)
9676 end Subprogram_Body_OK;
9678 -- Start of processing for Check_Inline_Always_Placement
9681 -- This check is relevant only for pragma Inline_Always
9683 if Pname /= Name_Inline_Always then
9686 -- Nothing to do when the pragma is internally generated on the
9687 -- assumption that it is properly placed.
9689 elsif not Comes_From_Source (N) then
9692 -- Nothing to do for internally generated subprograms that act
9693 -- as accidental homonyms of a source subprogram being inlined.
9695 elsif not Comes_From_Source (Spec_Id) then
9698 -- Nothing to do for generic formal subprograms that act as
9699 -- homonyms of another source subprogram being inlined.
9701 elsif Is_Formal_Subprogram (Spec_Id) then
9704 elsif Compilation_Unit_OK
9705 or else Declarative_List_OK
9706 or else Subprogram_Body_OK
9711 -- At this point it is known that the pragma applies to or appears
9712 -- within a completing body, a completing stub, or a subunit.
9714 Error_Msg_Name_1 := Pname;
9715 Error_Msg_Name_2 := Chars (Spec_Id);
9716 Error_Msg_Sloc := Sloc (Spec_Id);
9719 ("pragma % must appear on initial declaration of subprogram "
9720 & "% defined #", N);
9721 end Check_Inline_Always_Placement;
9723 ---------------------------
9724 -- Inlining_Not_Possible --
9725 ---------------------------
9727 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9728 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9732 if Nkind (Decl) = N_Subprogram_Body then
9733 Stats := Handled_Statement_Sequence (Decl);
9734 return Present (Exception_Handlers (Stats))
9735 or else Present (At_End_Proc (Stats));
9737 elsif Nkind (Decl) = N_Subprogram_Declaration
9738 and then Present (Corresponding_Body (Decl))
9740 if Analyzed (Corresponding_Body (Decl)) then
9741 Error_Msg_N ("pragma appears too late, ignored??", N);
9744 -- If the subprogram is a renaming as body, the body is just a
9745 -- call to the renamed subprogram, and inlining is trivially
9749 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9750 N_Subprogram_Renaming_Declaration
9756 Handled_Statement_Sequence
9757 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9760 Present (Exception_Handlers (Stats))
9761 or else Present (At_End_Proc (Stats));
9765 -- If body is not available, assume the best, the check is
9766 -- performed again when compiling enclosing package bodies.
9770 end Inlining_Not_Possible;
9776 procedure Make_Inline (Subp : Entity_Id) is
9777 Kind : constant Entity_Kind := Ekind (Subp);
9778 Inner_Subp : Entity_Id := Subp;
9781 -- Ignore if bad type, avoid cascaded error
9783 if Etype (Subp) = Any_Type then
9787 -- If inlining is not possible, for now do not treat as an error
9789 elsif Status /= Suppressed
9790 and then Front_End_Inlining
9791 and then Inlining_Not_Possible (Subp)
9796 -- Here we have a candidate for inlining, but we must exclude
9797 -- derived operations. Otherwise we would end up trying to inline
9798 -- a phantom declaration, and the result would be to drag in a
9799 -- body which has no direct inlining associated with it. That
9800 -- would not only be inefficient but would also result in the
9801 -- backend doing cross-unit inlining in cases where it was
9802 -- definitely inappropriate to do so.
9804 -- However, a simple Comes_From_Source test is insufficient, since
9805 -- we do want to allow inlining of generic instances which also do
9806 -- not come from source. We also need to recognize specs generated
9807 -- by the front-end for bodies that carry the pragma. Finally,
9808 -- predefined operators do not come from source but are not
9809 -- inlineable either.
9811 elsif Is_Generic_Instance (Subp)
9812 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9816 elsif not Comes_From_Source (Subp)
9817 and then Scope (Subp) /= Standard_Standard
9823 -- The referenced entity must either be the enclosing entity, or
9824 -- an entity declared within the current open scope.
9826 if Present (Scope (Subp))
9827 and then Scope (Subp) /= Current_Scope
9828 and then Subp /= Current_Scope
9831 ("argument of% must be entity in current scope", Assoc);
9835 -- Processing for procedure, operator or function. If subprogram
9836 -- is aliased (as for an instance) indicate that the renamed
9837 -- entity (if declared in the same unit) is inlined.
9838 -- If this is the anonymous subprogram created for a subprogram
9839 -- instance, the inlining applies to it directly. Otherwise we
9840 -- retrieve it as the alias of the visible subprogram instance.
9842 if Is_Subprogram (Subp) then
9844 -- Ensure that pragma Inline_Always is associated with the
9845 -- initial declaration of the subprogram.
9847 Check_Inline_Always_Placement (Subp);
9849 if Is_Wrapper_Package (Scope (Subp)) then
9852 Inner_Subp := Ultimate_Alias (Inner_Subp);
9855 if In_Same_Source_Unit (Subp, Inner_Subp) then
9856 Set_Inline_Flags (Inner_Subp);
9858 Decl := Parent (Parent (Inner_Subp));
9860 if Nkind (Decl) = N_Subprogram_Declaration
9861 and then Present (Corresponding_Body (Decl))
9863 Set_Inline_Flags (Corresponding_Body (Decl));
9865 elsif Is_Generic_Instance (Subp)
9866 and then Comes_From_Source (Subp)
9868 -- Indicate that the body needs to be created for
9869 -- inlining subsequent calls. The instantiation node
9870 -- follows the declaration of the wrapper package
9871 -- created for it. The subprogram that requires the
9872 -- body is the anonymous one in the wrapper package.
9874 if Scope (Subp) /= Standard_Standard
9876 Need_Subprogram_Instance_Body
9877 (Next (Unit_Declaration_Node
9878 (Scope (Alias (Subp)))), Subp)
9883 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9884 -- appear in a formal part to apply to a formal subprogram.
9885 -- Do not apply check within an instance or a formal package
9886 -- the test will have been applied to the original generic.
9888 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9889 and then In_Same_List (Decl, N)
9890 and then not In_Instance
9893 ("Inline cannot apply to a formal subprogram", N);
9899 -- For a generic subprogram set flag as well, for use at the point
9900 -- of instantiation, to determine whether the body should be
9903 elsif Is_Generic_Subprogram (Subp) then
9904 Set_Inline_Flags (Subp);
9907 -- Literals are by definition inlined
9909 elsif Kind = E_Enumeration_Literal then
9912 -- Anything else is an error
9916 ("expect subprogram name for pragma%", Assoc);
9920 ----------------------
9921 -- Set_Inline_Flags --
9922 ----------------------
9924 procedure Set_Inline_Flags (Subp : Entity_Id) is
9926 -- First set the Has_Pragma_XXX flags and issue the appropriate
9927 -- errors and warnings for suspicious combinations.
9929 if Prag_Id = Pragma_No_Inline then
9930 if Has_Pragma_Inline_Always (Subp) then
9932 ("Inline_Always and No_Inline are mutually exclusive", N);
9933 elsif Has_Pragma_Inline (Subp) then
9935 ("Inline and No_Inline both specified for& ??",
9936 N, Entity (Subp_Id));
9939 Set_Has_Pragma_No_Inline (Subp);
9941 if Prag_Id = Pragma_Inline_Always then
9942 if Has_Pragma_No_Inline (Subp) then
9944 ("Inline_Always and No_Inline are mutually exclusive",
9948 Set_Has_Pragma_Inline_Always (Subp);
9950 if Has_Pragma_No_Inline (Subp) then
9952 ("Inline and No_Inline both specified for& ??",
9953 N, Entity (Subp_Id));
9957 Set_Has_Pragma_Inline (Subp);
9960 -- Then adjust the Is_Inlined flag. It can never be set if the
9961 -- subprogram is subject to pragma No_Inline.
9965 Set_Is_Inlined (Subp, False);
9971 if not Has_Pragma_No_Inline (Subp) then
9972 Set_Is_Inlined (Subp, True);
9976 -- A pragma that applies to a Ghost entity becomes Ghost for the
9977 -- purposes of legality checks and removal of ignored Ghost code.
9979 Mark_Ghost_Pragma (N, Subp);
9981 -- Capture the entity of the first Ghost subprogram being
9982 -- processed for error detection purposes.
9984 if Is_Ghost_Entity (Subp) then
9985 if No (Ghost_Id) then
9989 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9990 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9992 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9993 Ghost_Error_Posted := True;
9995 Error_Msg_Name_1 := Pname;
9997 ("pragma % cannot mention ghost and non-ghost subprograms",
10000 Error_Msg_Sloc := Sloc (Ghost_Id);
10001 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
10003 Error_Msg_Sloc := Sloc (Subp);
10004 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
10006 end Set_Inline_Flags;
10008 -- Start of processing for Process_Inline
10011 -- An inlined subprogram may grant access to its private enclosing
10012 -- context depending on the placement of its body. From elaboration
10013 -- point of view, the flow of execution may enter this private
10014 -- context, and then reach an external unit, thus producing a
10015 -- dependency on that external unit. For such a path to be properly
10016 -- discovered and encoded in the ALI file of the main unit, let the
10017 -- ABE mechanism process the body of the main unit, and encode all
10018 -- relevant invocation constructs and the relations between them.
10020 Mark_Save_Invocation_Graph_Of_Body;
10022 Check_No_Identifiers;
10023 Check_At_Least_N_Arguments (1);
10025 if Status = Enabled then
10026 Inline_Processing_Required := True;
10030 while Present (Assoc) loop
10031 Subp_Id := Get_Pragma_Arg (Assoc);
10035 if Is_Entity_Name (Subp_Id) then
10036 Subp := Entity (Subp_Id);
10038 if Subp = Any_Id then
10040 -- If previous error, avoid cascaded errors
10042 Check_Error_Detected;
10046 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10047 -- is given that directly specifies an aspect of an entity,
10048 -- then it is illegal to give another [...]
10049 -- aspect_specification that directly specifies the same
10050 -- aspect of the entity.
10051 -- We only check Subp directly as per "directly specifies"
10052 -- above and because the case of pragma Inline is really
10053 -- special given its pre aspect usage.
10055 Check_Duplicate_Pragma (Subp);
10056 Record_Rep_Item (Subp, N);
10058 Make_Inline (Subp);
10060 -- For the pragma case, climb homonym chain. This is
10061 -- what implements allowing the pragma in the renaming
10062 -- case, with the result applying to the ancestors, and
10063 -- also allows Inline to apply to all previous homonyms.
10065 if not From_Aspect_Specification (N) then
10066 while Present (Homonym (Subp))
10067 and then Scope (Homonym (Subp)) = Current_Scope
10069 Subp := Homonym (Subp);
10070 Make_Inline (Subp);
10076 if not Applies then
10077 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
10083 -- If the context is a package declaration, the pragma indicates
10084 -- that inlining will require the presence of the corresponding
10085 -- body. (this may be further refined).
10088 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10089 N_Package_Declaration
10091 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
10093 end Process_Inline;
10095 ----------------------------
10096 -- Process_Interface_Name --
10097 ----------------------------
10099 procedure Process_Interface_Name
10100 (Subprogram_Def : Entity_Id;
10102 Link_Arg : Node_Id;
10106 Link_Nam : Node_Id;
10107 String_Val : String_Id;
10109 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10110 -- SN is a string literal node for an interface name. This routine
10111 -- performs some minimal checks that the name is reasonable. In
10112 -- particular that no spaces or other obviously incorrect characters
10113 -- appear. This is only a warning, since any characters are allowed.
10115 ----------------------------------
10116 -- Check_Form_Of_Interface_Name --
10117 ----------------------------------
10119 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10120 S : constant String_Id := Strval (Expr_Value_S (SN));
10121 SL : constant Nat := String_Length (S);
10126 Error_Msg_N ("interface name cannot be null string", SN);
10129 for J in 1 .. SL loop
10130 C := Get_String_Char (S, J);
10132 -- Look for dubious character and issue unconditional warning.
10133 -- Definitely dubious if not in character range.
10135 if not In_Character_Range (C)
10137 -- Commas, spaces and (back)slashes are dubious
10139 or else Get_Character (C) = ','
10140 or else Get_Character (C) = '\'
10141 or else Get_Character (C) = ' '
10142 or else Get_Character (C) = '/'
10145 ("??interface name contains illegal character",
10146 Sloc (SN) + Source_Ptr (J));
10149 end Check_Form_Of_Interface_Name;
10151 -- Start of processing for Process_Interface_Name
10154 -- If we are looking at a pragma that comes from an aspect then it
10155 -- needs to have its corresponding aspect argument expressions
10156 -- analyzed in addition to the generated pragma so that aspects
10157 -- within generic units get properly resolved.
10159 if Present (Prag) and then From_Aspect_Specification (Prag) then
10161 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10169 -- Obtain all interfacing aspects used to construct the pragma
10171 Get_Interfacing_Aspects
10172 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10174 -- Analyze the expression of aspect External_Name
10176 if Present (EN) then
10177 Analyze (Expression (EN));
10180 -- Analyze the expressio of aspect Link_Name
10182 if Present (LN) then
10183 Analyze (Expression (LN));
10188 if No (Link_Arg) then
10189 if No (Ext_Arg) then
10192 elsif Chars (Ext_Arg) = Name_Link_Name then
10194 Link_Nam := Expression (Ext_Arg);
10197 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10198 Ext_Nam := Expression (Ext_Arg);
10203 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10204 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10205 Ext_Nam := Expression (Ext_Arg);
10206 Link_Nam := Expression (Link_Arg);
10209 -- Check expressions for external name and link name are static
10211 if Present (Ext_Nam) then
10212 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10213 Check_Form_Of_Interface_Name (Ext_Nam);
10215 -- Verify that external name is not the name of a local entity,
10216 -- which would hide the imported one and could lead to run-time
10217 -- surprises. The problem can only arise for entities declared in
10218 -- a package body (otherwise the external name is fully qualified
10219 -- and will not conflict).
10227 if Prag_Id = Pragma_Import then
10228 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10229 E := Entity_Id (Get_Name_Table_Int (Nam));
10231 if Nam /= Chars (Subprogram_Def)
10232 and then Present (E)
10233 and then not Is_Overloadable (E)
10234 and then Is_Immediately_Visible (E)
10235 and then not Is_Imported (E)
10236 and then Ekind (Scope (E)) = E_Package
10239 while Present (Par) loop
10240 if Nkind (Par) = N_Package_Body then
10241 Error_Msg_Sloc := Sloc (E);
10243 ("imported entity is hidden by & declared#",
10248 Par := Parent (Par);
10255 if Present (Link_Nam) then
10256 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10257 Check_Form_Of_Interface_Name (Link_Nam);
10260 -- If there is no link name, just set the external name
10262 if No (Link_Nam) then
10263 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10265 -- For the Link_Name case, the given literal is preceded by an
10266 -- asterisk, which indicates to GCC that the given name should be
10267 -- taken literally, and in particular that no prepending of
10268 -- underlines should occur, even in systems where this is the
10273 Store_String_Char (Get_Char_Code ('*'));
10274 String_Val := Strval (Expr_Value_S (Link_Nam));
10275 Store_String_Chars (String_Val);
10277 Make_String_Literal (Sloc (Link_Nam),
10278 Strval => End_String);
10281 -- Set the interface name. If the entity is a generic instance, use
10282 -- its alias, which is the callable entity.
10284 if Is_Generic_Instance (Subprogram_Def) then
10285 Set_Encoded_Interface_Name
10286 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10288 Set_Encoded_Interface_Name
10289 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10292 Check_Duplicated_Export_Name (Link_Nam);
10293 end Process_Interface_Name;
10295 -----------------------------------------
10296 -- Process_Interrupt_Or_Attach_Handler --
10297 -----------------------------------------
10299 procedure Process_Interrupt_Or_Attach_Handler is
10300 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10301 Prot_Typ : constant Entity_Id := Scope (Handler);
10304 -- A pragma that applies to a Ghost entity becomes Ghost for the
10305 -- purposes of legality checks and removal of ignored Ghost code.
10307 Mark_Ghost_Pragma (N, Handler);
10308 Set_Is_Interrupt_Handler (Handler);
10310 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10312 Record_Rep_Item (Prot_Typ, N);
10314 -- Chain the pragma on the contract for completeness
10316 Add_Contract_Item (N, Handler);
10317 end Process_Interrupt_Or_Attach_Handler;
10319 --------------------------------------------------
10320 -- Process_Restrictions_Or_Restriction_Warnings --
10321 --------------------------------------------------
10323 -- Note: some of the simple identifier cases were handled in par-prag,
10324 -- but it is harmless (and more straightforward) to simply handle all
10325 -- cases here, even if it means we repeat a bit of work in some cases.
10327 procedure Process_Restrictions_Or_Restriction_Warnings
10331 R_Id : Restriction_Id;
10337 -- Ignore all Restrictions pragmas in CodePeer mode
10339 if CodePeer_Mode then
10343 Check_Ada_83_Warning;
10344 Check_At_Least_N_Arguments (1);
10345 Check_Valid_Configuration_Pragma;
10348 while Present (Arg) loop
10350 Expr := Get_Pragma_Arg (Arg);
10352 -- Case of no restriction identifier present
10354 if Id = No_Name then
10355 if Nkind (Expr) /= N_Identifier then
10357 ("invalid form for restriction", Arg);
10362 (Process_Restriction_Synonyms (Expr));
10364 if R_Id not in All_Boolean_Restrictions then
10365 Error_Msg_Name_1 := Pname;
10367 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10369 -- Check for possible misspelling
10371 for J in Restriction_Id loop
10373 Rnm : constant String := Restriction_Id'Image (J);
10376 Name_Buffer (1 .. Rnm'Length) := Rnm;
10377 Name_Len := Rnm'Length;
10378 Set_Casing (All_Lower_Case);
10380 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10383 (Source_Index (Current_Sem_Unit)));
10384 Error_Msg_String (1 .. Rnm'Length) :=
10385 Name_Buffer (1 .. Name_Len);
10386 Error_Msg_Strlen := Rnm'Length;
10387 Error_Msg_N -- CODEFIX
10388 ("\possible misspelling of ""~""",
10389 Get_Pragma_Arg (Arg));
10398 if Implementation_Restriction (R_Id) then
10399 Check_Restriction (No_Implementation_Restrictions, Arg);
10402 -- Special processing for No_Elaboration_Code restriction
10404 if R_Id = No_Elaboration_Code then
10406 -- Restriction is only recognized within a configuration
10407 -- pragma file, or within a unit of the main extended
10408 -- program. Note: the test for Main_Unit is needed to
10409 -- properly include the case of configuration pragma files.
10411 if not (Current_Sem_Unit = Main_Unit
10412 or else In_Extended_Main_Source_Unit (N))
10416 -- Don't allow in a subunit unless already specified in
10419 elsif Nkind (Parent (N)) = N_Compilation_Unit
10420 and then Nkind (Unit (Parent (N))) = N_Subunit
10421 and then not Restriction_Active (No_Elaboration_Code)
10424 ("invalid specification of ""No_Elaboration_Code""",
10427 ("\restriction cannot be specified in a subunit", N);
10429 ("\unless also specified in body or spec", N);
10432 -- If we accept a No_Elaboration_Code restriction, then it
10433 -- needs to be added to the configuration restriction set so
10434 -- that we get proper application to other units in the main
10435 -- extended source as required.
10438 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10441 -- Special processing for No_Tasking restriction placed in
10442 -- a configuration pragmas file.
10444 elsif R_Id = No_Tasking and then No (Cunit (Main_Unit)) then
10445 Set_Global_No_Tasking;
10448 Set_Restriction (R_Id, N, Warn);
10450 if R_Id = No_Dynamic_CPU_Assignment
10451 or else R_Id = No_Tasks_Unassigned_To_CPU
10453 -- These imply No_Dependence =>
10454 -- "System.Multiprocessors.Dispatching_Domains".
10455 -- This is not strictly what the AI says, but it eliminates
10456 -- the need for run-time checks, which are undesirable in
10459 Set_Restriction_No_Dependence
10461 (Sel_Comp ("system", "multiprocessors", Loc),
10462 "dispatching_domains"),
10466 if R_Id = No_Tasks_Unassigned_To_CPU then
10467 -- Likewise, imply No_Dynamic_CPU_Assignment
10469 Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn);
10472 -- Check for obsolescent restrictions in Ada 2005 mode
10475 and then Ada_Version >= Ada_2005
10476 and then (R_Id = No_Asynchronous_Control
10478 R_Id = No_Unchecked_Deallocation
10480 R_Id = No_Unchecked_Conversion)
10482 Check_Restriction (No_Obsolescent_Features, N);
10485 -- A very special case that must be processed here: pragma
10486 -- Restrictions (No_Exceptions) turns off all run-time
10487 -- checking. This is a bit dubious in terms of the formal
10488 -- language definition, but it is what is intended by RM
10489 -- H.4(12). Restriction_Warnings never affects generated code
10490 -- so this is done only in the real restriction case.
10492 -- Atomic_Synchronization is not a real check, so it is not
10493 -- affected by this processing).
10495 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10496 -- run-time checks in CodePeer and GNATprove modes: we want to
10497 -- generate checks for analysis purposes, as set respectively
10498 -- by -gnatC and -gnatd.F
10501 and then not (CodePeer_Mode or GNATprove_Mode)
10502 and then R_Id = No_Exceptions
10504 for J in Scope_Suppress.Suppress'Range loop
10505 if J /= Atomic_Synchronization then
10506 Scope_Suppress.Suppress (J) := True;
10511 -- Case of No_Dependence => unit-name. Note that the parser
10512 -- already made the necessary entry in the No_Dependence table.
10514 elsif Id = Name_No_Dependence then
10515 if not OK_No_Dependence_Unit_Name (Expr) then
10519 -- Case of No_Specification_Of_Aspect => aspect-identifier
10521 elsif Id = Name_No_Specification_Of_Aspect then
10526 if Nkind (Expr) /= N_Identifier then
10529 A_Id := Get_Aspect_Id (Chars (Expr));
10532 if A_Id = No_Aspect then
10533 Error_Pragma_Arg ("invalid restriction name", Arg);
10535 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10539 -- Case of No_Use_Of_Attribute => attribute-identifier
10541 elsif Id = Name_No_Use_Of_Attribute then
10542 if Nkind (Expr) /= N_Identifier
10543 or else not Is_Attribute_Name (Chars (Expr))
10545 Error_Msg_N ("unknown attribute name??", Expr);
10548 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10551 -- Case of No_Use_Of_Entity => fully-qualified-name
10553 elsif Id = Name_No_Use_Of_Entity then
10555 -- Restriction is only recognized within a configuration
10556 -- pragma file, or within a unit of the main extended
10557 -- program. Note: the test for Main_Unit is needed to
10558 -- properly include the case of configuration pragma files.
10560 if Current_Sem_Unit = Main_Unit
10561 or else In_Extended_Main_Source_Unit (N)
10563 if not OK_No_Dependence_Unit_Name (Expr) then
10564 Error_Msg_N ("wrong form for entity name", Expr);
10566 Set_Restriction_No_Use_Of_Entity
10567 (Expr, Warn, No_Profile);
10571 -- Case of No_Use_Of_Pragma => pragma-identifier
10573 elsif Id = Name_No_Use_Of_Pragma then
10574 if Nkind (Expr) /= N_Identifier
10575 or else not Is_Pragma_Name (Chars (Expr))
10577 Error_Msg_N ("unknown pragma name??", Expr);
10579 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10582 -- All other cases of restriction identifier present
10585 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10586 Analyze_And_Resolve (Expr, Any_Integer);
10588 if R_Id not in All_Parameter_Restrictions then
10590 ("invalid restriction parameter identifier", Arg);
10592 elsif not Is_OK_Static_Expression (Expr) then
10593 Flag_Non_Static_Expr
10594 ("value must be static expression!", Expr);
10597 elsif not Is_Integer_Type (Etype (Expr))
10598 or else Expr_Value (Expr) < 0
10601 ("value must be non-negative integer", Arg);
10604 -- Restriction pragma is active
10606 Val := Expr_Value (Expr);
10608 if not UI_Is_In_Int_Range (Val) then
10610 ("pragma ignored, value too large??", Arg);
10613 Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val)));
10618 end Process_Restrictions_Or_Restriction_Warnings;
10620 ---------------------------------
10621 -- Process_Suppress_Unsuppress --
10622 ---------------------------------
10624 -- Note: this procedure makes entries in the check suppress data
10625 -- structures managed by Sem. See spec of package Sem for full
10626 -- details on how we handle recording of check suppression.
10628 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10633 In_Package_Spec : constant Boolean :=
10634 Is_Package_Or_Generic_Package (Current_Scope)
10635 and then not In_Package_Body (Current_Scope);
10637 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10638 -- Used to suppress a single check on the given entity
10640 --------------------------------
10641 -- Suppress_Unsuppress_Echeck --
10642 --------------------------------
10644 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10646 -- Check for error of trying to set atomic synchronization for
10647 -- a non-atomic variable.
10649 if C = Atomic_Synchronization
10650 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10653 ("pragma & requires atomic type or variable",
10654 Pragma_Identifier (Original_Node (N)));
10657 Set_Checks_May_Be_Suppressed (E);
10659 if In_Package_Spec then
10660 Push_Global_Suppress_Stack_Entry
10663 Suppress => Suppress_Case);
10665 Push_Local_Suppress_Stack_Entry
10668 Suppress => Suppress_Case);
10671 -- If this is a first subtype, and the base type is distinct,
10672 -- then also set the suppress flags on the base type.
10674 if Is_First_Subtype (E) and then Etype (E) /= E then
10675 Suppress_Unsuppress_Echeck (Etype (E), C);
10677 end Suppress_Unsuppress_Echeck;
10679 -- Start of processing for Process_Suppress_Unsuppress
10682 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10683 -- on user code: we want to generate checks for analysis purposes, as
10684 -- set respectively by -gnatC and -gnatd.F
10686 if Comes_From_Source (N)
10687 and then (CodePeer_Mode or GNATprove_Mode)
10692 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10693 -- declarative part or a package spec (RM 11.5(5)).
10695 if not Is_Configuration_Pragma then
10696 Check_Is_In_Decl_Part_Or_Package_Spec;
10699 Check_At_Least_N_Arguments (1);
10700 Check_At_Most_N_Arguments (2);
10701 Check_No_Identifier (Arg1);
10702 Check_Arg_Is_Identifier (Arg1);
10704 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10706 if C = No_Check_Id then
10708 ("argument of pragma% is not valid check name", Arg1);
10711 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10713 if C = Elaboration_Check and then SPARK_Mode = On then
10715 ("Suppress of Elaboration_Check ignored in SPARK??",
10716 "\elaboration checking rules are statically enforced "
10717 & "(SPARK RM 7.7)", Arg1);
10720 -- One-argument case
10722 if Arg_Count = 1 then
10724 -- Make an entry in the local scope suppress table. This is the
10725 -- table that directly shows the current value of the scope
10726 -- suppress check for any check id value.
10728 if C = All_Checks then
10730 -- For All_Checks, we set all specific predefined checks with
10731 -- the exception of Elaboration_Check, which is handled
10732 -- specially because of not wanting All_Checks to have the
10733 -- effect of deactivating static elaboration order processing.
10734 -- Atomic_Synchronization is also not affected, since this is
10735 -- not a real check.
10737 for J in Scope_Suppress.Suppress'Range loop
10738 if J /= Elaboration_Check
10740 J /= Atomic_Synchronization
10742 Scope_Suppress.Suppress (J) := Suppress_Case;
10746 -- If not All_Checks, and predefined check, then set appropriate
10747 -- scope entry. Note that we will set Elaboration_Check if this
10748 -- is explicitly specified. Atomic_Synchronization is allowed
10749 -- only if internally generated and entity is atomic.
10751 elsif C in Predefined_Check_Id
10752 and then (not Comes_From_Source (N)
10753 or else C /= Atomic_Synchronization)
10755 Scope_Suppress.Suppress (C) := Suppress_Case;
10758 -- Also make an entry in the Local_Entity_Suppress table
10760 Push_Local_Suppress_Stack_Entry
10763 Suppress => Suppress_Case);
10765 -- Case of two arguments present, where the check is suppressed for
10766 -- a specified entity (given as the second argument of the pragma)
10769 -- This is obsolescent in Ada 2005 mode
10771 if Ada_Version >= Ada_2005 then
10772 Check_Restriction (No_Obsolescent_Features, Arg2);
10775 Check_Optional_Identifier (Arg2, Name_On);
10776 E_Id := Get_Pragma_Arg (Arg2);
10779 if not Is_Entity_Name (E_Id) then
10781 ("second argument of pragma% must be entity name", Arg2);
10784 E := Entity (E_Id);
10790 -- A pragma that applies to a Ghost entity becomes Ghost for the
10791 -- purposes of legality checks and removal of ignored Ghost code.
10793 Mark_Ghost_Pragma (N, E);
10795 -- Enforce RM 11.5(7) which requires that for a pragma that
10796 -- appears within a package spec, the named entity must be
10797 -- within the package spec. We allow the package name itself
10798 -- to be mentioned since that makes sense, although it is not
10799 -- strictly allowed by 11.5(7).
10802 and then E /= Current_Scope
10803 and then Scope (E) /= Current_Scope
10806 ("entity in pragma% is not in package spec (RM 11.5(7))",
10810 -- Loop through homonyms. As noted below, in the case of a package
10811 -- spec, only homonyms within the package spec are considered.
10814 Suppress_Unsuppress_Echeck (E, C);
10816 if Is_Generic_Instance (E)
10817 and then Is_Subprogram (E)
10818 and then Present (Alias (E))
10820 Suppress_Unsuppress_Echeck (Alias (E), C);
10823 -- Move to next homonym if not aspect spec case
10825 exit when From_Aspect_Specification (N);
10829 -- If we are within a package specification, the pragma only
10830 -- applies to homonyms in the same scope.
10832 exit when In_Package_Spec
10833 and then Scope (E) /= Current_Scope;
10836 end Process_Suppress_Unsuppress;
10838 -------------------------------
10839 -- Record_Independence_Check --
10840 -------------------------------
10842 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10843 pragma Unreferenced (N, E);
10845 -- For GCC back ends the validation is done a priori
10846 -- ??? This code is dead, might be useful in the future
10848 -- if not AAMP_On_Target then
10852 -- Independence_Checks.Append ((N, E));
10855 end Record_Independence_Check;
10861 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10863 if Is_Imported (E) then
10865 ("cannot export entity& that was previously imported", Arg);
10867 elsif Present (Address_Clause (E))
10868 and then not Relaxed_RM_Semantics
10871 ("cannot export entity& that has an address clause", Arg);
10874 Set_Is_Exported (E);
10876 -- Generate a reference for entity explicitly, because the
10877 -- identifier may be overloaded and name resolution will not
10880 Generate_Reference (E, Arg);
10882 -- Deal with exporting non-library level entity
10884 if not Is_Library_Level_Entity (E) then
10886 -- Not allowed at all for subprograms
10888 if Is_Subprogram (E) then
10889 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10891 -- Otherwise set public and statically allocated
10895 Set_Is_Statically_Allocated (E);
10897 -- Warn if the corresponding W flag is set
10899 if Warn_On_Export_Import
10901 -- Only do this for something that was in the source. Not
10902 -- clear if this can be False now (there used for sure to be
10903 -- cases on some systems where it was False), but anyway the
10904 -- test is harmless if not needed, so it is retained.
10906 and then Comes_From_Source (Arg)
10909 ("?x?& has been made static as a result of Export",
10912 ("\?x?this usage is non-standard and non-portable",
10918 if Warn_On_Export_Import and then Is_Type (E) then
10919 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10922 if Warn_On_Export_Import and Inside_A_Generic then
10924 ("all instances of& will have the same external name?x?",
10929 ----------------------------------------------
10930 -- Set_Extended_Import_Export_External_Name --
10931 ----------------------------------------------
10933 procedure Set_Extended_Import_Export_External_Name
10934 (Internal_Ent : Entity_Id;
10935 Arg_External : Node_Id)
10937 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10938 New_Name : Node_Id;
10941 if No (Arg_External) then
10945 Check_Arg_Is_External_Name (Arg_External);
10947 if Nkind (Arg_External) = N_String_Literal then
10948 if String_Length (Strval (Arg_External)) = 0 then
10951 New_Name := Adjust_External_Name_Case (Arg_External);
10954 elsif Nkind (Arg_External) = N_Identifier then
10955 New_Name := Get_Default_External_Name (Arg_External);
10957 -- Check_Arg_Is_External_Name should let through only identifiers and
10958 -- string literals or static string expressions (which are folded to
10959 -- string literals).
10962 raise Program_Error;
10965 -- If we already have an external name set (by a prior normal Import
10966 -- or Export pragma), then the external names must match
10968 if Present (Interface_Name (Internal_Ent)) then
10970 -- Ignore mismatching names in CodePeer mode, to support some
10971 -- old compilers which would export the same procedure under
10972 -- different names, e.g:
10974 -- pragma Export_Procedure (P, "a");
10975 -- pragma Export_Procedure (P, "b");
10977 if CodePeer_Mode then
10981 Check_Matching_Internal_Names : declare
10982 S1 : constant String_Id := Strval (Old_Name);
10983 S2 : constant String_Id := Strval (New_Name);
10985 procedure Mismatch;
10986 pragma No_Return (Mismatch);
10987 -- Called if names do not match
10993 procedure Mismatch is
10995 Error_Msg_Sloc := Sloc (Old_Name);
10997 ("external name does not match that given #",
11001 -- Start of processing for Check_Matching_Internal_Names
11004 if String_Length (S1) /= String_Length (S2) then
11008 for J in 1 .. String_Length (S1) loop
11009 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
11014 end Check_Matching_Internal_Names;
11016 -- Otherwise set the given name
11019 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
11020 Check_Duplicated_Export_Name (New_Name);
11022 end Set_Extended_Import_Export_External_Name;
11028 procedure Set_Imported (E : Entity_Id) is
11030 -- Error message if already imported or exported
11032 if Is_Exported (E) or else Is_Imported (E) then
11034 -- Error if being set Exported twice
11036 if Is_Exported (E) then
11037 Error_Msg_NE ("entity& was previously exported", N, E);
11039 -- Ignore error in CodePeer mode where we treat all imported
11040 -- subprograms as unknown.
11042 elsif CodePeer_Mode then
11045 -- OK if Import/Interface case
11047 elsif Import_Interface_Present (N) then
11050 -- Error if being set Imported twice
11053 Error_Msg_NE ("entity& was previously imported", N, E);
11056 Error_Msg_Name_1 := Pname;
11058 ("\(pragma% applies to all previous entities)", N);
11060 Error_Msg_Sloc := Sloc (E);
11061 Error_Msg_NE ("\import not allowed for& declared#", N, E);
11063 -- Here if not previously imported or exported, OK to import
11066 Set_Is_Imported (E);
11068 -- For subprogram, set Import_Pragma field
11070 if Is_Subprogram (E) then
11071 Set_Import_Pragma (E, N);
11074 -- If the entity is an object that is not at the library level,
11075 -- then it is statically allocated. We do not worry about objects
11076 -- with address clauses in this context since they are not really
11077 -- imported in the linker sense.
11080 and then not Is_Library_Level_Entity (E)
11081 and then No (Address_Clause (E))
11083 Set_Is_Statically_Allocated (E);
11090 -------------------------
11091 -- Set_Mechanism_Value --
11092 -------------------------
11094 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11095 -- analyzed, since it is semantic nonsense), so we get it in the exact
11096 -- form created by the parser.
11098 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11099 procedure Bad_Mechanism;
11100 pragma No_Return (Bad_Mechanism);
11101 -- Signal bad mechanism name
11103 -------------------
11104 -- Bad_Mechanism --
11105 -------------------
11107 procedure Bad_Mechanism is
11109 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11112 -- Start of processing for Set_Mechanism_Value
11115 if Mechanism (Ent) /= Default_Mechanism then
11117 ("mechanism for & has already been set", Mech_Name, Ent);
11120 -- MECHANISM_NAME ::= value | reference
11122 if Nkind (Mech_Name) = N_Identifier then
11123 if Chars (Mech_Name) = Name_Value then
11124 Set_Mechanism (Ent, By_Copy);
11127 elsif Chars (Mech_Name) = Name_Reference then
11128 Set_Mechanism (Ent, By_Reference);
11131 elsif Chars (Mech_Name) = Name_Copy then
11133 ("bad mechanism name, Value assumed", Mech_Name);
11142 end Set_Mechanism_Value;
11144 --------------------------
11145 -- Set_Rational_Profile --
11146 --------------------------
11148 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11149 -- extension to the semantics of renaming declarations.
11151 procedure Set_Rational_Profile is
11153 Implicit_Packing := True;
11154 Overriding_Renamings := True;
11155 Use_VADS_Size := True;
11156 end Set_Rational_Profile;
11158 ---------------------------
11159 -- Set_Ravenscar_Profile --
11160 ---------------------------
11162 -- The tasks to be done here are
11164 -- Set required policies
11166 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11167 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11168 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11169 -- (For GNAT_Ravenscar_EDF profile)
11170 -- pragma Locking_Policy (Ceiling_Locking)
11172 -- Set Detect_Blocking mode
11174 -- Set required restrictions (see System.Rident for detailed list)
11176 -- Set the No_Dependence rules
11177 -- No_Dependence => Ada.Asynchronous_Task_Control
11178 -- No_Dependence => Ada.Calendar
11179 -- No_Dependence => Ada.Execution_Time.Group_Budget
11180 -- No_Dependence => Ada.Execution_Time.Timers
11181 -- No_Dependence => Ada.Task_Attributes
11182 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11184 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11185 procedure Set_Error_Msg_To_Profile_Name;
11186 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11189 -----------------------------------
11190 -- Set_Error_Msg_To_Profile_Name --
11191 -----------------------------------
11193 procedure Set_Error_Msg_To_Profile_Name is
11194 Prof_Nam : constant Node_Id :=
11196 (First (Pragma_Argument_Associations (N)));
11199 Get_Name_String (Chars (Prof_Nam));
11200 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11201 Error_Msg_Strlen := Name_Len;
11202 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11203 end Set_Error_Msg_To_Profile_Name;
11205 Profile_Dispatching_Policy : Character;
11207 -- Start of processing for Set_Ravenscar_Profile
11210 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11212 if Profile = GNAT_Ravenscar_EDF then
11213 Profile_Dispatching_Policy := 'E';
11215 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11218 Profile_Dispatching_Policy := 'F';
11221 if Task_Dispatching_Policy /= ' '
11222 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11224 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11225 Set_Error_Msg_To_Profile_Name;
11226 Error_Pragma ("Profile (~) incompatible with policy#");
11228 -- Set the FIFO_Within_Priorities policy, but always preserve
11229 -- System_Location since we like the error message with the run time
11233 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11235 if Task_Dispatching_Policy_Sloc /= System_Location then
11236 Task_Dispatching_Policy_Sloc := Loc;
11240 -- pragma Locking_Policy (Ceiling_Locking)
11242 if Locking_Policy /= ' '
11243 and then Locking_Policy /= 'C'
11245 Error_Msg_Sloc := Locking_Policy_Sloc;
11246 Set_Error_Msg_To_Profile_Name;
11247 Error_Pragma ("Profile (~) incompatible with policy#");
11249 -- Set the Ceiling_Locking policy, but preserve System_Location since
11250 -- we like the error message with the run time name.
11253 Locking_Policy := 'C';
11255 if Locking_Policy_Sloc /= System_Location then
11256 Locking_Policy_Sloc := Loc;
11260 -- pragma Detect_Blocking
11262 Detect_Blocking := True;
11264 -- Set the corresponding restrictions
11266 Set_Profile_Restrictions
11267 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11269 -- Set the No_Dependence restrictions
11271 -- The following No_Dependence restrictions:
11272 -- No_Dependence => Ada.Asynchronous_Task_Control
11273 -- No_Dependence => Ada.Calendar
11274 -- No_Dependence => Ada.Task_Attributes
11275 -- are already set by previous call to Set_Profile_Restrictions.
11278 -- Set the following restrictions which were added to Ada 2005:
11279 -- No_Dependence => Ada.Execution_Time.Group_Budget
11280 -- No_Dependence => Ada.Execution_Time.Timers
11282 if Ada_Version >= Ada_2005 then
11284 Execution_Time : constant Node_Id :=
11285 Sel_Comp ("ada", "execution_time", Loc);
11286 Group_Budgets : constant Node_Id :=
11287 Sel_Comp (Execution_Time, "group_budgets");
11288 Timers : constant Node_Id :=
11289 Sel_Comp (Execution_Time, "timers");
11291 Set_Restriction_No_Dependence
11292 (Unit => Group_Budgets,
11293 Warn => Treat_Restrictions_As_Warnings,
11294 Profile => Ravenscar);
11295 Set_Restriction_No_Dependence
11297 Warn => Treat_Restrictions_As_Warnings,
11298 Profile => Ravenscar);
11302 -- Set the following restriction which was added to Ada 2012 (see
11304 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11306 if Ada_Version >= Ada_2012 then
11307 Set_Restriction_No_Dependence
11309 (Sel_Comp ("system", "multiprocessors", Loc),
11310 "dispatching_domains"),
11311 Warn => Treat_Restrictions_As_Warnings,
11312 Profile => Ravenscar);
11314 -- Set the following restriction which was added to Ada 2020,
11315 -- but as a binding interpretation:
11316 -- No_Dependence => Ada.Synchronous_Barriers
11317 -- for Ravenscar (and therefore for Ravenscar variants) but not
11318 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11319 -- in Ada2012 (AI05-0174).
11321 if Profile /= Jorvik then
11322 Set_Restriction_No_Dependence
11323 (Sel_Comp ("ada", "synchronous_barriers", Loc),
11324 Warn => Treat_Restrictions_As_Warnings,
11325 Profile => Ravenscar);
11329 end Set_Ravenscar_Profile;
11331 -- Start of processing for Analyze_Pragma
11334 -- The following code is a defense against recursion. Not clear that
11335 -- this can happen legitimately, but perhaps some error situations can
11336 -- cause it, and we did see this recursion during testing.
11338 if Analyzed (N) then
11344 Check_Restriction_No_Use_Of_Pragma (N);
11346 if Get_Aspect_Id (Chars (Pragma_Identifier (N))) /= No_Aspect then
11347 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11348 -- no aspect_specification, attribute_definition_clause, or pragma
11350 Check_Restriction_No_Specification_Of_Aspect (N);
11353 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11354 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11356 if Should_Ignore_Pragma_Sem (N)
11357 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11358 and then Ignore_Rep_Clauses)
11363 -- Deal with unrecognized pragma
11365 if not Is_Pragma_Name (Pname) then
11367 Msg_Issued : Boolean := False;
11370 (Msg_Issued, No_Unrecognized_Pragmas, Pragma_Identifier (N));
11371 if not Msg_Issued and then Warn_On_Unrecognized_Pragma then
11372 Error_Msg_Name_1 := Pname;
11373 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11375 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11376 if Is_Bad_Spelling_Of (Pname, PN) then
11377 Error_Msg_Name_1 := PN;
11378 Error_Msg_N -- CODEFIX
11379 ("\?g?possible misspelling of %!",
11380 Pragma_Identifier (N));
11390 -- Here to start processing for recognized pragma
11392 Pname := Original_Aspect_Pragma_Name (N);
11394 -- Capture setting of Opt.Uneval_Old
11396 case Opt.Uneval_Old is
11398 Set_Uneval_Old_Accept (N);
11404 Set_Uneval_Old_Warn (N);
11407 raise Program_Error;
11410 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11411 -- is already set, indicating that we have already checked the policy
11412 -- at the right point. This happens for example in the case of a pragma
11413 -- that is derived from an Aspect.
11415 if Is_Ignored (N) or else Is_Checked (N) then
11418 -- For a pragma that is a rewriting of another pragma, copy the
11419 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11421 elsif Is_Rewrite_Substitution (N)
11422 and then Nkind (Original_Node (N)) = N_Pragma
11424 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11425 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11427 -- Otherwise query the applicable policy at this point
11430 Check_Applicable_Policy (N);
11432 -- If pragma is disabled, rewrite as NULL and skip analysis
11434 if Is_Disabled (N) then
11435 Rewrite (N, Make_Null_Statement (Loc));
11441 -- Mark assertion pragmas as Ghost depending on their enclosing context
11443 if Assertion_Expression_Pragma (Prag_Id) then
11444 Mark_Ghost_Pragma (N, Current_Scope);
11447 -- Preset arguments
11456 if Present (Pragma_Argument_Associations (N)) then
11457 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11458 Arg1 := First (Pragma_Argument_Associations (N));
11460 if Present (Arg1) then
11461 Arg2 := Next (Arg1);
11463 if Present (Arg2) then
11464 Arg3 := Next (Arg2);
11466 if Present (Arg3) then
11467 Arg4 := Next (Arg3);
11469 if Present (Arg4) then
11470 Arg5 := Next (Arg4);
11477 -- An enumeration type defines the pragmas that are supported by the
11478 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11479 -- into the corresponding enumeration value for the following case.
11487 -- pragma Abort_Defer;
11489 when Pragma_Abort_Defer =>
11491 Check_Arg_Count (0);
11493 -- The only required semantic processing is to check the
11494 -- placement. This pragma must appear at the start of the
11495 -- statement sequence of a handled sequence of statements.
11497 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11498 or else N /= First (Statements (Parent (N)))
11503 --------------------
11504 -- Abstract_State --
11505 --------------------
11507 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11509 -- ABSTRACT_STATE_LIST ::=
11511 -- | STATE_NAME_WITH_OPTIONS
11512 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11514 -- STATE_NAME_WITH_OPTIONS ::=
11516 -- | (STATE_NAME with OPTION_LIST)
11518 -- OPTION_LIST ::= OPTION {, OPTION}
11522 -- | NAME_VALUE_OPTION
11524 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11526 -- NAME_VALUE_OPTION ::=
11527 -- Part_Of => ABSTRACT_STATE
11528 -- | External [=> EXTERNAL_PROPERTY_LIST]
11530 -- EXTERNAL_PROPERTY_LIST ::=
11531 -- EXTERNAL_PROPERTY
11532 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11534 -- EXTERNAL_PROPERTY ::=
11535 -- Async_Readers [=> boolean_EXPRESSION]
11536 -- | Async_Writers [=> boolean_EXPRESSION]
11537 -- | Effective_Reads [=> boolean_EXPRESSION]
11538 -- | Effective_Writes [=> boolean_EXPRESSION]
11539 -- others => boolean_EXPRESSION
11541 -- STATE_NAME ::= defining_identifier
11543 -- ABSTRACT_STATE ::= name
11545 -- Characteristics:
11547 -- * Analysis - The annotation is fully analyzed immediately upon
11548 -- elaboration as it cannot forward reference entities.
11550 -- * Expansion - None.
11552 -- * Template - The annotation utilizes the generic template of the
11553 -- related package declaration.
11555 -- * Globals - The annotation cannot reference global entities.
11557 -- * Instance - The annotation is instantiated automatically when
11558 -- the related generic package is instantiated.
11560 when Pragma_Abstract_State => Abstract_State : declare
11561 Missing_Parentheses : Boolean := False;
11562 -- Flag set when a state declaration with options is not properly
11565 -- Flags used to verify the consistency of states
11567 Non_Null_Seen : Boolean := False;
11568 Null_Seen : Boolean := False;
11570 procedure Analyze_Abstract_State
11572 Pack_Id : Entity_Id);
11573 -- Verify the legality of a single state declaration. Create and
11574 -- decorate a state abstraction entity and introduce it into the
11575 -- visibility chain. Pack_Id denotes the entity or the related
11576 -- package where pragma Abstract_State appears.
11578 procedure Malformed_State_Error (State : Node_Id);
11579 -- Emit an error concerning the illegal declaration of abstract
11580 -- state State. This routine diagnoses syntax errors that lead to
11581 -- a different parse tree. The error is issued regardless of the
11582 -- SPARK mode in effect.
11584 ----------------------------
11585 -- Analyze_Abstract_State --
11586 ----------------------------
11588 procedure Analyze_Abstract_State
11590 Pack_Id : Entity_Id)
11592 -- Flags used to verify the consistency of options
11594 AR_Seen : Boolean := False;
11595 AW_Seen : Boolean := False;
11596 ER_Seen : Boolean := False;
11597 EW_Seen : Boolean := False;
11598 External_Seen : Boolean := False;
11599 Ghost_Seen : Boolean := False;
11600 Others_Seen : Boolean := False;
11601 Part_Of_Seen : Boolean := False;
11602 Relaxed_Initialization_Seen : Boolean := False;
11603 Synchronous_Seen : Boolean := False;
11605 -- Flags used to store the static value of all external states'
11608 AR_Val : Boolean := False;
11609 AW_Val : Boolean := False;
11610 ER_Val : Boolean := False;
11611 EW_Val : Boolean := False;
11613 State_Id : Entity_Id := Empty;
11614 -- The entity to be generated for the current state declaration
11616 procedure Analyze_External_Option (Opt : Node_Id);
11617 -- Verify the legality of option External
11619 procedure Analyze_External_Property
11621 Expr : Node_Id := Empty);
11622 -- Verify the legailty of a single external property. Prop
11623 -- denotes the external property. Expr is the expression used
11624 -- to set the property.
11626 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11627 -- Verify the legality of option Part_Of
11629 procedure Check_Duplicate_Option
11631 Status : in out Boolean);
11632 -- Flag Status denotes whether a particular option has been
11633 -- seen while processing a state. This routine verifies that
11634 -- Opt is not a duplicate option and sets the flag Status
11635 -- (SPARK RM 7.1.4(1)).
11637 procedure Check_Duplicate_Property
11639 Status : in out Boolean);
11640 -- Flag Status denotes whether a particular property has been
11641 -- seen while processing option External. This routine verifies
11642 -- that Prop is not a duplicate property and sets flag Status.
11643 -- Opt is not a duplicate property and sets the flag Status.
11644 -- (SPARK RM 7.1.4(2))
11646 procedure Check_Ghost_Synchronous;
11647 -- Ensure that the abstract state is not subject to both Ghost
11648 -- and Synchronous simple options. Emit an error if this is the
11651 procedure Create_Abstract_State
11655 Is_Null : Boolean);
11656 -- Generate an abstract state entity with name Nam and enter it
11657 -- into visibility. Decl is the "declaration" of the state as
11658 -- it appears in pragma Abstract_State. Loc is the location of
11659 -- the related state "declaration". Flag Is_Null should be set
11660 -- when the associated Abstract_State pragma defines a null
11663 -----------------------------
11664 -- Analyze_External_Option --
11665 -----------------------------
11667 procedure Analyze_External_Option (Opt : Node_Id) is
11668 Errors : constant Nat := Serious_Errors_Detected;
11670 Props : Node_Id := Empty;
11673 if Nkind (Opt) = N_Component_Association then
11674 Props := Expression (Opt);
11677 -- External state with properties
11679 if Present (Props) then
11681 -- Multiple properties appear as an aggregate
11683 if Nkind (Props) = N_Aggregate then
11685 -- Simple property form
11687 Prop := First (Expressions (Props));
11688 while Present (Prop) loop
11689 Analyze_External_Property (Prop);
11693 -- Property with expression form
11695 Prop := First (Component_Associations (Props));
11696 while Present (Prop) loop
11697 Analyze_External_Property
11698 (Prop => First (Choices (Prop)),
11699 Expr => Expression (Prop));
11707 Analyze_External_Property (Props);
11710 -- An external state defined without any properties defaults
11711 -- all properties to True.
11720 -- Once all external properties have been processed, verify
11721 -- their mutual interaction. Do not perform the check when
11722 -- at least one of the properties is illegal as this will
11723 -- produce a bogus error.
11725 if Errors = Serious_Errors_Detected then
11726 Check_External_Properties
11727 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11729 end Analyze_External_Option;
11731 -------------------------------
11732 -- Analyze_External_Property --
11733 -------------------------------
11735 procedure Analyze_External_Property
11737 Expr : Node_Id := Empty)
11739 Expr_Val : Boolean;
11742 -- Check the placement of "others" (if available)
11744 if Nkind (Prop) = N_Others_Choice then
11745 if Others_Seen then
11747 ("only one others choice allowed in option External",
11750 Others_Seen := True;
11753 elsif Others_Seen then
11755 ("others must be the last property in option External",
11758 -- The only remaining legal options are the four predefined
11759 -- external properties.
11761 elsif Nkind (Prop) = N_Identifier
11762 and then Chars (Prop) in Name_Async_Readers
11763 | Name_Async_Writers
11764 | Name_Effective_Reads
11765 | Name_Effective_Writes
11769 -- Otherwise the construct is not a valid property
11772 SPARK_Msg_N ("invalid external state property", Prop);
11776 -- Ensure that the expression of the external state property
11777 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11779 if Present (Expr) then
11780 Analyze_And_Resolve (Expr, Standard_Boolean);
11782 if Is_OK_Static_Expression (Expr) then
11783 Expr_Val := Is_True (Expr_Value (Expr));
11786 ("expression of external state property must be "
11791 -- The lack of expression defaults the property to True
11797 -- Named properties
11799 if Nkind (Prop) = N_Identifier then
11800 if Chars (Prop) = Name_Async_Readers then
11801 Check_Duplicate_Property (Prop, AR_Seen);
11802 AR_Val := Expr_Val;
11804 elsif Chars (Prop) = Name_Async_Writers then
11805 Check_Duplicate_Property (Prop, AW_Seen);
11806 AW_Val := Expr_Val;
11808 elsif Chars (Prop) = Name_Effective_Reads then
11809 Check_Duplicate_Property (Prop, ER_Seen);
11810 ER_Val := Expr_Val;
11813 Check_Duplicate_Property (Prop, EW_Seen);
11814 EW_Val := Expr_Val;
11817 -- The handling of property "others" must take into account
11818 -- all other named properties that have been encountered so
11819 -- far. Only those that have not been seen are affected by
11823 if not AR_Seen then
11824 AR_Val := Expr_Val;
11827 if not AW_Seen then
11828 AW_Val := Expr_Val;
11831 if not ER_Seen then
11832 ER_Val := Expr_Val;
11835 if not EW_Seen then
11836 EW_Val := Expr_Val;
11839 end Analyze_External_Property;
11841 ----------------------------
11842 -- Analyze_Part_Of_Option --
11843 ----------------------------
11845 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
11846 Encap : constant Node_Id := Expression (Opt);
11847 Constits : Elist_Id;
11848 Encap_Id : Entity_Id;
11852 Check_Duplicate_Option (Opt, Part_Of_Seen);
11855 (Indic => First (Choices (Opt)),
11856 Item_Id => State_Id,
11858 Encap_Id => Encap_Id,
11861 -- The Part_Of indicator transforms the abstract state into
11862 -- a constituent of the encapsulating state or single
11863 -- concurrent type.
11866 pragma Assert (Present (Encap_Id));
11867 Constits := Part_Of_Constituents (Encap_Id);
11869 if No (Constits) then
11870 Constits := New_Elmt_List;
11871 Set_Part_Of_Constituents (Encap_Id, Constits);
11874 Append_Elmt (State_Id, Constits);
11875 Set_Encapsulating_State (State_Id, Encap_Id);
11877 end Analyze_Part_Of_Option;
11879 ----------------------------
11880 -- Check_Duplicate_Option --
11881 ----------------------------
11883 procedure Check_Duplicate_Option
11885 Status : in out Boolean)
11889 SPARK_Msg_N ("duplicate state option", Opt);
11893 end Check_Duplicate_Option;
11895 ------------------------------
11896 -- Check_Duplicate_Property --
11897 ------------------------------
11899 procedure Check_Duplicate_Property
11901 Status : in out Boolean)
11905 SPARK_Msg_N ("duplicate external property", Prop);
11909 end Check_Duplicate_Property;
11911 -----------------------------
11912 -- Check_Ghost_Synchronous --
11913 -----------------------------
11915 procedure Check_Ghost_Synchronous is
11917 -- A synchronized abstract state cannot be Ghost and vice
11918 -- versa (SPARK RM 6.9(19)).
11920 if Ghost_Seen and Synchronous_Seen then
11921 SPARK_Msg_N ("synchronized state cannot be ghost", State);
11923 end Check_Ghost_Synchronous;
11925 ---------------------------
11926 -- Create_Abstract_State --
11927 ---------------------------
11929 procedure Create_Abstract_State
11936 -- The abstract state may be semi-declared when the related
11937 -- package was withed through a limited with clause. In that
11938 -- case reuse the entity to fully declare the state.
11940 if Present (Decl) and then Present (Entity (Decl)) then
11941 State_Id := Entity (Decl);
11943 -- Otherwise the elaboration of pragma Abstract_State
11944 -- declares the state.
11947 State_Id := Make_Defining_Identifier (Loc, Nam);
11949 if Present (Decl) then
11950 Set_Entity (Decl, State_Id);
11954 -- Null states never come from source
11956 Set_Comes_From_Source (State_Id, not Is_Null);
11957 Set_Parent (State_Id, State);
11958 Set_Ekind (State_Id, E_Abstract_State);
11959 Set_Etype (State_Id, Standard_Void_Type);
11960 Set_Encapsulating_State (State_Id, Empty);
11962 -- Set the SPARK mode from the current context
11964 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
11965 Set_SPARK_Pragma_Inherited (State_Id);
11967 -- An abstract state declared within a Ghost region becomes
11968 -- Ghost (SPARK RM 6.9(2)).
11970 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11971 Set_Is_Ghost_Entity (State_Id);
11974 -- Establish a link between the state declaration and the
11975 -- abstract state entity. Note that a null state remains as
11976 -- N_Null and does not carry any linkages.
11978 if not Is_Null then
11979 if Present (Decl) then
11980 Set_Entity (Decl, State_Id);
11981 Set_Etype (Decl, Standard_Void_Type);
11984 -- Every non-null state must be defined, nameable and
11987 Push_Scope (Pack_Id);
11988 Generate_Definition (State_Id);
11989 Enter_Name (State_Id);
11992 end Create_Abstract_State;
11999 -- Start of processing for Analyze_Abstract_State
12002 -- A package with a null abstract state is not allowed to
12003 -- declare additional states.
12007 ("package & has null abstract state", State, Pack_Id);
12009 -- Null states appear as internally generated entities
12011 elsif Nkind (State) = N_Null then
12012 Create_Abstract_State
12013 (Nam => New_Internal_Name ('S'),
12015 Loc => Sloc (State),
12019 -- Catch a case where a null state appears in a list of
12020 -- non-null states.
12022 if Non_Null_Seen then
12024 ("package & has non-null abstract state",
12028 -- Simple state declaration
12030 elsif Nkind (State) = N_Identifier then
12031 Create_Abstract_State
12032 (Nam => Chars (State),
12034 Loc => Sloc (State),
12036 Non_Null_Seen := True;
12038 -- State declaration with various options. This construct
12039 -- appears as an extension aggregate in the tree.
12041 elsif Nkind (State) = N_Extension_Aggregate then
12042 if Nkind (Ancestor_Part (State)) = N_Identifier then
12043 Create_Abstract_State
12044 (Nam => Chars (Ancestor_Part (State)),
12045 Decl => Ancestor_Part (State),
12046 Loc => Sloc (Ancestor_Part (State)),
12048 Non_Null_Seen := True;
12051 ("state name must be an identifier",
12052 Ancestor_Part (State));
12055 -- Options External, Ghost and Synchronous appear as
12058 Opt := First (Expressions (State));
12059 while Present (Opt) loop
12060 if Nkind (Opt) = N_Identifier then
12064 if Chars (Opt) = Name_External then
12065 Check_Duplicate_Option (Opt, External_Seen);
12066 Analyze_External_Option (Opt);
12070 elsif Chars (Opt) = Name_Ghost then
12071 Check_Duplicate_Option (Opt, Ghost_Seen);
12072 Check_Ghost_Synchronous;
12074 if Present (State_Id) then
12075 Set_Is_Ghost_Entity (State_Id);
12080 elsif Chars (Opt) = Name_Synchronous then
12081 Check_Duplicate_Option (Opt, Synchronous_Seen);
12082 Check_Ghost_Synchronous;
12084 -- Relaxed_Initialization
12086 elsif Chars (Opt) = Name_Relaxed_Initialization then
12087 Check_Duplicate_Option
12088 (Opt, Relaxed_Initialization_Seen);
12090 -- Option Part_Of without an encapsulating state is
12091 -- illegal (SPARK RM 7.1.4(8)).
12093 elsif Chars (Opt) = Name_Part_Of then
12095 ("indicator Part_Of must denote abstract state, "
12096 & "single protected type or single task type",
12099 -- Do not emit an error message when a previous state
12100 -- declaration with options was not parenthesized as
12101 -- the option is actually another state declaration.
12103 -- with Abstract_State
12104 -- (State_1 with ..., -- missing parentheses
12105 -- (State_2 with ...),
12106 -- State_3) -- ok state declaration
12108 elsif Missing_Parentheses then
12111 -- Otherwise the option is not allowed. Note that it
12112 -- is not possible to distinguish between an option
12113 -- and a state declaration when a previous state with
12114 -- options not properly parentheses.
12116 -- with Abstract_State
12117 -- (State_1 with ..., -- missing parentheses
12118 -- State_2); -- could be an option
12122 ("simple option not allowed in state declaration",
12126 -- Catch a case where missing parentheses around a state
12127 -- declaration with options cause a subsequent state
12128 -- declaration with options to be treated as an option.
12130 -- with Abstract_State
12131 -- (State_1 with ..., -- missing parentheses
12132 -- (State_2 with ...))
12134 elsif Nkind (Opt) = N_Extension_Aggregate then
12135 Missing_Parentheses := True;
12137 ("state declaration must be parenthesized",
12138 Ancestor_Part (State));
12140 -- Otherwise the option is malformed
12143 SPARK_Msg_N ("malformed option", Opt);
12149 -- Options External and Part_Of appear as component
12152 Opt := First (Component_Associations (State));
12153 while Present (Opt) loop
12154 Opt_Nam := First (Choices (Opt));
12156 if Nkind (Opt_Nam) = N_Identifier then
12157 if Chars (Opt_Nam) = Name_External then
12158 Analyze_External_Option (Opt);
12160 elsif Chars (Opt_Nam) = Name_Part_Of then
12161 Analyze_Part_Of_Option (Opt);
12164 SPARK_Msg_N ("invalid state option", Opt);
12167 SPARK_Msg_N ("invalid state option", Opt);
12173 -- Any other attempt to declare a state is illegal
12176 Malformed_State_Error (State);
12180 -- Guard against a junk state. In such cases no entity is
12181 -- generated and the subsequent checks cannot be applied.
12183 if Present (State_Id) then
12185 -- Verify whether the state does not introduce an illegal
12186 -- hidden state within a package subject to a null abstract
12189 Check_No_Hidden_State (State_Id);
12191 -- Check whether the lack of option Part_Of agrees with the
12192 -- placement of the abstract state with respect to the state
12195 if not Part_Of_Seen then
12196 Check_Missing_Part_Of (State_Id);
12199 -- Associate the state with its related package
12201 if No (Abstract_States (Pack_Id)) then
12202 Set_Abstract_States (Pack_Id, New_Elmt_List);
12205 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12207 end Analyze_Abstract_State;
12209 ---------------------------
12210 -- Malformed_State_Error --
12211 ---------------------------
12213 procedure Malformed_State_Error (State : Node_Id) is
12215 Error_Msg_N ("malformed abstract state declaration", State);
12217 -- An abstract state with a simple option is being declared
12218 -- with "=>" rather than the legal "with". The state appears
12219 -- as a component association.
12221 if Nkind (State) = N_Component_Association then
12222 Error_Msg_N ("\use WITH to specify simple option", State);
12224 end Malformed_State_Error;
12228 Pack_Decl : Node_Id;
12229 Pack_Id : Entity_Id;
12233 -- Start of processing for Abstract_State
12237 Check_No_Identifiers;
12238 Check_Arg_Count (1);
12240 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12242 if Nkind (Pack_Decl) not in
12243 N_Generic_Package_Declaration | N_Package_Declaration
12249 Pack_Id := Defining_Entity (Pack_Decl);
12251 -- A pragma that applies to a Ghost entity becomes Ghost for the
12252 -- purposes of legality checks and removal of ignored Ghost code.
12254 Mark_Ghost_Pragma (N, Pack_Id);
12255 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12257 -- Chain the pragma on the contract for completeness
12259 Add_Contract_Item (N, Pack_Id);
12261 -- The legality checks of pragmas Abstract_State, Initializes, and
12262 -- Initial_Condition are affected by the SPARK mode in effect. In
12263 -- addition, these three pragmas are subject to an inherent order:
12265 -- 1) Abstract_State
12267 -- 3) Initial_Condition
12269 -- Analyze all these pragmas in the order outlined above
12271 Analyze_If_Present (Pragma_SPARK_Mode);
12272 States := Expression (Get_Argument (N, Pack_Id));
12274 -- Multiple non-null abstract states appear as an aggregate
12276 if Nkind (States) = N_Aggregate then
12277 State := First (Expressions (States));
12278 while Present (State) loop
12279 Analyze_Abstract_State (State, Pack_Id);
12283 -- An abstract state with a simple option is being illegaly
12284 -- declared with "=>" rather than "with". In this case the
12285 -- state declaration appears as a component association.
12287 if Present (Component_Associations (States)) then
12288 State := First (Component_Associations (States));
12289 while Present (State) loop
12290 Malformed_State_Error (State);
12295 -- Various forms of a single abstract state. Note that these may
12296 -- include malformed state declarations.
12299 Analyze_Abstract_State (States, Pack_Id);
12302 Analyze_If_Present (Pragma_Initializes);
12303 Analyze_If_Present (Pragma_Initial_Condition);
12304 end Abstract_State;
12312 -- Note: this pragma also has some specific processing in Par.Prag
12313 -- because we want to set the Ada version mode during parsing.
12315 when Pragma_Ada_83 =>
12317 Check_Arg_Count (0);
12319 -- We really should check unconditionally for proper configuration
12320 -- pragma placement, since we really don't want mixed Ada modes
12321 -- within a single unit, and the GNAT reference manual has always
12322 -- said this was a configuration pragma, but we did not check and
12323 -- are hesitant to add the check now.
12325 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12326 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12327 -- or Ada 2012 mode.
12329 if Ada_Version >= Ada_2005 then
12330 Check_Valid_Configuration_Pragma;
12333 -- Now set Ada 83 mode
12335 if Latest_Ada_Only then
12336 Error_Pragma ("??pragma% ignored");
12338 Ada_Version := Ada_83;
12339 Ada_Version_Explicit := Ada_83;
12340 Ada_Version_Pragma := N;
12349 -- Note: this pragma also has some specific processing in Par.Prag
12350 -- because we want to set the Ada 83 version mode during parsing.
12352 when Pragma_Ada_95 =>
12354 Check_Arg_Count (0);
12356 -- We really should check unconditionally for proper configuration
12357 -- pragma placement, since we really don't want mixed Ada modes
12358 -- within a single unit, and the GNAT reference manual has always
12359 -- said this was a configuration pragma, but we did not check and
12360 -- are hesitant to add the check now.
12362 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12363 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12365 if Ada_Version >= Ada_2005 then
12366 Check_Valid_Configuration_Pragma;
12369 -- Now set Ada 95 mode
12371 if Latest_Ada_Only then
12372 Error_Pragma ("??pragma% ignored");
12374 Ada_Version := Ada_95;
12375 Ada_Version_Explicit := Ada_95;
12376 Ada_Version_Pragma := N;
12379 ---------------------
12380 -- Ada_05/Ada_2005 --
12381 ---------------------
12384 -- pragma Ada_05 (LOCAL_NAME);
12386 -- pragma Ada_2005;
12387 -- pragma Ada_2005 (LOCAL_NAME):
12389 -- Note: these pragmas also have some specific processing in Par.Prag
12390 -- because we want to set the Ada 2005 version mode during parsing.
12392 -- The one argument form is used for managing the transition from
12393 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12394 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12395 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12396 -- mode, a preference rule is established which does not choose
12397 -- such an entity unless it is unambiguously specified. This avoids
12398 -- extra subprograms marked this way from generating ambiguities in
12399 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12400 -- intended for exclusive use in the GNAT run-time library.
12411 if Arg_Count = 1 then
12412 Check_Arg_Is_Local_Name (Arg1);
12413 E_Id := Get_Pragma_Arg (Arg1);
12415 if Etype (E_Id) = Any_Type then
12419 Set_Is_Ada_2005_Only (Entity (E_Id));
12420 Record_Rep_Item (Entity (E_Id), N);
12423 Check_Arg_Count (0);
12425 -- For Ada_2005 we unconditionally enforce the documented
12426 -- configuration pragma placement, since we do not want to
12427 -- tolerate mixed modes in a unit involving Ada 2005. That
12428 -- would cause real difficulties for those cases where there
12429 -- are incompatibilities between Ada 95 and Ada 2005.
12431 Check_Valid_Configuration_Pragma;
12433 -- Now set appropriate Ada mode
12435 if Latest_Ada_Only then
12436 Error_Pragma ("??pragma% ignored");
12438 Ada_Version := Ada_2005;
12439 Ada_Version_Explicit := Ada_2005;
12440 Ada_Version_Pragma := N;
12445 ---------------------
12446 -- Ada_12/Ada_2012 --
12447 ---------------------
12450 -- pragma Ada_12 (LOCAL_NAME);
12452 -- pragma Ada_2012;
12453 -- pragma Ada_2012 (LOCAL_NAME):
12455 -- Note: these pragmas also have some specific processing in Par.Prag
12456 -- because we want to set the Ada 2012 version mode during parsing.
12458 -- The one argument form is used for managing the transition from Ada
12459 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12460 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12461 -- mode will generate a warning. In addition, in any pre-Ada_2012
12462 -- mode, a preference rule is established which does not choose
12463 -- such an entity unless it is unambiguously specified. This avoids
12464 -- extra subprograms marked this way from generating ambiguities in
12465 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12466 -- intended for exclusive use in the GNAT run-time library.
12477 if Arg_Count = 1 then
12478 Check_Arg_Is_Local_Name (Arg1);
12479 E_Id := Get_Pragma_Arg (Arg1);
12481 if Etype (E_Id) = Any_Type then
12485 Set_Is_Ada_2012_Only (Entity (E_Id));
12486 Record_Rep_Item (Entity (E_Id), N);
12489 Check_Arg_Count (0);
12491 -- For Ada_2012 we unconditionally enforce the documented
12492 -- configuration pragma placement, since we do not want to
12493 -- tolerate mixed modes in a unit involving Ada 2012. That
12494 -- would cause real difficulties for those cases where there
12495 -- are incompatibilities between Ada 95 and Ada 2012. We could
12496 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12498 Check_Valid_Configuration_Pragma;
12500 -- Now set appropriate Ada mode
12502 Ada_Version := Ada_2012;
12503 Ada_Version_Explicit := Ada_2012;
12504 Ada_Version_Pragma := N;
12512 -- pragma Ada_2020;
12514 -- Note: this pragma also has some specific processing in Par.Prag
12515 -- because we want to set the Ada 2020 version mode during parsing.
12517 when Pragma_Ada_2020 =>
12520 Check_Arg_Count (0);
12522 Check_Valid_Configuration_Pragma;
12524 -- Now set appropriate Ada mode
12526 Ada_Version := Ada_2020;
12527 Ada_Version_Explicit := Ada_2020;
12528 Ada_Version_Pragma := N;
12530 -------------------------------------
12531 -- Aggregate_Individually_Assign --
12532 -------------------------------------
12534 -- pragma Aggregate_Individually_Assign;
12536 when Pragma_Aggregate_Individually_Assign =>
12538 Check_Arg_Count (0);
12539 Check_Valid_Configuration_Pragma;
12540 Aggregate_Individually_Assign := True;
12542 ----------------------
12543 -- All_Calls_Remote --
12544 ----------------------
12546 -- pragma All_Calls_Remote [(library_package_NAME)];
12548 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
12549 Lib_Entity : Entity_Id;
12552 Check_Ada_83_Warning;
12553 Check_Valid_Library_Unit_Pragma;
12555 Lib_Entity := Find_Lib_Unit_Name;
12557 -- A pragma that applies to a Ghost entity becomes Ghost for the
12558 -- purposes of legality checks and removal of ignored Ghost code.
12560 Mark_Ghost_Pragma (N, Lib_Entity);
12562 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12564 if Present (Lib_Entity) and then not Debug_Flag_U then
12565 if not Is_Remote_Call_Interface (Lib_Entity) then
12566 Error_Pragma ("pragma% only apply to rci unit");
12568 -- Set flag for entity of the library unit
12571 Set_Has_All_Calls_Remote (Lib_Entity);
12574 end All_Calls_Remote;
12576 ---------------------------
12577 -- Allow_Integer_Address --
12578 ---------------------------
12580 -- pragma Allow_Integer_Address;
12582 when Pragma_Allow_Integer_Address =>
12584 Check_Valid_Configuration_Pragma;
12585 Check_Arg_Count (0);
12587 -- If Address is a private type, then set the flag to allow
12588 -- integer address values. If Address is not private, then this
12589 -- pragma has no purpose, so it is simply ignored. Not clear if
12590 -- there are any such targets now.
12592 if Opt.Address_Is_Private then
12593 Opt.Allow_Integer_Address := True;
12601 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12602 -- ARG ::= NAME | EXPRESSION
12604 -- The first two arguments are by convention intended to refer to an
12605 -- external tool and a tool-specific function. These arguments are
12608 when Pragma_Annotate => Annotate : declare
12613 --------------------------
12614 -- Inferred_String_Type --
12615 --------------------------
12617 function Preferred_String_Type (Expr : Node_Id) return Entity_Id;
12618 -- Infer the type to use for a string literal or a concatentation
12619 -- of operands whose types can be inferred. For such expressions,
12620 -- returns the "narrowest" of the three predefined string types
12621 -- that can represent the characters occurring in the expression.
12622 -- For other expressions, returns Empty.
12624 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
12626 case Nkind (Expr) is
12627 when N_String_Literal =>
12628 if Has_Wide_Wide_Character (Expr) then
12629 return Standard_Wide_Wide_String;
12630 elsif Has_Wide_Character (Expr) then
12631 return Standard_Wide_String;
12633 return Standard_String;
12636 when N_Op_Concat =>
12638 L_Type : constant Entity_Id
12639 := Preferred_String_Type (Left_Opnd (Expr));
12640 R_Type : constant Entity_Id
12641 := Preferred_String_Type (Right_Opnd (Expr));
12643 Type_Table : constant array (1 .. 4) of Entity_Id
12645 Standard_Wide_Wide_String,
12646 Standard_Wide_String,
12649 for Idx in Type_Table'Range loop
12650 if (L_Type = Type_Table (Idx)) or
12651 (R_Type = Type_Table (Idx))
12653 return Type_Table (Idx);
12656 raise Program_Error;
12662 end Preferred_String_Type;
12665 Check_At_Least_N_Arguments (1);
12667 Nam_Arg := Last (Pragma_Argument_Associations (N));
12669 -- Determine whether the last argument is "Entity => local_NAME"
12670 -- and if it is, perform the required semantic checks. Remove the
12671 -- argument from further processing.
12673 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
12674 and then Chars (Nam_Arg) = Name_Entity
12676 Check_Arg_Is_Local_Name (Nam_Arg);
12677 Arg_Count := Arg_Count - 1;
12679 -- A pragma that applies to a Ghost entity becomes Ghost for
12680 -- the purposes of legality checks and removal of ignored Ghost
12683 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
12684 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
12686 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
12689 -- Not allowed in compiler units (bootstrap issues)
12691 Check_Compiler_Unit ("Entity for pragma Annotate", N);
12694 -- Continue the processing with last argument removed for now
12696 Check_Arg_Is_Identifier (Arg1);
12697 Check_No_Identifiers;
12700 -- The second parameter is optional, it is never analyzed
12705 -- Otherwise there is a second parameter
12708 -- The second parameter must be an identifier
12710 Check_Arg_Is_Identifier (Arg2);
12712 -- Process the remaining parameters (if any)
12714 Arg := Next (Arg2);
12715 while Present (Arg) loop
12716 Expr := Get_Pragma_Arg (Arg);
12719 if Is_Entity_Name (Expr) then
12722 -- For string literals and concatenations of string literals
12723 -- we assume Standard_String as the type, unless the string
12724 -- contains wide or wide_wide characters.
12726 elsif Present (Preferred_String_Type (Expr)) then
12727 Resolve (Expr, Preferred_String_Type (Expr));
12729 elsif Is_Overloaded (Expr) then
12730 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
12741 -------------------------------------------------
12742 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12743 -------------------------------------------------
12746 -- ( [Check => ] Boolean_EXPRESSION
12747 -- [, [Message =>] Static_String_EXPRESSION]);
12749 -- pragma Assert_And_Cut
12750 -- ( [Check => ] Boolean_EXPRESSION
12751 -- [, [Message =>] Static_String_EXPRESSION]);
12754 -- ( [Check => ] Boolean_EXPRESSION
12755 -- [, [Message =>] Static_String_EXPRESSION]);
12757 -- pragma Loop_Invariant
12758 -- ( [Check => ] Boolean_EXPRESSION
12759 -- [, [Message =>] Static_String_EXPRESSION]);
12762 | Pragma_Assert_And_Cut
12764 | Pragma_Loop_Invariant
12767 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
12768 -- Determine whether expression Expr contains a Loop_Entry
12769 -- attribute reference.
12771 -------------------------
12772 -- Contains_Loop_Entry --
12773 -------------------------
12775 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
12776 Has_Loop_Entry : Boolean := False;
12778 function Process (N : Node_Id) return Traverse_Result;
12779 -- Process function for traversal to look for Loop_Entry
12785 function Process (N : Node_Id) return Traverse_Result is
12787 if Nkind (N) = N_Attribute_Reference
12788 and then Attribute_Name (N) = Name_Loop_Entry
12790 Has_Loop_Entry := True;
12797 procedure Traverse is new Traverse_Proc (Process);
12799 -- Start of processing for Contains_Loop_Entry
12803 return Has_Loop_Entry;
12804 end Contains_Loop_Entry;
12809 New_Args : List_Id;
12811 -- Start of processing for Assert
12814 -- Assert is an Ada 2005 RM-defined pragma
12816 if Prag_Id = Pragma_Assert then
12819 -- The remaining ones are GNAT pragmas
12825 Check_At_Least_N_Arguments (1);
12826 Check_At_Most_N_Arguments (2);
12827 Check_Arg_Order ((Name_Check, Name_Message));
12828 Check_Optional_Identifier (Arg1, Name_Check);
12829 Expr := Get_Pragma_Arg (Arg1);
12831 -- Special processing for Loop_Invariant, Loop_Variant or for
12832 -- other cases where a Loop_Entry attribute is present. If the
12833 -- assertion pragma contains attribute Loop_Entry, ensure that
12834 -- the related pragma is within a loop.
12836 if Prag_Id = Pragma_Loop_Invariant
12837 or else Prag_Id = Pragma_Loop_Variant
12838 or else Contains_Loop_Entry (Expr)
12840 Check_Loop_Pragma_Placement;
12842 -- Perform preanalysis to deal with embedded Loop_Entry
12845 Preanalyze_Assert_Expression (Expr, Any_Boolean);
12848 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12849 -- a corresponding Check pragma:
12851 -- pragma Check (name, condition [, msg]);
12853 -- Where name is the identifier matching the pragma name. So
12854 -- rewrite pragma in this manner, transfer the message argument
12855 -- if present, and analyze the result
12857 -- Note: When dealing with a semantically analyzed tree, the
12858 -- information that a Check node N corresponds to a source Assert,
12859 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12860 -- pragma kind of Original_Node(N).
12862 New_Args := New_List (
12863 Make_Pragma_Argument_Association (Loc,
12864 Expression => Make_Identifier (Loc, Pname)),
12865 Make_Pragma_Argument_Association (Sloc (Expr),
12866 Expression => Expr));
12868 if Arg_Count > 1 then
12869 Check_Optional_Identifier (Arg2, Name_Message);
12871 -- Provide semantic annotations for optional argument, for
12872 -- ASIS use, before rewriting.
12873 -- Is this still needed???
12875 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
12876 Append_To (New_Args, New_Copy_Tree (Arg2));
12879 -- Rewrite as Check pragma
12883 Chars => Name_Check,
12884 Pragma_Argument_Associations => New_Args));
12889 ----------------------
12890 -- Assertion_Policy --
12891 ----------------------
12893 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12895 -- The following form is Ada 2012 only, but we allow it in all modes
12897 -- Pragma Assertion_Policy (
12898 -- ASSERTION_KIND => POLICY_IDENTIFIER
12899 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12901 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12903 -- RM_ASSERTION_KIND ::= Assert |
12904 -- Static_Predicate |
12905 -- Dynamic_Predicate |
12910 -- Type_Invariant |
12911 -- Type_Invariant'Class
12913 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12915 -- Contract_Cases |
12917 -- Default_Initial_Condition |
12919 -- Initial_Condition |
12920 -- Loop_Invariant |
12926 -- Statement_Assertions
12928 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12929 -- ID_ASSERTION_KIND list contains implementation-defined additions
12930 -- recognized by GNAT. The effect is to control the behavior of
12931 -- identically named aspects and pragmas, depending on the specified
12932 -- policy identifier:
12934 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12936 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12937 -- implementation-defined addition that results in totally ignoring
12938 -- the corresponding assertion. If Disable is specified, then the
12939 -- argument of the assertion is not even analyzed. This is useful
12940 -- when the aspect/pragma argument references entities in a with'ed
12941 -- package that is replaced by a dummy package in the final build.
12943 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12944 -- and Type_Invariant'Class were recognized by the parser and
12945 -- transformed into references to the special internal identifiers
12946 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12947 -- processing is required here.
12949 when Pragma_Assertion_Policy => Assertion_Policy : declare
12950 procedure Resolve_Suppressible (Policy : Node_Id);
12951 -- Converts the assertion policy 'Suppressible' to either Check or
12952 -- Ignore based on whether checks are suppressed via -gnatp.
12954 --------------------------
12955 -- Resolve_Suppressible --
12956 --------------------------
12958 procedure Resolve_Suppressible (Policy : Node_Id) is
12959 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
12963 -- Transform policy argument Suppressible into either Ignore or
12964 -- Check depending on whether checks are enabled or suppressed.
12966 if Chars (Arg) = Name_Suppressible then
12967 if Suppress_Checks then
12968 Nam := Name_Ignore;
12973 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
12975 end Resolve_Suppressible;
12987 -- This can always appear as a configuration pragma
12989 if Is_Configuration_Pragma then
12992 -- It can also appear in a declarative part or package spec in Ada
12993 -- 2012 mode. We allow this in other modes, but in that case we
12994 -- consider that we have an Ada 2012 pragma on our hands.
12997 Check_Is_In_Decl_Part_Or_Package_Spec;
13001 -- One argument case with no identifier (first form above)
13004 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13005 or else Chars (Arg1) = No_Name)
13007 Check_Arg_Is_One_Of (Arg1,
13008 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13010 Resolve_Suppressible (Arg1);
13012 -- Treat one argument Assertion_Policy as equivalent to:
13014 -- pragma Check_Policy (Assertion, policy)
13016 -- So rewrite pragma in that manner and link on to the chain
13017 -- of Check_Policy pragmas, marking the pragma as analyzed.
13019 Policy := Get_Pragma_Arg (Arg1);
13023 Chars => Name_Check_Policy,
13024 Pragma_Argument_Associations => New_List (
13025 Make_Pragma_Argument_Association (Loc,
13026 Expression => Make_Identifier (Loc, Name_Assertion)),
13028 Make_Pragma_Argument_Association (Loc,
13030 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13033 -- Here if we have two or more arguments
13036 Check_At_Least_N_Arguments (1);
13039 -- Loop through arguments
13042 while Present (Arg) loop
13043 LocP := Sloc (Arg);
13045 -- Kind must be specified
13047 if Nkind (Arg) /= N_Pragma_Argument_Association
13048 or else Chars (Arg) = No_Name
13051 ("missing assertion kind for pragma%", Arg);
13054 -- Check Kind and Policy have allowed forms
13056 Kind := Chars (Arg);
13057 Policy := Get_Pragma_Arg (Arg);
13059 if not Is_Valid_Assertion_Kind (Kind) then
13061 ("invalid assertion kind for pragma%", Arg);
13064 Check_Arg_Is_One_Of (Arg,
13065 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13067 Resolve_Suppressible (Arg);
13069 if Kind = Name_Ghost then
13071 -- The Ghost policy must be either Check or Ignore
13072 -- (SPARK RM 6.9(6)).
13074 if Chars (Policy) not in Name_Check | Name_Ignore then
13076 ("argument of pragma % Ghost must be Check or "
13077 & "Ignore", Policy);
13080 -- Pragma Assertion_Policy specifying a Ghost policy
13081 -- cannot occur within a Ghost subprogram or package
13082 -- (SPARK RM 6.9(14)).
13084 if Ghost_Mode > None then
13086 ("pragma % cannot appear within ghost subprogram or "
13091 -- Rewrite the Assertion_Policy pragma as a series of
13092 -- Check_Policy pragmas of the form:
13094 -- Check_Policy (Kind, Policy);
13096 -- Note: the insertion of the pragmas cannot be done with
13097 -- Insert_Action because in the configuration case, there
13098 -- are no scopes on the scope stack and the mechanism will
13101 Insert_Before_And_Analyze (N,
13103 Chars => Name_Check_Policy,
13104 Pragma_Argument_Associations => New_List (
13105 Make_Pragma_Argument_Association (LocP,
13106 Expression => Make_Identifier (LocP, Kind)),
13107 Make_Pragma_Argument_Association (LocP,
13108 Expression => Policy))));
13113 -- Rewrite the Assertion_Policy pragma as null since we have
13114 -- now inserted all the equivalent Check pragmas.
13116 Rewrite (N, Make_Null_Statement (Loc));
13119 end Assertion_Policy;
13121 ------------------------------
13122 -- Assume_No_Invalid_Values --
13123 ------------------------------
13125 -- pragma Assume_No_Invalid_Values (On | Off);
13127 when Pragma_Assume_No_Invalid_Values =>
13129 Check_Valid_Configuration_Pragma;
13130 Check_Arg_Count (1);
13131 Check_No_Identifiers;
13132 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13134 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13135 Assume_No_Invalid_Values := True;
13137 Assume_No_Invalid_Values := False;
13140 --------------------------
13141 -- Attribute_Definition --
13142 --------------------------
13144 -- pragma Attribute_Definition
13145 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13146 -- [Entity =>] LOCAL_NAME,
13147 -- [Expression =>] EXPRESSION | NAME);
13149 when Pragma_Attribute_Definition => Attribute_Definition : declare
13150 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13155 Check_Arg_Count (3);
13156 Check_Optional_Identifier (Arg1, "attribute");
13157 Check_Optional_Identifier (Arg2, "entity");
13158 Check_Optional_Identifier (Arg3, "expression");
13160 if Nkind (Attribute_Designator) /= N_Identifier then
13161 Error_Msg_N ("attribute name expected", Attribute_Designator);
13165 Check_Arg_Is_Local_Name (Arg2);
13167 -- If the attribute is not recognized, then issue a warning (not
13168 -- an error), and ignore the pragma.
13170 Aname := Chars (Attribute_Designator);
13172 if not Is_Attribute_Name (Aname) then
13173 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13177 -- Otherwise, rewrite the pragma as an attribute definition clause
13180 Make_Attribute_Definition_Clause (Loc,
13181 Name => Get_Pragma_Arg (Arg2),
13183 Expression => Get_Pragma_Arg (Arg3)));
13185 end Attribute_Definition;
13187 ------------------------------------------------------------------
13188 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13190 ------------------------------------------------------------------
13192 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13193 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13194 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13195 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13196 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13198 when Pragma_Async_Readers
13199 | Pragma_Async_Writers
13200 | Pragma_Effective_Reads
13201 | Pragma_Effective_Writes
13202 | Pragma_No_Caching
13204 Async_Effective : declare
13205 Obj_Or_Type_Decl : Node_Id;
13206 Obj_Or_Type_Id : Entity_Id;
13209 Check_No_Identifiers;
13210 Check_At_Most_N_Arguments (1);
13212 Obj_Or_Type_Decl := Find_Related_Context (N, Do_Checks => True);
13214 -- Pragma must apply to a object declaration or to a type
13215 -- declaration (only the former in the No_Caching case).
13216 -- Original_Node is necessary to account for untagged derived
13217 -- types that are rewritten as subtypes of their
13218 -- respective root types.
13220 if Nkind (Obj_Or_Type_Decl) /= N_Object_Declaration then
13221 if Prag_Id = Pragma_No_Caching
13222 or else Nkind (Original_Node (Obj_Or_Type_Decl)) not in
13223 N_Full_Type_Declaration |
13224 N_Private_Type_Declaration |
13225 N_Formal_Type_Declaration |
13226 N_Task_Type_Declaration |
13227 N_Protected_Type_Declaration
13234 Obj_Or_Type_Id := Defining_Entity (Obj_Or_Type_Decl);
13236 -- Perform minimal verification to ensure that the argument is at
13237 -- least a variable or a type. Subsequent finer grained checks
13238 -- will be done at the end of the declarative region that
13239 -- contains the pragma.
13241 if Ekind (Obj_Or_Type_Id) = E_Variable
13242 or else Is_Type (Obj_Or_Type_Id)
13245 -- In the case of a type, pragma is a type-related
13246 -- representation item and so requires checks common to
13247 -- all type-related representation items.
13249 if Is_Type (Obj_Or_Type_Id)
13250 and then Rep_Item_Too_Late (Obj_Or_Type_Id, N)
13255 -- A pragma that applies to a Ghost entity becomes Ghost for
13256 -- the purposes of legality checks and removal of ignored Ghost
13259 Mark_Ghost_Pragma (N, Obj_Or_Type_Id);
13261 -- Chain the pragma on the contract for further processing by
13262 -- Analyze_External_Property_In_Decl_Part.
13264 Add_Contract_Item (N, Obj_Or_Type_Id);
13266 -- Analyze the Boolean expression (if any)
13268 if Present (Arg1) then
13269 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13272 -- Otherwise the external property applies to a constant
13276 ("pragma % must apply to a volatile type or object");
13278 end Async_Effective;
13284 -- pragma Asynchronous (LOCAL_NAME);
13286 when Pragma_Asynchronous => Asynchronous : declare
13289 Formal : Entity_Id;
13294 procedure Process_Async_Pragma;
13295 -- Common processing for procedure and access-to-procedure case
13297 --------------------------
13298 -- Process_Async_Pragma --
13299 --------------------------
13301 procedure Process_Async_Pragma is
13304 Set_Is_Asynchronous (Nm);
13308 -- The formals should be of mode IN (RM E.4.1(6))
13311 while Present (S) loop
13312 Formal := Defining_Identifier (S);
13314 if Nkind (Formal) = N_Defining_Identifier
13315 and then Ekind (Formal) /= E_In_Parameter
13318 ("pragma% procedure can only have IN parameter",
13325 Set_Is_Asynchronous (Nm);
13326 end Process_Async_Pragma;
13328 -- Start of processing for pragma Asynchronous
13331 Check_Ada_83_Warning;
13332 Check_No_Identifiers;
13333 Check_Arg_Count (1);
13334 Check_Arg_Is_Local_Name (Arg1);
13336 if Debug_Flag_U then
13340 C_Ent := Cunit_Entity (Current_Sem_Unit);
13341 Analyze (Get_Pragma_Arg (Arg1));
13342 Nm := Entity (Get_Pragma_Arg (Arg1));
13344 -- A pragma that applies to a Ghost entity becomes Ghost for the
13345 -- purposes of legality checks and removal of ignored Ghost code.
13347 Mark_Ghost_Pragma (N, Nm);
13349 if not Is_Remote_Call_Interface (C_Ent)
13350 and then not Is_Remote_Types (C_Ent)
13352 -- This pragma should only appear in an RCI or Remote Types
13353 -- unit (RM E.4.1(4)).
13356 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13359 if Ekind (Nm) = E_Procedure
13360 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13362 if not Is_Remote_Call_Interface (Nm) then
13364 ("pragma% cannot be applied on non-remote procedure",
13368 L := Parameter_Specifications (Parent (Nm));
13369 Process_Async_Pragma;
13372 elsif Ekind (Nm) = E_Function then
13374 ("pragma% cannot be applied to function", Arg1);
13376 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13377 if Is_Record_Type (Nm) then
13379 -- A record type that is the Equivalent_Type for a remote
13380 -- access-to-subprogram type.
13382 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13385 -- A non-expanded RAS type (distribution is not enabled)
13387 Decl := Declaration_Node (Nm);
13390 if Nkind (Decl) = N_Full_Type_Declaration
13391 and then Nkind (Type_Definition (Decl)) =
13392 N_Access_Procedure_Definition
13394 L := Parameter_Specifications (Type_Definition (Decl));
13395 Process_Async_Pragma;
13397 if Is_Asynchronous (Nm)
13398 and then Expander_Active
13399 and then Get_PCS_Name /= Name_No_DSA
13401 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13406 ("pragma% cannot reference access-to-function type",
13410 -- Only other possibility is Access-to-class-wide type
13412 elsif Is_Access_Type (Nm)
13413 and then Is_Class_Wide_Type (Designated_Type (Nm))
13415 Check_First_Subtype (Arg1);
13416 Set_Is_Asynchronous (Nm);
13417 if Expander_Active then
13418 RACW_Type_Is_Asynchronous (Nm);
13422 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13430 -- pragma Atomic (LOCAL_NAME);
13432 when Pragma_Atomic =>
13433 Process_Atomic_Independent_Shared_Volatile;
13435 -----------------------
13436 -- Atomic_Components --
13437 -----------------------
13439 -- pragma Atomic_Components (array_LOCAL_NAME);
13441 -- This processing is shared by Volatile_Components
13443 when Pragma_Atomic_Components
13444 | Pragma_Volatile_Components
13446 Atomic_Components : declare
13452 Check_Ada_83_Warning;
13453 Check_No_Identifiers;
13454 Check_Arg_Count (1);
13455 Check_Arg_Is_Local_Name (Arg1);
13456 E_Id := Get_Pragma_Arg (Arg1);
13458 if Etype (E_Id) = Any_Type then
13462 E := Entity (E_Id);
13464 -- A pragma that applies to a Ghost entity becomes Ghost for the
13465 -- purposes of legality checks and removal of ignored Ghost code.
13467 Mark_Ghost_Pragma (N, E);
13468 Check_Duplicate_Pragma (E);
13470 if Rep_Item_Too_Early (E, N)
13472 Rep_Item_Too_Late (E, N)
13477 D := Declaration_Node (E);
13479 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
13481 (Nkind (D) = N_Object_Declaration
13482 and then Ekind (E) in E_Constant | E_Variable
13483 and then Nkind (Object_Definition (D)) =
13484 N_Constrained_Array_Definition)
13486 (Ada_Version >= Ada_2020
13487 and then Nkind (D) = N_Formal_Type_Declaration)
13489 -- The flag is set on the base type, or on the object
13491 if Nkind (D) = N_Full_Type_Declaration then
13492 E := Base_Type (E);
13495 -- Atomic implies both Independent and Volatile
13497 if Prag_Id = Pragma_Atomic_Components then
13498 Set_Has_Atomic_Components (E);
13499 Set_Has_Independent_Components (E);
13502 Set_Has_Volatile_Components (E);
13505 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13507 end Atomic_Components;
13509 --------------------
13510 -- Attach_Handler --
13511 --------------------
13513 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13515 when Pragma_Attach_Handler =>
13516 Check_Ada_83_Warning;
13517 Check_No_Identifiers;
13518 Check_Arg_Count (2);
13520 if No_Run_Time_Mode then
13521 Error_Msg_CRT ("Attach_Handler pragma", N);
13523 Check_Interrupt_Or_Attach_Handler;
13525 -- The expression that designates the attribute may depend on a
13526 -- discriminant, and is therefore a per-object expression, to
13527 -- be expanded in the init proc. If expansion is enabled, then
13528 -- perform semantic checks on a copy only.
13533 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13536 -- In Relaxed_RM_Semantics mode, we allow any static
13537 -- integer value, for compatibility with other compilers.
13539 if Relaxed_RM_Semantics
13540 and then Nkind (Parg2) = N_Integer_Literal
13542 Typ := Standard_Integer;
13544 Typ := RTE (RE_Interrupt_ID);
13547 if Expander_Active then
13548 Temp := New_Copy_Tree (Parg2);
13549 Set_Parent (Temp, N);
13550 Preanalyze_And_Resolve (Temp, Typ);
13553 Resolve (Parg2, Typ);
13557 Process_Interrupt_Or_Attach_Handler;
13560 --------------------
13561 -- C_Pass_By_Copy --
13562 --------------------
13564 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13566 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13572 Check_Valid_Configuration_Pragma;
13573 Check_Arg_Count (1);
13574 Check_Optional_Identifier (Arg1, "max_size");
13576 Arg := Get_Pragma_Arg (Arg1);
13577 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
13579 Val := Expr_Value (Arg);
13583 ("maximum size for pragma% must be positive", Arg1);
13585 elsif UI_Is_In_Int_Range (Val) then
13586 Default_C_Record_Mechanism := UI_To_Int (Val);
13588 -- If a giant value is given, Int'Last will do well enough.
13589 -- If sometime someone complains that a record larger than
13590 -- two gigabytes is not copied, we will worry about it then.
13593 Default_C_Record_Mechanism := Mechanism_Type'Last;
13595 end C_Pass_By_Copy;
13601 -- pragma Check ([Name =>] CHECK_KIND,
13602 -- [Check =>] Boolean_EXPRESSION
13603 -- [,[Message =>] String_EXPRESSION]);
13605 -- CHECK_KIND ::= IDENTIFIER |
13608 -- Invariant'Class |
13609 -- Type_Invariant'Class
13611 -- The identifiers Assertions and Statement_Assertions are not
13612 -- allowed, since they have special meaning for Check_Policy.
13614 -- WARNING: The code below manages Ghost regions. Return statements
13615 -- must be replaced by gotos which jump to the end of the code and
13616 -- restore the Ghost mode.
13618 when Pragma_Check => Check : declare
13619 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
13620 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
13621 -- Save the Ghost-related attributes to restore on exit
13627 pragma Warnings (Off, Str);
13630 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13631 -- the mode now to ensure that any nodes generated during analysis
13632 -- and expansion are marked as Ghost.
13634 Set_Ghost_Mode (N);
13637 Check_At_Least_N_Arguments (2);
13638 Check_At_Most_N_Arguments (3);
13639 Check_Optional_Identifier (Arg1, Name_Name);
13640 Check_Optional_Identifier (Arg2, Name_Check);
13642 if Arg_Count = 3 then
13643 Check_Optional_Identifier (Arg3, Name_Message);
13644 Str := Get_Pragma_Arg (Arg3);
13647 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
13648 Check_Arg_Is_Identifier (Arg1);
13649 Cname := Chars (Get_Pragma_Arg (Arg1));
13651 -- Check forbidden name Assertions or Statement_Assertions
13654 when Name_Assertions =>
13656 ("""Assertions"" is not allowed as a check kind for "
13657 & "pragma%", Arg1);
13659 when Name_Statement_Assertions =>
13661 ("""Statement_Assertions"" is not allowed as a check kind "
13662 & "for pragma%", Arg1);
13668 -- Check applicable policy. We skip this if Checked/Ignored status
13669 -- is already set (e.g. in the case of a pragma from an aspect).
13671 if Is_Checked (N) or else Is_Ignored (N) then
13674 -- For a non-source pragma that is a rewriting of another pragma,
13675 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13677 elsif Is_Rewrite_Substitution (N)
13678 and then Nkind (Original_Node (N)) = N_Pragma
13680 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
13681 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
13683 -- Otherwise query the applicable policy at this point
13686 case Check_Kind (Cname) is
13687 when Name_Ignore =>
13688 Set_Is_Ignored (N, True);
13689 Set_Is_Checked (N, False);
13692 Set_Is_Ignored (N, False);
13693 Set_Is_Checked (N, True);
13695 -- For disable, rewrite pragma as null statement and skip
13696 -- rest of the analysis of the pragma.
13698 when Name_Disable =>
13699 Rewrite (N, Make_Null_Statement (Loc));
13703 -- No other possibilities
13706 raise Program_Error;
13710 -- If check kind was not Disable, then continue pragma analysis
13712 Expr := Get_Pragma_Arg (Arg2);
13714 -- Mark the pragma (or, if rewritten from an aspect, the original
13715 -- aspect) as enabled. Nothing to do for an internally generated
13716 -- check for a dynamic predicate.
13719 and then not Split_PPC (N)
13720 and then Cname /= Name_Dynamic_Predicate
13722 Set_SCO_Pragma_Enabled (Loc);
13725 -- Deal with analyzing the string argument. If checks are not
13726 -- on we don't want any expansion (since such expansion would
13727 -- not get properly deleted) but we do want to analyze (to get
13728 -- proper references). The Preanalyze_And_Resolve routine does
13729 -- just what we want. Ditto if pragma is active, because it will
13730 -- be rewritten as an if-statement whose analysis will complete
13731 -- analysis and expansion of the string message. This makes a
13732 -- difference in the unusual case where the expression for the
13733 -- string may have a side effect, such as raising an exception.
13734 -- This is mandated by RM 11.4.2, which specifies that the string
13735 -- expression is only evaluated if the check fails and
13736 -- Assertion_Error is to be raised.
13738 if Arg_Count = 3 then
13739 Preanalyze_And_Resolve (Str, Standard_String);
13742 -- Now you might think we could just do the same with the Boolean
13743 -- expression if checks are off (and expansion is on) and then
13744 -- rewrite the check as a null statement. This would work but we
13745 -- would lose the useful warnings about an assertion being bound
13746 -- to fail even if assertions are turned off.
13748 -- So instead we wrap the boolean expression in an if statement
13749 -- that looks like:
13751 -- if False and then condition then
13755 -- The reason we do this rewriting during semantic analysis rather
13756 -- than as part of normal expansion is that we cannot analyze and
13757 -- expand the code for the boolean expression directly, or it may
13758 -- cause insertion of actions that would escape the attempt to
13759 -- suppress the check code.
13761 -- Note that the Sloc for the if statement corresponds to the
13762 -- argument condition, not the pragma itself. The reason for
13763 -- this is that we may generate a warning if the condition is
13764 -- False at compile time, and we do not want to delete this
13765 -- warning when we delete the if statement.
13767 if Expander_Active and Is_Ignored (N) then
13768 Eloc := Sloc (Expr);
13771 Make_If_Statement (Eloc,
13773 Make_And_Then (Eloc,
13774 Left_Opnd => Make_Identifier (Eloc, Name_False),
13775 Right_Opnd => Expr),
13776 Then_Statements => New_List (
13777 Make_Null_Statement (Eloc))));
13779 -- Now go ahead and analyze the if statement
13781 In_Assertion_Expr := In_Assertion_Expr + 1;
13783 -- One rather special treatment. If we are now in Eliminated
13784 -- overflow mode, then suppress overflow checking since we do
13785 -- not want to drag in the bignum stuff if we are in Ignore
13786 -- mode anyway. This is particularly important if we are using
13787 -- a configurable run time that does not support bignum ops.
13789 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
13791 Svo : constant Boolean :=
13792 Scope_Suppress.Suppress (Overflow_Check);
13794 Scope_Suppress.Overflow_Mode_Assertions := Strict;
13795 Scope_Suppress.Suppress (Overflow_Check) := True;
13797 Scope_Suppress.Suppress (Overflow_Check) := Svo;
13798 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
13801 -- Not that special case
13807 -- All done with this check
13809 In_Assertion_Expr := In_Assertion_Expr - 1;
13811 -- Check is active or expansion not active. In these cases we can
13812 -- just go ahead and analyze the boolean with no worries.
13815 In_Assertion_Expr := In_Assertion_Expr + 1;
13816 Analyze_And_Resolve (Expr, Any_Boolean);
13817 In_Assertion_Expr := In_Assertion_Expr - 1;
13820 Restore_Ghost_Region (Saved_GM, Saved_IGR);
13823 --------------------------
13824 -- Check_Float_Overflow --
13825 --------------------------
13827 -- pragma Check_Float_Overflow;
13829 when Pragma_Check_Float_Overflow =>
13831 Check_Valid_Configuration_Pragma;
13832 Check_Arg_Count (0);
13833 Check_Float_Overflow := not Machine_Overflows_On_Target;
13839 -- pragma Check_Name (check_IDENTIFIER);
13841 when Pragma_Check_Name =>
13843 Check_No_Identifiers;
13844 Check_Valid_Configuration_Pragma;
13845 Check_Arg_Count (1);
13846 Check_Arg_Is_Identifier (Arg1);
13849 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
13852 for J in Check_Names.First .. Check_Names.Last loop
13853 if Check_Names.Table (J) = Nam then
13858 Check_Names.Append (Nam);
13865 -- This is the old style syntax, which is still allowed in all modes:
13867 -- pragma Check_Policy ([Name =>] CHECK_KIND
13868 -- [Policy =>] POLICY_IDENTIFIER);
13870 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13872 -- CHECK_KIND ::= IDENTIFIER |
13875 -- Type_Invariant'Class |
13878 -- This is the new style syntax, compatible with Assertion_Policy
13879 -- and also allowed in all modes.
13881 -- Pragma Check_Policy (
13882 -- CHECK_KIND => POLICY_IDENTIFIER
13883 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13885 -- Note: the identifiers Name and Policy are not allowed as
13886 -- Check_Kind values. This avoids ambiguities between the old and
13887 -- new form syntax.
13889 when Pragma_Check_Policy => Check_Policy : declare
13894 Check_At_Least_N_Arguments (1);
13896 -- A Check_Policy pragma can appear either as a configuration
13897 -- pragma, or in a declarative part or a package spec (see RM
13898 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13899 -- followed for Check_Policy).
13901 if not Is_Configuration_Pragma then
13902 Check_Is_In_Decl_Part_Or_Package_Spec;
13905 -- Figure out if we have the old or new syntax. We have the
13906 -- old syntax if the first argument has no identifier, or the
13907 -- identifier is Name.
13909 if Nkind (Arg1) /= N_Pragma_Argument_Association
13910 or else Chars (Arg1) in No_Name | Name_Name
13914 Check_Arg_Count (2);
13915 Check_Optional_Identifier (Arg1, Name_Name);
13916 Kind := Get_Pragma_Arg (Arg1);
13917 Rewrite_Assertion_Kind (Kind,
13918 From_Policy => Comes_From_Source (N));
13919 Check_Arg_Is_Identifier (Arg1);
13921 -- Check forbidden check kind
13923 if Chars (Kind) in Name_Name | Name_Policy then
13924 Error_Msg_Name_2 := Chars (Kind);
13926 ("pragma% does not allow% as check name", Arg1);
13931 Check_Optional_Identifier (Arg2, Name_Policy);
13932 Check_Arg_Is_One_Of
13934 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
13936 -- And chain pragma on the Check_Policy_List for search
13938 Set_Next_Pragma (N, Opt.Check_Policy_List);
13939 Opt.Check_Policy_List := N;
13941 -- For the new syntax, what we do is to convert each argument to
13942 -- an old syntax equivalent. We do that because we want to chain
13943 -- old style Check_Policy pragmas for the search (we don't want
13944 -- to have to deal with multiple arguments in the search).
13955 while Present (Arg) loop
13956 LocP := Sloc (Arg);
13957 Argx := Get_Pragma_Arg (Arg);
13959 -- Kind must be specified
13961 if Nkind (Arg) /= N_Pragma_Argument_Association
13962 or else Chars (Arg) = No_Name
13965 ("missing assertion kind for pragma%", Arg);
13968 -- Construct equivalent old form syntax Check_Policy
13969 -- pragma and insert it to get remaining checks.
13973 Chars => Name_Check_Policy,
13974 Pragma_Argument_Associations => New_List (
13975 Make_Pragma_Argument_Association (LocP,
13977 Make_Identifier (LocP, Chars (Arg))),
13978 Make_Pragma_Argument_Association (Sloc (Argx),
13979 Expression => Argx)));
13983 -- For a configuration pragma, insert old form in
13984 -- the corresponding file.
13986 if Is_Configuration_Pragma then
13987 Insert_After (N, New_P);
13991 Insert_Action (N, New_P);
13995 -- Rewrite original Check_Policy pragma to null, since we
13996 -- have converted it into a series of old syntax pragmas.
13998 Rewrite (N, Make_Null_Statement (Loc));
14008 -- pragma Comment (static_string_EXPRESSION)
14010 -- Processing for pragma Comment shares the circuitry for pragma
14011 -- Ident. The only differences are that Ident enforces a limit of 31
14012 -- characters on its argument, and also enforces limitations on
14013 -- placement for DEC compatibility. Pragma Comment shares neither of
14014 -- these restrictions.
14016 -------------------
14017 -- Common_Object --
14018 -------------------
14020 -- pragma Common_Object (
14021 -- [Internal =>] LOCAL_NAME
14022 -- [, [External =>] EXTERNAL_SYMBOL]
14023 -- [, [Size =>] EXTERNAL_SYMBOL]);
14025 -- Processing for this pragma is shared with Psect_Object
14027 ----------------------------------------------
14028 -- Compile_Time_Error, Compile_Time_Warning --
14029 ----------------------------------------------
14031 -- pragma Compile_Time_Error
14032 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14034 -- pragma Compile_Time_Warning
14035 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14037 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning =>
14039 Process_Compile_Time_Warning_Or_Error;
14041 ---------------------------
14042 -- Compiler_Unit_Warning --
14043 ---------------------------
14045 -- pragma Compiler_Unit_Warning;
14049 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14050 -- errors not warnings. This means that we had introduced a big extra
14051 -- inertia to compiler changes, since even if we implemented a new
14052 -- feature, and even if all versions to be used for bootstrapping
14053 -- implemented this new feature, we could not use it, since old
14054 -- compilers would give errors for using this feature in units
14055 -- having Compiler_Unit pragmas.
14057 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14058 -- problem. We no longer have any units mentioning Compiler_Unit,
14059 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14060 -- and thus generates a warning which can be ignored. So that deals
14061 -- with the problem of old compilers not implementing the newer form
14064 -- Newer compilers recognize the new pragma, but generate warning
14065 -- messages instead of errors, which again can be ignored in the
14066 -- case of an old compiler which implements a wanted new feature
14067 -- but at the time felt like warning about it for older compilers.
14069 -- We retain Compiler_Unit so that new compilers can be used to build
14070 -- older run-times that use this pragma. That's an unusual case, but
14071 -- it's easy enough to handle, so why not?
14073 when Pragma_Compiler_Unit
14074 | Pragma_Compiler_Unit_Warning
14077 Check_Arg_Count (0);
14079 -- Only recognized in main unit
14081 if Current_Sem_Unit = Main_Unit then
14082 Compiler_Unit := True;
14085 -----------------------------
14086 -- Complete_Representation --
14087 -----------------------------
14089 -- pragma Complete_Representation;
14091 when Pragma_Complete_Representation =>
14093 Check_Arg_Count (0);
14095 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14097 ("pragma & must appear within record representation clause");
14100 ----------------------------
14101 -- Complex_Representation --
14102 ----------------------------
14104 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14106 when Pragma_Complex_Representation => Complex_Representation : declare
14113 Check_Arg_Count (1);
14114 Check_Optional_Identifier (Arg1, Name_Entity);
14115 Check_Arg_Is_Local_Name (Arg1);
14116 E_Id := Get_Pragma_Arg (Arg1);
14118 if Etype (E_Id) = Any_Type then
14122 E := Entity (E_Id);
14124 if not Is_Record_Type (E) then
14126 ("argument for pragma% must be record type", Arg1);
14129 Ent := First_Entity (E);
14132 or else No (Next_Entity (Ent))
14133 or else Present (Next_Entity (Next_Entity (Ent)))
14134 or else not Is_Floating_Point_Type (Etype (Ent))
14135 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14138 ("record for pragma% must have two fields of the same "
14139 & "floating-point type", Arg1);
14142 Set_Has_Complex_Representation (Base_Type (E));
14144 -- We need to treat the type has having a non-standard
14145 -- representation, for back-end purposes, even though in
14146 -- general a complex will have the default representation
14147 -- of a record with two real components.
14149 Set_Has_Non_Standard_Rep (Base_Type (E));
14151 end Complex_Representation;
14153 -------------------------
14154 -- Component_Alignment --
14155 -------------------------
14157 -- pragma Component_Alignment (
14158 -- [Form =>] ALIGNMENT_CHOICE
14159 -- [, [Name =>] type_LOCAL_NAME]);
14161 -- ALIGNMENT_CHOICE ::=
14163 -- | Component_Size_4
14167 when Pragma_Component_Alignment => Component_AlignmentP : declare
14168 Args : Args_List (1 .. 2);
14169 Names : constant Name_List (1 .. 2) := (
14173 Form : Node_Id renames Args (1);
14174 Name : Node_Id renames Args (2);
14176 Atype : Component_Alignment_Kind;
14181 Gather_Associations (Names, Args);
14184 Error_Pragma ("missing Form argument for pragma%");
14187 Check_Arg_Is_Identifier (Form);
14189 -- Get proper alignment, note that Default = Component_Size on all
14190 -- machines we have so far, and we want to set this value rather
14191 -- than the default value to indicate that it has been explicitly
14192 -- set (and thus will not get overridden by the default component
14193 -- alignment for the current scope)
14195 if Chars (Form) = Name_Component_Size then
14196 Atype := Calign_Component_Size;
14198 elsif Chars (Form) = Name_Component_Size_4 then
14199 Atype := Calign_Component_Size_4;
14201 elsif Chars (Form) = Name_Default then
14202 Atype := Calign_Component_Size;
14204 elsif Chars (Form) = Name_Storage_Unit then
14205 Atype := Calign_Storage_Unit;
14209 ("invalid Form parameter for pragma%", Form);
14212 -- The pragma appears in a configuration file
14214 if No (Parent (N)) then
14215 Check_Valid_Configuration_Pragma;
14217 -- Capture the component alignment in a global variable when
14218 -- the pragma appears in a configuration file. Note that the
14219 -- scope stack is empty at this point and cannot be used to
14220 -- store the alignment value.
14222 Configuration_Component_Alignment := Atype;
14224 -- Case with no name, supplied, affects scope table entry
14226 elsif No (Name) then
14228 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14230 -- Case of name supplied
14233 Check_Arg_Is_Local_Name (Name);
14235 Typ := Entity (Name);
14238 or else Rep_Item_Too_Early (Typ, N)
14242 Typ := Underlying_Type (Typ);
14245 if not Is_Record_Type (Typ)
14246 and then not Is_Array_Type (Typ)
14249 ("Name parameter of pragma% must identify record or "
14250 & "array type", Name);
14253 -- An explicit Component_Alignment pragma overrides an
14254 -- implicit pragma Pack, but not an explicit one.
14256 if not Has_Pragma_Pack (Base_Type (Typ)) then
14257 Set_Is_Packed (Base_Type (Typ), False);
14258 Set_Component_Alignment (Base_Type (Typ), Atype);
14261 end Component_AlignmentP;
14263 --------------------------------
14264 -- Constant_After_Elaboration --
14265 --------------------------------
14267 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14269 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14271 Obj_Decl : Node_Id;
14272 Obj_Id : Entity_Id;
14276 Check_No_Identifiers;
14277 Check_At_Most_N_Arguments (1);
14279 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14281 if Nkind (Obj_Decl) /= N_Object_Declaration then
14286 Obj_Id := Defining_Entity (Obj_Decl);
14288 -- The object declaration must be a library-level variable which
14289 -- is either explicitly initialized or obtains a value during the
14290 -- elaboration of a package body (SPARK RM 3.3.1).
14292 if Ekind (Obj_Id) = E_Variable then
14293 if not Is_Library_Level_Entity (Obj_Id) then
14295 ("pragma % must apply to a library level variable");
14299 -- Otherwise the pragma applies to a constant, which is illegal
14302 Error_Pragma ("pragma % must apply to a variable declaration");
14306 -- A pragma that applies to a Ghost entity becomes Ghost for the
14307 -- purposes of legality checks and removal of ignored Ghost code.
14309 Mark_Ghost_Pragma (N, Obj_Id);
14311 -- Chain the pragma on the contract for completeness
14313 Add_Contract_Item (N, Obj_Id);
14315 -- Analyze the Boolean expression (if any)
14317 if Present (Arg1) then
14318 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14320 end Constant_After_Elaboration;
14322 --------------------
14323 -- Contract_Cases --
14324 --------------------
14326 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14328 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14330 -- CASE_GUARD ::= boolean_EXPRESSION | others
14332 -- CONSEQUENCE ::= boolean_EXPRESSION
14334 -- Characteristics:
14336 -- * Analysis - The annotation undergoes initial checks to verify
14337 -- the legal placement and context. Secondary checks preanalyze the
14340 -- Analyze_Contract_Cases_In_Decl_Part
14342 -- * Expansion - The annotation is expanded during the expansion of
14343 -- the related subprogram [body] contract as performed in:
14345 -- Expand_Subprogram_Contract
14347 -- * Template - The annotation utilizes the generic template of the
14348 -- related subprogram [body] when it is:
14350 -- aspect on subprogram declaration
14351 -- aspect on stand-alone subprogram body
14352 -- pragma on stand-alone subprogram body
14354 -- The annotation must prepare its own template when it is:
14356 -- pragma on subprogram declaration
14358 -- * Globals - Capture of global references must occur after full
14361 -- * Instance - The annotation is instantiated automatically when
14362 -- the related generic subprogram [body] is instantiated except for
14363 -- the "pragma on subprogram declaration" case. In that scenario
14364 -- the annotation must instantiate itself.
14366 when Pragma_Contract_Cases => Contract_Cases : declare
14367 Spec_Id : Entity_Id;
14368 Subp_Decl : Node_Id;
14369 Subp_Spec : Node_Id;
14373 Check_No_Identifiers;
14374 Check_Arg_Count (1);
14376 -- Ensure the proper placement of the pragma. Contract_Cases must
14377 -- be associated with a subprogram declaration or a body that acts
14381 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14385 if Nkind (Subp_Decl) = N_Entry_Declaration then
14388 -- Generic subprogram
14390 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14393 -- Body acts as spec
14395 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14396 and then No (Corresponding_Spec (Subp_Decl))
14400 -- Body stub acts as spec
14402 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14403 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14409 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14410 Subp_Spec := Specification (Subp_Decl);
14412 -- Pragma Contract_Cases is forbidden on null procedures, as
14413 -- this may lead to potential ambiguities in behavior when
14414 -- interface null procedures are involved.
14416 if Nkind (Subp_Spec) = N_Procedure_Specification
14417 and then Null_Present (Subp_Spec)
14419 Error_Msg_N (Fix_Error
14420 ("pragma % cannot apply to null procedure"), N);
14429 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14431 -- A pragma that applies to a Ghost entity becomes Ghost for the
14432 -- purposes of legality checks and removal of ignored Ghost code.
14434 Mark_Ghost_Pragma (N, Spec_Id);
14435 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14437 -- Chain the pragma on the contract for further processing by
14438 -- Analyze_Contract_Cases_In_Decl_Part.
14440 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14442 -- Fully analyze the pragma when it appears inside an entry
14443 -- or subprogram body because it cannot benefit from forward
14446 if Nkind (Subp_Decl) in N_Entry_Body
14447 | N_Subprogram_Body
14448 | N_Subprogram_Body_Stub
14450 -- The legality checks of pragma Contract_Cases are affected by
14451 -- the SPARK mode in effect and the volatility of the context.
14452 -- Analyze all pragmas in a specific order.
14454 Analyze_If_Present (Pragma_SPARK_Mode);
14455 Analyze_If_Present (Pragma_Volatile_Function);
14456 Analyze_Contract_Cases_In_Decl_Part (N);
14458 end Contract_Cases;
14464 -- pragma Controlled (first_subtype_LOCAL_NAME);
14466 when Pragma_Controlled => Controlled : declare
14470 Check_No_Identifiers;
14471 Check_Arg_Count (1);
14472 Check_Arg_Is_Local_Name (Arg1);
14473 Arg := Get_Pragma_Arg (Arg1);
14475 if not Is_Entity_Name (Arg)
14476 or else not Is_Access_Type (Entity (Arg))
14478 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14480 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14488 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14489 -- [Entity =>] LOCAL_NAME);
14491 when Pragma_Convention => Convention : declare
14494 pragma Warnings (Off, C);
14495 pragma Warnings (Off, E);
14498 Check_Arg_Order ((Name_Convention, Name_Entity));
14499 Check_Ada_83_Warning;
14500 Check_Arg_Count (2);
14501 Process_Convention (C, E);
14503 -- A pragma that applies to a Ghost entity becomes Ghost for the
14504 -- purposes of legality checks and removal of ignored Ghost code.
14506 Mark_Ghost_Pragma (N, E);
14509 ---------------------------
14510 -- Convention_Identifier --
14511 ---------------------------
14513 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14514 -- [Convention =>] convention_IDENTIFIER);
14516 when Pragma_Convention_Identifier => Convention_Identifier : declare
14522 Check_Arg_Order ((Name_Name, Name_Convention));
14523 Check_Arg_Count (2);
14524 Check_Optional_Identifier (Arg1, Name_Name);
14525 Check_Optional_Identifier (Arg2, Name_Convention);
14526 Check_Arg_Is_Identifier (Arg1);
14527 Check_Arg_Is_Identifier (Arg2);
14528 Idnam := Chars (Get_Pragma_Arg (Arg1));
14529 Cname := Chars (Get_Pragma_Arg (Arg2));
14531 if Is_Convention_Name (Cname) then
14532 Record_Convention_Identifier
14533 (Idnam, Get_Convention_Id (Cname));
14536 ("second arg for % pragma must be convention", Arg2);
14538 end Convention_Identifier;
14544 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14546 when Pragma_CPP_Class =>
14549 if Warn_On_Obsolescent_Feature then
14551 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14552 & "effect; replace it by pragma import?j?", N);
14555 Check_Arg_Count (1);
14559 Chars => Name_Import,
14560 Pragma_Argument_Associations => New_List (
14561 Make_Pragma_Argument_Association (Loc,
14562 Expression => Make_Identifier (Loc, Name_CPP)),
14563 New_Copy (First (Pragma_Argument_Associations (N))))));
14566 ---------------------
14567 -- CPP_Constructor --
14568 ---------------------
14570 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14571 -- [, [External_Name =>] static_string_EXPRESSION ]
14572 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14574 when Pragma_CPP_Constructor => CPP_Constructor : declare
14577 Def_Id : Entity_Id;
14578 Tag_Typ : Entity_Id;
14582 Check_At_Least_N_Arguments (1);
14583 Check_At_Most_N_Arguments (3);
14584 Check_Optional_Identifier (Arg1, Name_Entity);
14585 Check_Arg_Is_Local_Name (Arg1);
14587 Id := Get_Pragma_Arg (Arg1);
14588 Find_Program_Unit_Name (Id);
14590 -- If we did not find the name, we are done
14592 if Etype (Id) = Any_Type then
14596 Def_Id := Entity (Id);
14598 -- Check if already defined as constructor
14600 if Is_Constructor (Def_Id) then
14602 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
14606 if Ekind (Def_Id) = E_Function
14607 and then (Is_CPP_Class (Etype (Def_Id))
14608 or else (Is_Class_Wide_Type (Etype (Def_Id))
14610 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
14612 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
14614 ("'C'P'P constructor must be defined in the scope of "
14615 & "its returned type", Arg1);
14618 if Arg_Count >= 2 then
14619 Set_Imported (Def_Id);
14620 Set_Is_Public (Def_Id);
14621 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
14624 Set_Has_Completion (Def_Id);
14625 Set_Is_Constructor (Def_Id);
14626 Set_Convention (Def_Id, Convention_CPP);
14628 -- Imported C++ constructors are not dispatching primitives
14629 -- because in C++ they don't have a dispatch table slot.
14630 -- However, in Ada the constructor has the profile of a
14631 -- function that returns a tagged type and therefore it has
14632 -- been treated as a primitive operation during semantic
14633 -- analysis. We now remove it from the list of primitive
14634 -- operations of the type.
14636 if Is_Tagged_Type (Etype (Def_Id))
14637 and then not Is_Class_Wide_Type (Etype (Def_Id))
14638 and then Is_Dispatching_Operation (Def_Id)
14640 Tag_Typ := Etype (Def_Id);
14642 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
14643 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
14647 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
14648 Set_Is_Dispatching_Operation (Def_Id, False);
14651 -- For backward compatibility, if the constructor returns a
14652 -- class wide type, and we internally change the return type to
14653 -- the corresponding root type.
14655 if Is_Class_Wide_Type (Etype (Def_Id)) then
14656 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
14660 ("pragma% requires function returning a 'C'P'P_Class type",
14663 end CPP_Constructor;
14669 when Pragma_CPP_Virtual =>
14672 if Warn_On_Obsolescent_Feature then
14674 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14678 --------------------
14680 --------------------
14682 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
14686 -- [, EXPRESSION]]);
14688 when Pragma_CUDA_Execute => CUDA_Execute : declare
14690 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean;
14691 -- Returns True if N is an acceptable argument for CUDA_Execute,
14692 -- False otherwise.
14694 ------------------------
14695 -- Is_Acceptable_Dim3 --
14696 ------------------------
14698 function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is
14701 if Is_RTE (Etype (N), RE_Dim3)
14702 or else Is_Integer_Type (Etype (N))
14707 if Nkind (N) = N_Aggregate
14708 and then List_Length (Expressions (N)) = 3
14710 Expr := First (Expressions (N));
14711 while Present (Expr) loop
14712 Analyze_And_Resolve (Expr, Any_Integer);
14719 end Is_Acceptable_Dim3;
14723 Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg3);
14724 Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg2);
14725 Kernel_Call : constant Node_Id := Get_Pragma_Arg (Arg1);
14726 Shared_Memory : Node_Id;
14729 -- Start of processing for CUDA_Execute
14733 Check_At_Least_N_Arguments (3);
14734 Check_At_Most_N_Arguments (5);
14736 Analyze_And_Resolve (Kernel_Call);
14737 if Nkind (Kernel_Call) /= N_Function_Call
14738 or else Etype (Kernel_Call) /= Standard_Void_Type
14740 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
14741 -- GNAT sees Kernel_Call as an N_Function_Call since
14742 -- Kernel_Call "looks" like an expression. However, only
14743 -- procedures can be kernels, so to make things easier for the
14744 -- user the error message complains about Kernel_Call not being
14745 -- a procedure call.
14747 Error_Msg_N ("first argument of & must be a procedure call", N);
14750 Analyze (Grid_Dimensions);
14751 if not Is_Acceptable_Dim3 (Grid_Dimensions) then
14753 ("second argument of & must be an Integer, Dim3 or aggregate "
14754 & "containing 3 Integers", N);
14757 Analyze (Block_Dimensions);
14758 if not Is_Acceptable_Dim3 (Block_Dimensions) then
14760 ("third argument of & must be an Integer, Dim3 or aggregate "
14761 & "containing 3 Integers", N);
14764 if Present (Arg4) then
14765 Shared_Memory := Get_Pragma_Arg (Arg4);
14766 Analyze_And_Resolve (Shared_Memory, Any_Integer);
14768 if Present (Arg5) then
14769 Stream := Get_Pragma_Arg (Arg5);
14770 Analyze_And_Resolve (Stream, RTE (RE_Stream_T));
14779 -- pragma CUDA_Global (IDENTIFIER);
14781 when Pragma_CUDA_Global => CUDA_Global : declare
14782 Arg_Node : Node_Id;
14783 Kernel_Proc : Entity_Id;
14784 Pack_Id : Entity_Id;
14787 Check_At_Least_N_Arguments (1);
14788 Check_At_Most_N_Arguments (1);
14789 Check_Optional_Identifier (Arg1, Name_Entity);
14790 Check_Arg_Is_Local_Name (Arg1);
14792 Arg_Node := Get_Pragma_Arg (Arg1);
14793 Analyze (Arg_Node);
14795 Kernel_Proc := Entity (Arg_Node);
14796 Pack_Id := Scope (Kernel_Proc);
14798 if Ekind (Kernel_Proc) /= E_Procedure then
14799 Error_Msg_NE ("& must be a procedure", N, Kernel_Proc);
14801 elsif Ekind (Pack_Id) /= E_Package
14802 or else not Is_Library_Level_Entity (Pack_Id)
14805 ("& must reside in a library-level package", N, Kernel_Proc);
14808 Set_Is_CUDA_Kernel (Kernel_Proc);
14809 Add_CUDA_Kernel (Pack_Id, Kernel_Proc);
14817 when Pragma_CPP_Vtable =>
14820 if Warn_On_Obsolescent_Feature then
14822 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14830 -- pragma CPU (EXPRESSION);
14832 when Pragma_CPU => CPU : declare
14833 P : constant Node_Id := Parent (N);
14839 Check_No_Identifiers;
14840 Check_Arg_Count (1);
14841 Arg := Get_Pragma_Arg (Arg1);
14845 if Nkind (P) = N_Subprogram_Body then
14846 Check_In_Main_Program;
14848 Analyze_And_Resolve (Arg, Any_Integer);
14850 Ent := Defining_Unit_Name (Specification (P));
14852 if Nkind (Ent) = N_Defining_Program_Unit_Name then
14853 Ent := Defining_Identifier (Ent);
14858 if not Is_OK_Static_Expression (Arg) then
14859 Flag_Non_Static_Expr
14860 ("main subprogram affinity is not static!", Arg);
14863 -- If constraint error, then we already signalled an error
14865 elsif Raises_Constraint_Error (Arg) then
14868 -- Otherwise check in range
14872 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
14873 -- This is the entity System.Multiprocessors.CPU_Range;
14875 Val : constant Uint := Expr_Value (Arg);
14878 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
14880 Val > Expr_Value (Type_High_Bound (CPU_Id))
14883 ("main subprogram CPU is out of range", Arg1);
14889 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
14893 elsif Nkind (P) = N_Task_Definition then
14894 Ent := Defining_Identifier (Parent (P));
14896 -- The expression must be analyzed in the special manner
14897 -- described in "Handling of Default and Per-Object
14898 -- Expressions" in sem.ads.
14900 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
14902 -- See comment in Sem_Ch13 about the following restrictions
14904 if Is_OK_Static_Expression (Arg) then
14905 if Expr_Value (Arg) = Uint_0 then
14906 Check_Restriction (No_Tasks_Unassigned_To_CPU, N);
14909 Check_Restriction (No_Dynamic_CPU_Assignment, N);
14912 -- Anything else is incorrect
14918 -- Check duplicate pragma before we chain the pragma in the Rep
14919 -- Item chain of Ent.
14921 Check_Duplicate_Pragma (Ent);
14922 Record_Rep_Item (Ent, N);
14925 --------------------
14926 -- Deadline_Floor --
14927 --------------------
14929 -- pragma Deadline_Floor (time_span_EXPRESSION);
14931 when Pragma_Deadline_Floor => Deadline_Floor : declare
14932 P : constant Node_Id := Parent (N);
14938 Check_No_Identifiers;
14939 Check_Arg_Count (1);
14941 Arg := Get_Pragma_Arg (Arg1);
14943 -- The expression must be analyzed in the special manner described
14944 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14946 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
14948 -- Only protected types allowed
14950 if Nkind (P) /= N_Protected_Definition then
14954 Ent := Defining_Identifier (Parent (P));
14956 -- Check duplicate pragma before we chain the pragma in the Rep
14957 -- Item chain of Ent.
14959 Check_Duplicate_Pragma (Ent);
14960 Record_Rep_Item (Ent, N);
14962 end Deadline_Floor;
14968 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14970 when Pragma_Debug => Debug : declare
14977 -- The condition for executing the call is that the expander
14978 -- is active and that we are not ignoring this debug pragma.
14983 (Expander_Active and then not Is_Ignored (N)),
14986 if not Is_Ignored (N) then
14987 Set_SCO_Pragma_Enabled (Loc);
14990 if Arg_Count = 2 then
14992 Make_And_Then (Loc,
14993 Left_Opnd => Relocate_Node (Cond),
14994 Right_Opnd => Get_Pragma_Arg (Arg1));
14995 Call := Get_Pragma_Arg (Arg2);
14997 Call := Get_Pragma_Arg (Arg1);
15000 if Nkind (Call) in N_Expanded_Name
15003 | N_Indexed_Component
15004 | N_Selected_Component
15006 -- If this pragma Debug comes from source, its argument was
15007 -- parsed as a name form (which is syntactically identical).
15008 -- In a generic context a parameterless call will be left as
15009 -- an expanded name (if global) or selected_component if local.
15010 -- Change it to a procedure call statement now.
15012 Change_Name_To_Procedure_Call_Statement (Call);
15014 elsif Nkind (Call) = N_Procedure_Call_Statement then
15016 -- Already in the form of a procedure call statement: nothing
15017 -- to do (could happen in case of an internally generated
15023 -- All other cases: diagnose error
15026 ("argument of pragma ""Debug"" is not procedure call",
15031 -- Rewrite into a conditional with an appropriate condition. We
15032 -- wrap the procedure call in a block so that overhead from e.g.
15033 -- use of the secondary stack does not generate execution overhead
15034 -- for suppressed conditions.
15036 -- Normally the analysis that follows will freeze the subprogram
15037 -- being called. However, if the call is to a null procedure,
15038 -- we want to freeze it before creating the block, because the
15039 -- analysis that follows may be done with expansion disabled, in
15040 -- which case the body will not be generated, leading to spurious
15043 if Nkind (Call) = N_Procedure_Call_Statement
15044 and then Is_Entity_Name (Name (Call))
15046 Analyze (Name (Call));
15047 Freeze_Before (N, Entity (Name (Call)));
15051 Make_Implicit_If_Statement (N,
15053 Then_Statements => New_List (
15054 Make_Block_Statement (Loc,
15055 Handled_Statement_Sequence =>
15056 Make_Handled_Sequence_Of_Statements (Loc,
15057 Statements => New_List (Relocate_Node (Call)))))));
15060 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15061 -- after analysis of the normally rewritten node, to capture all
15062 -- references to entities, which avoids issuing wrong warnings
15063 -- about unused entities.
15065 if GNATprove_Mode then
15066 Rewrite (N, Make_Null_Statement (Loc));
15074 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15076 when Pragma_Debug_Policy =>
15078 Check_Arg_Count (1);
15079 Check_No_Identifiers;
15080 Check_Arg_Is_Identifier (Arg1);
15082 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15083 -- rewrite it that way, and let the rest of the checking come
15084 -- from analyzing the rewritten pragma.
15088 Chars => Name_Check_Policy,
15089 Pragma_Argument_Associations => New_List (
15090 Make_Pragma_Argument_Association (Loc,
15091 Expression => Make_Identifier (Loc, Name_Debug)),
15093 Make_Pragma_Argument_Association (Loc,
15094 Expression => Get_Pragma_Arg (Arg1)))));
15097 -------------------------------
15098 -- Default_Initial_Condition --
15099 -------------------------------
15101 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15103 when Pragma_Default_Initial_Condition => DIC : declare
15110 Check_No_Identifiers;
15111 Check_At_Most_N_Arguments (1);
15115 while Present (Stmt) loop
15117 -- Skip prior pragmas, but check for duplicates
15119 if Nkind (Stmt) = N_Pragma then
15120 if Pragma_Name (Stmt) = Pname then
15127 -- Skip internally generated code. Note that derived type
15128 -- declarations of untagged types with discriminants are
15129 -- rewritten as private type declarations.
15131 elsif not Comes_From_Source (Stmt)
15132 and then Nkind (Stmt) /= N_Private_Type_Declaration
15136 -- The associated private type [extension] has been found, stop
15139 elsif Nkind (Stmt) in N_Private_Extension_Declaration
15140 | N_Private_Type_Declaration
15142 Typ := Defining_Entity (Stmt);
15145 -- The pragma does not apply to a legal construct, issue an
15146 -- error and stop the analysis.
15153 Stmt := Prev (Stmt);
15156 -- The pragma does not apply to a legal construct, issue an error
15157 -- and stop the analysis.
15164 -- A pragma that applies to a Ghost entity becomes Ghost for the
15165 -- purposes of legality checks and removal of ignored Ghost code.
15167 Mark_Ghost_Pragma (N, Typ);
15169 -- The pragma signals that the type defines its own DIC assertion
15172 Set_Has_Own_DIC (Typ);
15174 -- Chain the pragma on the rep item chain for further processing
15176 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15178 -- Create the declaration of the procedure which verifies the
15179 -- assertion expression of pragma DIC at runtime.
15181 Build_DIC_Procedure_Declaration (Typ);
15184 ----------------------------------
15185 -- Default_Scalar_Storage_Order --
15186 ----------------------------------
15188 -- pragma Default_Scalar_Storage_Order
15189 -- (High_Order_First | Low_Order_First);
15191 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15192 Default : Character;
15196 Check_Arg_Count (1);
15198 -- Default_Scalar_Storage_Order can appear as a configuration
15199 -- pragma, or in a declarative part of a package spec.
15201 if not Is_Configuration_Pragma then
15202 Check_Is_In_Decl_Part_Or_Package_Spec;
15205 Check_No_Identifiers;
15206 Check_Arg_Is_One_Of
15207 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15208 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15209 Default := Fold_Upper (Name_Buffer (1));
15211 if not Support_Nondefault_SSO_On_Target
15212 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15214 if Warn_On_Unrecognized_Pragma then
15216 ("non-default Scalar_Storage_Order not supported "
15217 & "on target?g?", N);
15219 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15222 -- Here set the specified default
15225 Opt.Default_SSO := Default;
15229 --------------------------
15230 -- Default_Storage_Pool --
15231 --------------------------
15233 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15235 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15240 Check_Arg_Count (1);
15242 -- Default_Storage_Pool can appear as a configuration pragma, or
15243 -- in a declarative part of a package spec.
15245 if not Is_Configuration_Pragma then
15246 Check_Is_In_Decl_Part_Or_Package_Spec;
15249 if From_Aspect_Specification (N) then
15251 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15253 if not In_Open_Scopes (E) then
15255 ("aspect must apply to package or subprogram", N);
15260 if Present (Arg1) then
15261 Pool := Get_Pragma_Arg (Arg1);
15263 -- Case of Default_Storage_Pool (null);
15265 if Nkind (Pool) = N_Null then
15268 -- This is an odd case, this is not really an expression,
15269 -- so we don't have a type for it. So just set the type to
15272 Set_Etype (Pool, Empty);
15274 -- Case of Default_Storage_Pool (Standard);
15276 elsif Nkind (Pool) = N_Identifier
15277 and then Chars (Pool) = Name_Standard
15281 if Entity (Pool) /= Standard_Standard then
15283 ("package Standard is not directly visible", Arg1);
15286 -- Case of Default_Storage_Pool (storage_pool_NAME);
15289 -- If it's a configuration pragma, then the only allowed
15290 -- argument is "null".
15292 if Is_Configuration_Pragma then
15293 Error_Pragma_Arg ("NULL or Standard expected", Arg1);
15296 -- The expected type for a non-"null" argument is
15297 -- Root_Storage_Pool'Class, and the pool must be a variable.
15299 Analyze_And_Resolve
15300 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15302 if Is_Variable (Pool) then
15304 -- A pragma that applies to a Ghost entity becomes Ghost
15305 -- for the purposes of legality checks and removal of
15306 -- ignored Ghost code.
15308 Mark_Ghost_Pragma (N, Entity (Pool));
15312 ("default storage pool must be a variable", Arg1);
15316 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15317 -- access type will use this information to set the appropriate
15318 -- attributes of the access type. If the pragma appears in a
15319 -- generic unit it is ignored, given that it may refer to a
15322 if not Inside_A_Generic then
15323 Default_Pool := Pool;
15326 end Default_Storage_Pool;
15332 -- pragma Depends (DEPENDENCY_RELATION);
15334 -- DEPENDENCY_RELATION ::=
15336 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15338 -- DEPENDENCY_CLAUSE ::=
15339 -- OUTPUT_LIST =>[+] INPUT_LIST
15340 -- | NULL_DEPENDENCY_CLAUSE
15342 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15344 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15346 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15348 -- OUTPUT ::= NAME | FUNCTION_RESULT
15351 -- where FUNCTION_RESULT is a function Result attribute_reference
15353 -- Characteristics:
15355 -- * Analysis - The annotation undergoes initial checks to verify
15356 -- the legal placement and context. Secondary checks fully analyze
15357 -- the dependency clauses in:
15359 -- Analyze_Depends_In_Decl_Part
15361 -- * Expansion - None.
15363 -- * Template - The annotation utilizes the generic template of the
15364 -- related subprogram [body] when it is:
15366 -- aspect on subprogram declaration
15367 -- aspect on stand-alone subprogram body
15368 -- pragma on stand-alone subprogram body
15370 -- The annotation must prepare its own template when it is:
15372 -- pragma on subprogram declaration
15374 -- * Globals - Capture of global references must occur after full
15377 -- * Instance - The annotation is instantiated automatically when
15378 -- the related generic subprogram [body] is instantiated except for
15379 -- the "pragma on subprogram declaration" case. In that scenario
15380 -- the annotation must instantiate itself.
15382 when Pragma_Depends => Depends : declare
15384 Spec_Id : Entity_Id;
15385 Subp_Decl : Node_Id;
15388 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15392 -- Chain the pragma on the contract for further processing by
15393 -- Analyze_Depends_In_Decl_Part.
15395 Add_Contract_Item (N, Spec_Id);
15397 -- Fully analyze the pragma when it appears inside an entry
15398 -- or subprogram body because it cannot benefit from forward
15401 if Nkind (Subp_Decl) in N_Entry_Body
15402 | N_Subprogram_Body
15403 | N_Subprogram_Body_Stub
15405 -- The legality checks of pragmas Depends and Global are
15406 -- affected by the SPARK mode in effect and the volatility
15407 -- of the context. In addition these two pragmas are subject
15408 -- to an inherent order:
15413 -- Analyze all these pragmas in the order outlined above
15415 Analyze_If_Present (Pragma_SPARK_Mode);
15416 Analyze_If_Present (Pragma_Volatile_Function);
15417 Analyze_If_Present (Pragma_Global);
15418 Analyze_Depends_In_Decl_Part (N);
15423 ---------------------
15424 -- Detect_Blocking --
15425 ---------------------
15427 -- pragma Detect_Blocking;
15429 when Pragma_Detect_Blocking =>
15431 Check_Arg_Count (0);
15432 Check_Valid_Configuration_Pragma;
15433 Detect_Blocking := True;
15435 ------------------------------------
15436 -- Disable_Atomic_Synchronization --
15437 ------------------------------------
15439 -- pragma Disable_Atomic_Synchronization [(Entity)];
15441 when Pragma_Disable_Atomic_Synchronization =>
15443 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15445 -------------------
15446 -- Discard_Names --
15447 -------------------
15449 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15451 when Pragma_Discard_Names => Discard_Names : declare
15456 Check_Ada_83_Warning;
15458 -- Deal with configuration pragma case
15460 if Arg_Count = 0 and then Is_Configuration_Pragma then
15461 Global_Discard_Names := True;
15464 -- Otherwise, check correct appropriate context
15467 Check_Is_In_Decl_Part_Or_Package_Spec;
15469 if Arg_Count = 0 then
15471 -- If there is no parameter, then from now on this pragma
15472 -- applies to any enumeration, exception or tagged type
15473 -- defined in the current declarative part, and recursively
15474 -- to any nested scope.
15476 Set_Discard_Names (Current_Scope);
15480 Check_Arg_Count (1);
15481 Check_Optional_Identifier (Arg1, Name_On);
15482 Check_Arg_Is_Local_Name (Arg1);
15484 E_Id := Get_Pragma_Arg (Arg1);
15486 if Etype (E_Id) = Any_Type then
15490 E := Entity (E_Id);
15492 -- A pragma that applies to a Ghost entity becomes Ghost for
15493 -- the purposes of legality checks and removal of ignored
15496 Mark_Ghost_Pragma (N, E);
15498 if (Is_First_Subtype (E)
15500 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15501 or else Ekind (E) = E_Exception
15503 Set_Discard_Names (E);
15504 Record_Rep_Item (E, N);
15508 ("inappropriate entity for pragma%", Arg1);
15514 ------------------------
15515 -- Dispatching_Domain --
15516 ------------------------
15518 -- pragma Dispatching_Domain (EXPRESSION);
15520 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15521 P : constant Node_Id := Parent (N);
15527 Check_No_Identifiers;
15528 Check_Arg_Count (1);
15530 -- This pragma is born obsolete, but not the aspect
15532 if not From_Aspect_Specification (N) then
15534 (No_Obsolescent_Features, Pragma_Identifier (N));
15537 if Nkind (P) = N_Task_Definition then
15538 Arg := Get_Pragma_Arg (Arg1);
15539 Ent := Defining_Identifier (Parent (P));
15541 -- A pragma that applies to a Ghost entity becomes Ghost for
15542 -- the purposes of legality checks and removal of ignored Ghost
15545 Mark_Ghost_Pragma (N, Ent);
15547 -- The expression must be analyzed in the special manner
15548 -- described in "Handling of Default and Per-Object
15549 -- Expressions" in sem.ads.
15551 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15553 -- Check duplicate pragma before we chain the pragma in the Rep
15554 -- Item chain of Ent.
15556 Check_Duplicate_Pragma (Ent);
15557 Record_Rep_Item (Ent, N);
15559 -- Anything else is incorrect
15564 end Dispatching_Domain;
15570 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15572 when Pragma_Elaborate => Elaborate : declare
15577 -- Pragma must be in context items list of a compilation unit
15579 if not Is_In_Context_Clause then
15583 -- Must be at least one argument
15585 if Arg_Count = 0 then
15586 Error_Pragma ("pragma% requires at least one argument");
15589 -- In Ada 83 mode, there can be no items following it in the
15590 -- context list except other pragmas and implicit with clauses
15591 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15592 -- placement rule does not apply.
15594 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15596 while Present (Citem) loop
15597 if Nkind (Citem) = N_Pragma
15598 or else (Nkind (Citem) = N_With_Clause
15599 and then Implicit_With (Citem))
15604 ("(Ada 83) pragma% must be at end of context clause");
15611 -- Finally, the arguments must all be units mentioned in a with
15612 -- clause in the same context clause. Note we already checked (in
15613 -- Par.Prag) that the arguments are all identifiers or selected
15617 Outer : while Present (Arg) loop
15618 Citem := First (List_Containing (N));
15619 Inner : while Citem /= N loop
15620 if Nkind (Citem) = N_With_Clause
15621 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15623 Set_Elaborate_Present (Citem, True);
15624 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15626 -- With the pragma present, elaboration calls on
15627 -- subprograms from the named unit need no further
15628 -- checks, as long as the pragma appears in the current
15629 -- compilation unit. If the pragma appears in some unit
15630 -- in the context, there might still be a need for an
15631 -- Elaborate_All_Desirable from the current compilation
15632 -- to the named unit, so we keep the check enabled. This
15633 -- does not apply in SPARK mode, where we allow pragma
15634 -- Elaborate, but we don't trust it to be right so we
15635 -- will still insist on the Elaborate_All.
15637 if Legacy_Elaboration_Checks
15638 and then In_Extended_Main_Source_Unit (N)
15639 and then SPARK_Mode /= On
15641 Set_Suppress_Elaboration_Warnings
15642 (Entity (Name (Citem)));
15653 ("argument of pragma% is not withed unit", Arg);
15660 -------------------
15661 -- Elaborate_All --
15662 -------------------
15664 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15666 when Pragma_Elaborate_All => Elaborate_All : declare
15671 Check_Ada_83_Warning;
15673 -- Pragma must be in context items list of a compilation unit
15675 if not Is_In_Context_Clause then
15679 -- Must be at least one argument
15681 if Arg_Count = 0 then
15682 Error_Pragma ("pragma% requires at least one argument");
15685 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15686 -- have to appear at the end of the context clause, but may
15687 -- appear mixed in with other items, even in Ada 83 mode.
15689 -- Final check: the arguments must all be units mentioned in
15690 -- a with clause in the same context clause. Note that we
15691 -- already checked (in Par.Prag) that all the arguments are
15692 -- either identifiers or selected components.
15695 Outr : while Present (Arg) loop
15696 Citem := First (List_Containing (N));
15697 Innr : while Citem /= N loop
15698 if Nkind (Citem) = N_With_Clause
15699 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15701 Set_Elaborate_All_Present (Citem, True);
15702 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15704 -- Suppress warnings and elaboration checks on the named
15705 -- unit if the pragma is in the current compilation, as
15706 -- for pragma Elaborate.
15708 if Legacy_Elaboration_Checks
15709 and then In_Extended_Main_Source_Unit (N)
15711 Set_Suppress_Elaboration_Warnings
15712 (Entity (Name (Citem)));
15722 Set_Error_Posted (N);
15724 ("argument of pragma% is not withed unit", Arg);
15731 --------------------
15732 -- Elaborate_Body --
15733 --------------------
15735 -- pragma Elaborate_Body [( library_unit_NAME )];
15737 when Pragma_Elaborate_Body => Elaborate_Body : declare
15738 Cunit_Node : Node_Id;
15739 Cunit_Ent : Entity_Id;
15742 Check_Ada_83_Warning;
15743 Check_Valid_Library_Unit_Pragma;
15745 Cunit_Node := Cunit (Current_Sem_Unit);
15746 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
15748 -- A pragma that applies to a Ghost entity becomes Ghost for the
15749 -- purposes of legality checks and removal of ignored Ghost code.
15751 Mark_Ghost_Pragma (N, Cunit_Ent);
15753 if Nkind (Unit (Cunit_Node)) in
15754 N_Package_Body | N_Subprogram_Body
15756 Error_Pragma ("pragma% must refer to a spec, not a body");
15758 Set_Body_Required (Cunit_Node);
15759 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
15761 -- If we are in dynamic elaboration mode, then we suppress
15762 -- elaboration warnings for the unit, since it is definitely
15763 -- fine NOT to do dynamic checks at the first level (and such
15764 -- checks will be suppressed because no elaboration boolean
15765 -- is created for Elaborate_Body packages).
15767 -- But in the static model of elaboration, Elaborate_Body is
15768 -- definitely NOT good enough to ensure elaboration safety on
15769 -- its own, since the body may WITH other units that are not
15770 -- safe from an elaboration point of view, so a client must
15771 -- still do an Elaborate_All on such units.
15773 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15774 -- Elaborate_Body always suppressed elab warnings.
15776 if Legacy_Elaboration_Checks
15777 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
15779 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
15782 end Elaborate_Body;
15784 ------------------------
15785 -- Elaboration_Checks --
15786 ------------------------
15788 -- pragma Elaboration_Checks (Static | Dynamic);
15790 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
15791 procedure Check_Duplicate_Elaboration_Checks_Pragma;
15792 -- Emit an error if the current context list already contains
15793 -- a previous Elaboration_Checks pragma. This routine raises
15794 -- Pragma_Exit if a duplicate is found.
15796 procedure Ignore_Elaboration_Checks_Pragma;
15797 -- Warn that the effects of the pragma are ignored. This routine
15798 -- raises Pragma_Exit.
15800 -----------------------------------------------
15801 -- Check_Duplicate_Elaboration_Checks_Pragma --
15802 -----------------------------------------------
15804 procedure Check_Duplicate_Elaboration_Checks_Pragma is
15809 while Present (Item) loop
15810 if Nkind (Item) = N_Pragma
15811 and then Pragma_Name (Item) = Name_Elaboration_Checks
15821 end Check_Duplicate_Elaboration_Checks_Pragma;
15823 --------------------------------------
15824 -- Ignore_Elaboration_Checks_Pragma --
15825 --------------------------------------
15827 procedure Ignore_Elaboration_Checks_Pragma is
15829 Error_Msg_Name_1 := Pname;
15830 Error_Msg_N ("??effects of pragma % are ignored", N);
15832 ("\place pragma on initial declaration of library unit", N);
15835 end Ignore_Elaboration_Checks_Pragma;
15839 Context : constant Node_Id := Parent (N);
15842 -- Start of processing for Elaboration_Checks
15846 Check_Arg_Count (1);
15847 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
15849 -- The pragma appears in a configuration file
15851 if No (Context) then
15852 Check_Valid_Configuration_Pragma;
15853 Check_Duplicate_Elaboration_Checks_Pragma;
15855 -- The pragma acts as a configuration pragma in a compilation unit
15857 -- pragma Elaboration_Checks (...);
15858 -- package Pack is ...;
15860 elsif Nkind (Context) = N_Compilation_Unit
15861 and then List_Containing (N) = Context_Items (Context)
15863 Check_Valid_Configuration_Pragma;
15864 Check_Duplicate_Elaboration_Checks_Pragma;
15866 Unt := Unit (Context);
15868 -- The pragma must appear on the initial declaration of a unit.
15869 -- If this is not the case, warn that the effects of the pragma
15872 if Nkind (Unt) = N_Package_Body then
15873 Ignore_Elaboration_Checks_Pragma;
15875 -- Check the Acts_As_Spec flag of the compilation units itself
15876 -- to determine whether the subprogram body completes since it
15877 -- has not been analyzed yet. This is safe because compilation
15878 -- units are not overloadable.
15880 elsif Nkind (Unt) = N_Subprogram_Body
15881 and then not Acts_As_Spec (Context)
15883 Ignore_Elaboration_Checks_Pragma;
15885 elsif Nkind (Unt) = N_Subunit then
15886 Ignore_Elaboration_Checks_Pragma;
15889 -- Otherwise the pragma does not appear at the configuration level
15896 -- At this point the pragma is not a duplicate, and appears in the
15897 -- proper context. Set the elaboration model in effect.
15899 Dynamic_Elaboration_Checks :=
15900 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
15901 end Elaboration_Checks;
15907 -- pragma Eliminate (
15908 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15909 -- [Entity =>] IDENTIFIER |
15910 -- SELECTED_COMPONENT |
15912 -- [, Source_Location => SOURCE_TRACE]);
15914 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15915 -- SOURCE_TRACE ::= STRING_LITERAL
15917 when Pragma_Eliminate => Eliminate : declare
15918 Args : Args_List (1 .. 5);
15919 Names : constant Name_List (1 .. 5) := (
15922 Name_Parameter_Types,
15924 Name_Source_Location);
15926 -- Note : Parameter_Types and Result_Type are leftovers from
15927 -- prior implementations of the pragma. They are not generated
15928 -- by the gnatelim tool, and play no role in selecting which
15929 -- of a set of overloaded names is chosen for elimination.
15931 Unit_Name : Node_Id renames Args (1);
15932 Entity : Node_Id renames Args (2);
15933 Parameter_Types : Node_Id renames Args (3);
15934 Result_Type : Node_Id renames Args (4);
15935 Source_Location : Node_Id renames Args (5);
15939 Check_Valid_Configuration_Pragma;
15940 Gather_Associations (Names, Args);
15942 if No (Unit_Name) then
15943 Error_Pragma ("missing Unit_Name argument for pragma%");
15947 and then (Present (Parameter_Types)
15949 Present (Result_Type)
15951 Present (Source_Location))
15953 Error_Pragma ("missing Entity argument for pragma%");
15956 if (Present (Parameter_Types)
15958 Present (Result_Type))
15960 Present (Source_Location)
15963 ("parameter profile and source location cannot be used "
15964 & "together in pragma%");
15967 Process_Eliminate_Pragma
15976 -----------------------------------
15977 -- Enable_Atomic_Synchronization --
15978 -----------------------------------
15980 -- pragma Enable_Atomic_Synchronization [(Entity)];
15982 when Pragma_Enable_Atomic_Synchronization =>
15984 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
15991 -- [ Convention =>] convention_IDENTIFIER,
15992 -- [ Entity =>] LOCAL_NAME
15993 -- [, [External_Name =>] static_string_EXPRESSION ]
15994 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15996 when Pragma_Export => Export : declare
15998 Def_Id : Entity_Id;
16000 pragma Warnings (Off, C);
16003 Check_Ada_83_Warning;
16007 Name_External_Name,
16010 Check_At_Least_N_Arguments (2);
16011 Check_At_Most_N_Arguments (4);
16013 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16014 -- pragma Export (Entity, "external name");
16016 if Relaxed_RM_Semantics
16017 and then Arg_Count = 2
16018 and then Nkind (Expression (Arg2)) = N_String_Literal
16021 Def_Id := Get_Pragma_Arg (Arg1);
16024 if not Is_Entity_Name (Def_Id) then
16025 Error_Pragma_Arg ("entity name required", Arg1);
16028 Def_Id := Entity (Def_Id);
16029 Set_Exported (Def_Id, Arg1);
16032 Process_Convention (C, Def_Id);
16034 -- A pragma that applies to a Ghost entity becomes Ghost for
16035 -- the purposes of legality checks and removal of ignored Ghost
16038 Mark_Ghost_Pragma (N, Def_Id);
16040 if Ekind (Def_Id) /= E_Constant then
16041 Note_Possible_Modification
16042 (Get_Pragma_Arg (Arg2), Sure => False);
16045 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16046 Set_Exported (Def_Id, Arg2);
16049 -- If the entity is a deferred constant, propagate the information
16050 -- to the full view, because gigi elaborates the full view only.
16052 if Ekind (Def_Id) = E_Constant
16053 and then Present (Full_View (Def_Id))
16056 Id2 : constant Entity_Id := Full_View (Def_Id);
16058 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16059 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16060 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16065 ---------------------
16066 -- Export_Function --
16067 ---------------------
16069 -- pragma Export_Function (
16070 -- [Internal =>] LOCAL_NAME
16071 -- [, [External =>] EXTERNAL_SYMBOL]
16072 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16073 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16074 -- [, [Mechanism =>] MECHANISM]
16075 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16077 -- EXTERNAL_SYMBOL ::=
16079 -- | static_string_EXPRESSION
16081 -- PARAMETER_TYPES ::=
16083 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16085 -- TYPE_DESIGNATOR ::=
16087 -- | subtype_Name ' Access
16091 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16093 -- MECHANISM_ASSOCIATION ::=
16094 -- [formal_parameter_NAME =>] MECHANISM_NAME
16096 -- MECHANISM_NAME ::=
16100 when Pragma_Export_Function => Export_Function : declare
16101 Args : Args_List (1 .. 6);
16102 Names : constant Name_List (1 .. 6) := (
16105 Name_Parameter_Types,
16108 Name_Result_Mechanism);
16110 Internal : Node_Id renames Args (1);
16111 External : Node_Id renames Args (2);
16112 Parameter_Types : Node_Id renames Args (3);
16113 Result_Type : Node_Id renames Args (4);
16114 Mechanism : Node_Id renames Args (5);
16115 Result_Mechanism : Node_Id renames Args (6);
16119 Gather_Associations (Names, Args);
16120 Process_Extended_Import_Export_Subprogram_Pragma (
16121 Arg_Internal => Internal,
16122 Arg_External => External,
16123 Arg_Parameter_Types => Parameter_Types,
16124 Arg_Result_Type => Result_Type,
16125 Arg_Mechanism => Mechanism,
16126 Arg_Result_Mechanism => Result_Mechanism);
16127 end Export_Function;
16129 -------------------
16130 -- Export_Object --
16131 -------------------
16133 -- pragma Export_Object (
16134 -- [Internal =>] LOCAL_NAME
16135 -- [, [External =>] EXTERNAL_SYMBOL]
16136 -- [, [Size =>] EXTERNAL_SYMBOL]);
16138 -- EXTERNAL_SYMBOL ::=
16140 -- | static_string_EXPRESSION
16142 -- PARAMETER_TYPES ::=
16144 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16146 -- TYPE_DESIGNATOR ::=
16148 -- | subtype_Name ' Access
16152 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16154 -- MECHANISM_ASSOCIATION ::=
16155 -- [formal_parameter_NAME =>] MECHANISM_NAME
16157 -- MECHANISM_NAME ::=
16161 when Pragma_Export_Object => Export_Object : declare
16162 Args : Args_List (1 .. 3);
16163 Names : constant Name_List (1 .. 3) := (
16168 Internal : Node_Id renames Args (1);
16169 External : Node_Id renames Args (2);
16170 Size : Node_Id renames Args (3);
16174 Gather_Associations (Names, Args);
16175 Process_Extended_Import_Export_Object_Pragma (
16176 Arg_Internal => Internal,
16177 Arg_External => External,
16181 ----------------------
16182 -- Export_Procedure --
16183 ----------------------
16185 -- pragma Export_Procedure (
16186 -- [Internal =>] LOCAL_NAME
16187 -- [, [External =>] EXTERNAL_SYMBOL]
16188 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16189 -- [, [Mechanism =>] MECHANISM]);
16191 -- EXTERNAL_SYMBOL ::=
16193 -- | static_string_EXPRESSION
16195 -- PARAMETER_TYPES ::=
16197 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16199 -- TYPE_DESIGNATOR ::=
16201 -- | subtype_Name ' Access
16205 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16207 -- MECHANISM_ASSOCIATION ::=
16208 -- [formal_parameter_NAME =>] MECHANISM_NAME
16210 -- MECHANISM_NAME ::=
16214 when Pragma_Export_Procedure => Export_Procedure : declare
16215 Args : Args_List (1 .. 4);
16216 Names : constant Name_List (1 .. 4) := (
16219 Name_Parameter_Types,
16222 Internal : Node_Id renames Args (1);
16223 External : Node_Id renames Args (2);
16224 Parameter_Types : Node_Id renames Args (3);
16225 Mechanism : Node_Id renames Args (4);
16229 Gather_Associations (Names, Args);
16230 Process_Extended_Import_Export_Subprogram_Pragma (
16231 Arg_Internal => Internal,
16232 Arg_External => External,
16233 Arg_Parameter_Types => Parameter_Types,
16234 Arg_Mechanism => Mechanism);
16235 end Export_Procedure;
16241 -- pragma Export_Value (
16242 -- [Value =>] static_integer_EXPRESSION,
16243 -- [Link_Name =>] static_string_EXPRESSION);
16245 when Pragma_Export_Value =>
16247 Check_Arg_Order ((Name_Value, Name_Link_Name));
16248 Check_Arg_Count (2);
16250 Check_Optional_Identifier (Arg1, Name_Value);
16251 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16253 Check_Optional_Identifier (Arg2, Name_Link_Name);
16254 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16256 -----------------------------
16257 -- Export_Valued_Procedure --
16258 -----------------------------
16260 -- pragma Export_Valued_Procedure (
16261 -- [Internal =>] LOCAL_NAME
16262 -- [, [External =>] EXTERNAL_SYMBOL,]
16263 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16264 -- [, [Mechanism =>] MECHANISM]);
16266 -- EXTERNAL_SYMBOL ::=
16268 -- | static_string_EXPRESSION
16270 -- PARAMETER_TYPES ::=
16272 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16274 -- TYPE_DESIGNATOR ::=
16276 -- | subtype_Name ' Access
16280 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16282 -- MECHANISM_ASSOCIATION ::=
16283 -- [formal_parameter_NAME =>] MECHANISM_NAME
16285 -- MECHANISM_NAME ::=
16289 when Pragma_Export_Valued_Procedure =>
16290 Export_Valued_Procedure : declare
16291 Args : Args_List (1 .. 4);
16292 Names : constant Name_List (1 .. 4) := (
16295 Name_Parameter_Types,
16298 Internal : Node_Id renames Args (1);
16299 External : Node_Id renames Args (2);
16300 Parameter_Types : Node_Id renames Args (3);
16301 Mechanism : Node_Id renames Args (4);
16305 Gather_Associations (Names, Args);
16306 Process_Extended_Import_Export_Subprogram_Pragma (
16307 Arg_Internal => Internal,
16308 Arg_External => External,
16309 Arg_Parameter_Types => Parameter_Types,
16310 Arg_Mechanism => Mechanism);
16311 end Export_Valued_Procedure;
16313 -------------------
16314 -- Extend_System --
16315 -------------------
16317 -- pragma Extend_System ([Name =>] Identifier);
16319 when Pragma_Extend_System =>
16321 Check_Valid_Configuration_Pragma;
16322 Check_Arg_Count (1);
16323 Check_Optional_Identifier (Arg1, Name_Name);
16324 Check_Arg_Is_Identifier (Arg1);
16326 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16329 and then Name_Buffer (1 .. 4) = "aux_"
16331 if Present (System_Extend_Pragma_Arg) then
16332 if Chars (Get_Pragma_Arg (Arg1)) =
16333 Chars (Expression (System_Extend_Pragma_Arg))
16337 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16338 Error_Pragma ("pragma% conflicts with that #");
16342 System_Extend_Pragma_Arg := Arg1;
16344 if not GNAT_Mode then
16345 System_Extend_Unit := Arg1;
16349 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16352 ------------------------
16353 -- Extensions_Allowed --
16354 ------------------------
16356 -- pragma Extensions_Allowed (ON | OFF);
16358 when Pragma_Extensions_Allowed =>
16360 Check_Arg_Count (1);
16361 Check_No_Identifiers;
16362 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16364 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16365 Extensions_Allowed := True;
16366 Ada_Version := Ada_Version_Type'Last;
16369 Extensions_Allowed := False;
16370 Ada_Version := Ada_Version_Explicit;
16371 Ada_Version_Pragma := Empty;
16374 ------------------------
16375 -- Extensions_Visible --
16376 ------------------------
16378 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16380 -- Characteristics:
16382 -- * Analysis - The annotation is fully analyzed immediately upon
16383 -- elaboration as its expression must be static.
16385 -- * Expansion - None.
16387 -- * Template - The annotation utilizes the generic template of the
16388 -- related subprogram [body] when it is:
16390 -- aspect on subprogram declaration
16391 -- aspect on stand-alone subprogram body
16392 -- pragma on stand-alone subprogram body
16394 -- The annotation must prepare its own template when it is:
16396 -- pragma on subprogram declaration
16398 -- * Globals - Capture of global references must occur after full
16401 -- * Instance - The annotation is instantiated automatically when
16402 -- the related generic subprogram [body] is instantiated except for
16403 -- the "pragma on subprogram declaration" case. In that scenario
16404 -- the annotation must instantiate itself.
16406 when Pragma_Extensions_Visible => Extensions_Visible : declare
16407 Formal : Entity_Id;
16408 Has_OK_Formal : Boolean := False;
16409 Spec_Id : Entity_Id;
16410 Subp_Decl : Node_Id;
16414 Check_No_Identifiers;
16415 Check_At_Most_N_Arguments (1);
16418 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16420 -- Abstract subprogram declaration
16422 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16425 -- Generic subprogram declaration
16427 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16430 -- Body acts as spec
16432 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16433 and then No (Corresponding_Spec (Subp_Decl))
16437 -- Body stub acts as spec
16439 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16440 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16444 -- Subprogram declaration
16446 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16449 -- Otherwise the pragma is associated with an illegal construct
16452 Error_Pragma ("pragma % must apply to a subprogram");
16456 -- Mark the pragma as Ghost if the related subprogram is also
16457 -- Ghost. This also ensures that any expansion performed further
16458 -- below will produce Ghost nodes.
16460 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16461 Mark_Ghost_Pragma (N, Spec_Id);
16463 -- Chain the pragma on the contract for completeness
16465 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16467 -- The legality checks of pragma Extension_Visible are affected
16468 -- by the SPARK mode in effect. Analyze all pragmas in specific
16471 Analyze_If_Present (Pragma_SPARK_Mode);
16473 -- Examine the formals of the related subprogram
16475 Formal := First_Formal (Spec_Id);
16476 while Present (Formal) loop
16478 -- At least one of the formals is of a specific tagged type,
16479 -- the pragma is legal.
16481 if Is_Specific_Tagged_Type (Etype (Formal)) then
16482 Has_OK_Formal := True;
16485 -- A generic subprogram with at least one formal of a private
16486 -- type ensures the legality of the pragma because the actual
16487 -- may be specifically tagged. Note that this is verified by
16488 -- the check above at instantiation time.
16490 elsif Is_Private_Type (Etype (Formal))
16491 and then Is_Generic_Type (Etype (Formal))
16493 Has_OK_Formal := True;
16497 Next_Formal (Formal);
16500 if not Has_OK_Formal then
16501 Error_Msg_Name_1 := Pname;
16502 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16504 ("\subprogram & lacks parameter of specific tagged or "
16505 & "generic private type", N, Spec_Id);
16510 -- Analyze the Boolean expression (if any)
16512 if Present (Arg1) then
16513 Check_Static_Boolean_Expression
16514 (Expression (Get_Argument (N, Spec_Id)));
16516 end Extensions_Visible;
16522 -- pragma External (
16523 -- [ Convention =>] convention_IDENTIFIER,
16524 -- [ Entity =>] LOCAL_NAME
16525 -- [, [External_Name =>] static_string_EXPRESSION ]
16526 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16528 when Pragma_External => External : declare
16531 pragma Warnings (Off, C);
16538 Name_External_Name,
16540 Check_At_Least_N_Arguments (2);
16541 Check_At_Most_N_Arguments (4);
16542 Process_Convention (C, E);
16544 -- A pragma that applies to a Ghost entity becomes Ghost for the
16545 -- purposes of legality checks and removal of ignored Ghost code.
16547 Mark_Ghost_Pragma (N, E);
16549 Note_Possible_Modification
16550 (Get_Pragma_Arg (Arg2), Sure => False);
16551 Process_Interface_Name (E, Arg3, Arg4, N);
16552 Set_Exported (E, Arg2);
16555 --------------------------
16556 -- External_Name_Casing --
16557 --------------------------
16559 -- pragma External_Name_Casing (
16560 -- UPPERCASE | LOWERCASE
16561 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16563 when Pragma_External_Name_Casing =>
16565 Check_No_Identifiers;
16567 if Arg_Count = 2 then
16568 Check_Arg_Is_One_Of
16569 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16571 case Chars (Get_Pragma_Arg (Arg2)) is
16573 Opt.External_Name_Exp_Casing := As_Is;
16575 when Name_Uppercase =>
16576 Opt.External_Name_Exp_Casing := Uppercase;
16578 when Name_Lowercase =>
16579 Opt.External_Name_Exp_Casing := Lowercase;
16586 Check_Arg_Count (1);
16589 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16591 case Chars (Get_Pragma_Arg (Arg1)) is
16592 when Name_Uppercase =>
16593 Opt.External_Name_Imp_Casing := Uppercase;
16595 when Name_Lowercase =>
16596 Opt.External_Name_Imp_Casing := Lowercase;
16606 -- pragma Fast_Math;
16608 when Pragma_Fast_Math =>
16610 Check_No_Identifiers;
16611 Check_Valid_Configuration_Pragma;
16614 --------------------------
16615 -- Favor_Top_Level --
16616 --------------------------
16618 -- pragma Favor_Top_Level (type_NAME);
16620 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16625 Check_No_Identifiers;
16626 Check_Arg_Count (1);
16627 Check_Arg_Is_Local_Name (Arg1);
16628 Typ := Entity (Get_Pragma_Arg (Arg1));
16630 -- A pragma that applies to a Ghost entity becomes Ghost for the
16631 -- purposes of legality checks and removal of ignored Ghost code.
16633 Mark_Ghost_Pragma (N, Typ);
16635 -- If it's an access-to-subprogram type (in particular, not a
16636 -- subtype), set the flag on that type.
16638 if Is_Access_Subprogram_Type (Typ) then
16639 Set_Can_Use_Internal_Rep (Typ, False);
16641 -- Otherwise it's an error (name denotes the wrong sort of entity)
16645 ("access-to-subprogram type expected",
16646 Get_Pragma_Arg (Arg1));
16648 end Favor_Top_Level;
16650 ---------------------------
16651 -- Finalize_Storage_Only --
16652 ---------------------------
16654 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16656 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16657 Assoc : constant Node_Id := Arg1;
16658 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16663 Check_No_Identifiers;
16664 Check_Arg_Count (1);
16665 Check_Arg_Is_Local_Name (Arg1);
16667 Find_Type (Type_Id);
16668 Typ := Entity (Type_Id);
16671 or else Rep_Item_Too_Early (Typ, N)
16675 Typ := Underlying_Type (Typ);
16678 if not Is_Controlled (Typ) then
16679 Error_Pragma ("pragma% must specify controlled type");
16682 Check_First_Subtype (Arg1);
16684 if Finalize_Storage_Only (Typ) then
16685 Error_Pragma ("duplicate pragma%, only one allowed");
16687 elsif not Rep_Item_Too_Late (Typ, N) then
16688 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16690 end Finalize_Storage;
16696 -- pragma Ghost [ (boolean_EXPRESSION) ];
16698 when Pragma_Ghost => Ghost : declare
16702 Orig_Stmt : Node_Id;
16703 Prev_Id : Entity_Id;
16708 Check_No_Identifiers;
16709 Check_At_Most_N_Arguments (1);
16713 while Present (Stmt) loop
16715 -- Skip prior pragmas, but check for duplicates
16717 if Nkind (Stmt) = N_Pragma then
16718 if Pragma_Name (Stmt) = Pname then
16725 -- Task unit declared without a definition cannot be subject to
16726 -- pragma Ghost (SPARK RM 6.9(19)).
16728 elsif Nkind (Stmt) in
16729 N_Single_Task_Declaration | N_Task_Type_Declaration
16731 Error_Pragma ("pragma % cannot apply to a task type");
16734 -- Skip internally generated code
16736 elsif not Comes_From_Source (Stmt) then
16737 Orig_Stmt := Original_Node (Stmt);
16739 -- When pragma Ghost applies to an untagged derivation, the
16740 -- derivation is transformed into a [sub]type declaration.
16743 N_Full_Type_Declaration | N_Subtype_Declaration
16744 and then Comes_From_Source (Orig_Stmt)
16745 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
16746 and then Nkind (Type_Definition (Orig_Stmt)) =
16747 N_Derived_Type_Definition
16749 Id := Defining_Entity (Stmt);
16752 -- When pragma Ghost applies to an object declaration which
16753 -- is initialized by means of a function call that returns
16754 -- on the secondary stack, the object declaration becomes a
16757 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
16758 and then Comes_From_Source (Orig_Stmt)
16759 and then Nkind (Orig_Stmt) = N_Object_Declaration
16761 Id := Defining_Entity (Stmt);
16764 -- When pragma Ghost applies to an expression function, the
16765 -- expression function is transformed into a subprogram.
16767 elsif Nkind (Stmt) = N_Subprogram_Declaration
16768 and then Comes_From_Source (Orig_Stmt)
16769 and then Nkind (Orig_Stmt) = N_Expression_Function
16771 Id := Defining_Entity (Stmt);
16775 -- The pragma applies to a legal construct, stop the traversal
16777 elsif Nkind (Stmt) in N_Abstract_Subprogram_Declaration
16778 | N_Full_Type_Declaration
16779 | N_Generic_Subprogram_Declaration
16780 | N_Object_Declaration
16781 | N_Private_Extension_Declaration
16782 | N_Private_Type_Declaration
16783 | N_Subprogram_Declaration
16784 | N_Subtype_Declaration
16786 Id := Defining_Entity (Stmt);
16789 -- The pragma does not apply to a legal construct, issue an
16790 -- error and stop the analysis.
16794 ("pragma % must apply to an object, package, subprogram "
16799 Stmt := Prev (Stmt);
16802 Context := Parent (N);
16804 -- Handle compilation units
16806 if Nkind (Context) = N_Compilation_Unit_Aux then
16807 Context := Unit (Parent (Context));
16810 -- Protected and task types cannot be subject to pragma Ghost
16811 -- (SPARK RM 6.9(19)).
16813 if Nkind (Context) in N_Protected_Body | N_Protected_Definition
16815 Error_Pragma ("pragma % cannot apply to a protected type");
16818 elsif Nkind (Context) in N_Task_Body | N_Task_Definition then
16819 Error_Pragma ("pragma % cannot apply to a task type");
16825 -- When pragma Ghost is associated with a [generic] package, it
16826 -- appears in the visible declarations.
16828 if Nkind (Context) = N_Package_Specification
16829 and then Present (Visible_Declarations (Context))
16830 and then List_Containing (N) = Visible_Declarations (Context)
16832 Id := Defining_Entity (Context);
16834 -- Pragma Ghost applies to a stand-alone subprogram body
16836 elsif Nkind (Context) = N_Subprogram_Body
16837 and then No (Corresponding_Spec (Context))
16839 Id := Defining_Entity (Context);
16841 -- Pragma Ghost applies to a subprogram declaration that acts
16842 -- as a compilation unit.
16844 elsif Nkind (Context) = N_Subprogram_Declaration then
16845 Id := Defining_Entity (Context);
16847 -- Pragma Ghost applies to a generic subprogram
16849 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
16850 Id := Defining_Entity (Specification (Context));
16856 ("pragma % must apply to an object, package, subprogram or "
16861 -- Handle completions of types and constants that are subject to
16864 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
16865 Prev_Id := Incomplete_Or_Partial_View (Id);
16867 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
16868 Error_Msg_Name_1 := Pname;
16870 -- The full declaration of a deferred constant cannot be
16871 -- subject to pragma Ghost unless the deferred declaration
16872 -- is also Ghost (SPARK RM 6.9(9)).
16874 if Ekind (Prev_Id) = E_Constant then
16875 Error_Msg_Name_1 := Pname;
16876 Error_Msg_NE (Fix_Error
16877 ("pragma % must apply to declaration of deferred "
16878 & "constant &"), N, Id);
16881 -- Pragma Ghost may appear on the full view of an incomplete
16882 -- type because the incomplete declaration lacks aspects and
16883 -- cannot be subject to pragma Ghost.
16885 elsif Ekind (Prev_Id) = E_Incomplete_Type then
16888 -- The full declaration of a type cannot be subject to
16889 -- pragma Ghost unless the partial view is also Ghost
16890 -- (SPARK RM 6.9(9)).
16893 Error_Msg_NE (Fix_Error
16894 ("pragma % must apply to partial view of type &"),
16900 -- A synchronized object cannot be subject to pragma Ghost
16901 -- (SPARK RM 6.9(19)).
16903 elsif Ekind (Id) = E_Variable then
16904 if Is_Protected_Type (Etype (Id)) then
16905 Error_Pragma ("pragma % cannot apply to a protected object");
16908 elsif Is_Task_Type (Etype (Id)) then
16909 Error_Pragma ("pragma % cannot apply to a task object");
16914 -- Analyze the Boolean expression (if any)
16916 if Present (Arg1) then
16917 Expr := Get_Pragma_Arg (Arg1);
16919 Analyze_And_Resolve (Expr, Standard_Boolean);
16921 if Is_OK_Static_Expression (Expr) then
16923 -- "Ghostness" cannot be turned off once enabled within a
16924 -- region (SPARK RM 6.9(6)).
16926 if Is_False (Expr_Value (Expr))
16927 and then Ghost_Mode > None
16930 ("pragma % with value False cannot appear in enabled "
16935 -- Otherwise the expression is not static
16939 ("expression of pragma % must be static", Expr);
16944 Set_Is_Ghost_Entity (Id);
16951 -- pragma Global (GLOBAL_SPECIFICATION);
16953 -- GLOBAL_SPECIFICATION ::=
16956 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16958 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16960 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16961 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16962 -- GLOBAL_ITEM ::= NAME
16964 -- Characteristics:
16966 -- * Analysis - The annotation undergoes initial checks to verify
16967 -- the legal placement and context. Secondary checks fully analyze
16968 -- the dependency clauses in:
16970 -- Analyze_Global_In_Decl_Part
16972 -- * Expansion - None.
16974 -- * Template - The annotation utilizes the generic template of the
16975 -- related subprogram [body] when it is:
16977 -- aspect on subprogram declaration
16978 -- aspect on stand-alone subprogram body
16979 -- pragma on stand-alone subprogram body
16981 -- The annotation must prepare its own template when it is:
16983 -- pragma on subprogram declaration
16985 -- * Globals - Capture of global references must occur after full
16988 -- * Instance - The annotation is instantiated automatically when
16989 -- the related generic subprogram [body] is instantiated except for
16990 -- the "pragma on subprogram declaration" case. In that scenario
16991 -- the annotation must instantiate itself.
16993 when Pragma_Global => Global : declare
16995 Spec_Id : Entity_Id;
16996 Subp_Decl : Node_Id;
16999 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17003 -- Chain the pragma on the contract for further processing by
17004 -- Analyze_Global_In_Decl_Part.
17006 Add_Contract_Item (N, Spec_Id);
17008 -- Fully analyze the pragma when it appears inside an entry
17009 -- or subprogram body because it cannot benefit from forward
17012 if Nkind (Subp_Decl) in N_Entry_Body
17013 | N_Subprogram_Body
17014 | N_Subprogram_Body_Stub
17016 -- The legality checks of pragmas Depends and Global are
17017 -- affected by the SPARK mode in effect and the volatility
17018 -- of the context. In addition these two pragmas are subject
17019 -- to an inherent order:
17024 -- Analyze all these pragmas in the order outlined above
17026 Analyze_If_Present (Pragma_SPARK_Mode);
17027 Analyze_If_Present (Pragma_Volatile_Function);
17028 Analyze_Global_In_Decl_Part (N);
17029 Analyze_If_Present (Pragma_Depends);
17038 -- pragma Ident (static_string_EXPRESSION)
17040 -- Note: pragma Comment shares this processing. Pragma Ident is
17041 -- identical in effect to pragma Commment.
17043 when Pragma_Comment
17051 Check_Arg_Count (1);
17052 Check_No_Identifiers;
17053 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17056 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17063 GP := Parent (Parent (N));
17066 N_Package_Declaration | N_Generic_Package_Declaration
17071 -- If we have a compilation unit, then record the ident value,
17072 -- checking for improper duplication.
17074 if Nkind (GP) = N_Compilation_Unit then
17075 CS := Ident_String (Current_Sem_Unit);
17077 if Present (CS) then
17079 -- If we have multiple instances, concatenate them.
17081 Start_String (Strval (CS));
17082 Store_String_Char (' ');
17083 Store_String_Chars (Strval (Str));
17084 Set_Strval (CS, End_String);
17087 Set_Ident_String (Current_Sem_Unit, Str);
17090 -- For subunits, we just ignore the Ident, since in GNAT these
17091 -- are not separate object files, and hence not separate units
17092 -- in the unit table.
17094 elsif Nkind (GP) = N_Subunit then
17100 -------------------
17101 -- Ignore_Pragma --
17102 -------------------
17104 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17106 -- Entirely handled in the parser, nothing to do here
17108 when Pragma_Ignore_Pragma =>
17111 ----------------------------
17112 -- Implementation_Defined --
17113 ----------------------------
17115 -- pragma Implementation_Defined (LOCAL_NAME);
17117 -- Marks previously declared entity as implementation defined. For
17118 -- an overloaded entity, applies to the most recent homonym.
17120 -- pragma Implementation_Defined;
17122 -- The form with no arguments appears anywhere within a scope, most
17123 -- typically a package spec, and indicates that all entities that are
17124 -- defined within the package spec are Implementation_Defined.
17126 when Pragma_Implementation_Defined => Implementation_Defined : declare
17131 Check_No_Identifiers;
17133 -- Form with no arguments
17135 if Arg_Count = 0 then
17136 Set_Is_Implementation_Defined (Current_Scope);
17138 -- Form with one argument
17141 Check_Arg_Count (1);
17142 Check_Arg_Is_Local_Name (Arg1);
17143 Ent := Entity (Get_Pragma_Arg (Arg1));
17144 Set_Is_Implementation_Defined (Ent);
17146 end Implementation_Defined;
17152 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17154 -- IMPLEMENTATION_KIND ::=
17155 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17157 -- "By_Any" and "Optional" are treated as synonyms in order to
17158 -- support Ada 2012 aspect Synchronization.
17160 when Pragma_Implemented => Implemented : declare
17161 Proc_Id : Entity_Id;
17166 Check_Arg_Count (2);
17167 Check_No_Identifiers;
17168 Check_Arg_Is_Identifier (Arg1);
17169 Check_Arg_Is_Local_Name (Arg1);
17170 Check_Arg_Is_One_Of (Arg2,
17173 Name_By_Protected_Procedure,
17176 -- Extract the name of the local procedure
17178 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17180 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17181 -- primitive procedure of a synchronized tagged type.
17183 if Ekind (Proc_Id) = E_Procedure
17184 and then Is_Primitive (Proc_Id)
17185 and then Present (First_Formal (Proc_Id))
17187 Typ := Etype (First_Formal (Proc_Id));
17189 if Is_Tagged_Type (Typ)
17192 -- Check for a protected, a synchronized or a task interface
17194 ((Is_Interface (Typ)
17195 and then Is_Synchronized_Interface (Typ))
17197 -- Check for a protected type or a task type that implements
17201 (Is_Concurrent_Record_Type (Typ)
17202 and then Present (Interfaces (Typ)))
17204 -- In analysis-only mode, examine original protected type
17207 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17208 and then Present (Interface_List (Parent (Typ))))
17210 -- Check for a private record extension with keyword
17214 (Ekind (Typ) in E_Record_Type_With_Private
17215 | E_Record_Subtype_With_Private
17216 and then Synchronized_Present (Parent (Typ))))
17221 ("controlling formal must be of synchronized tagged type",
17226 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17227 -- By_Protected_Procedure to the primitive procedure of a task
17230 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17231 and then Is_Interface (Typ)
17232 and then Is_Task_Interface (Typ)
17235 ("implementation kind By_Protected_Procedure cannot be "
17236 & "applied to a task interface primitive", Arg2);
17240 -- Procedures declared inside a protected type must be accepted
17242 elsif Ekind (Proc_Id) = E_Procedure
17243 and then Is_Protected_Type (Scope (Proc_Id))
17247 -- The first argument is not a primitive procedure
17251 ("pragma % must be applied to a primitive procedure", Arg1);
17255 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17256 -- By_Protected_Procedure to a procedure that has aspect Yield
17258 if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
17259 and then Has_Yield_Aspect (Proc_Id)
17262 ("implementation kind By_Protected_Procedure cannot be "
17263 & "applied to entities with aspect 'Yield", Arg2);
17267 Record_Rep_Item (Proc_Id, N);
17270 ----------------------
17271 -- Implicit_Packing --
17272 ----------------------
17274 -- pragma Implicit_Packing;
17276 when Pragma_Implicit_Packing =>
17278 Check_Arg_Count (0);
17279 Implicit_Packing := True;
17286 -- [Convention =>] convention_IDENTIFIER,
17287 -- [Entity =>] LOCAL_NAME
17288 -- [, [External_Name =>] static_string_EXPRESSION ]
17289 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17291 when Pragma_Import =>
17292 Check_Ada_83_Warning;
17296 Name_External_Name,
17299 Check_At_Least_N_Arguments (2);
17300 Check_At_Most_N_Arguments (4);
17301 Process_Import_Or_Interface;
17303 ---------------------
17304 -- Import_Function --
17305 ---------------------
17307 -- pragma Import_Function (
17308 -- [Internal =>] LOCAL_NAME,
17309 -- [, [External =>] EXTERNAL_SYMBOL]
17310 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17311 -- [, [Result_Type =>] SUBTYPE_MARK]
17312 -- [, [Mechanism =>] MECHANISM]
17313 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17315 -- EXTERNAL_SYMBOL ::=
17317 -- | static_string_EXPRESSION
17319 -- PARAMETER_TYPES ::=
17321 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17323 -- TYPE_DESIGNATOR ::=
17325 -- | subtype_Name ' Access
17329 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17331 -- MECHANISM_ASSOCIATION ::=
17332 -- [formal_parameter_NAME =>] MECHANISM_NAME
17334 -- MECHANISM_NAME ::=
17338 when Pragma_Import_Function => Import_Function : declare
17339 Args : Args_List (1 .. 6);
17340 Names : constant Name_List (1 .. 6) := (
17343 Name_Parameter_Types,
17346 Name_Result_Mechanism);
17348 Internal : Node_Id renames Args (1);
17349 External : Node_Id renames Args (2);
17350 Parameter_Types : Node_Id renames Args (3);
17351 Result_Type : Node_Id renames Args (4);
17352 Mechanism : Node_Id renames Args (5);
17353 Result_Mechanism : Node_Id renames Args (6);
17357 Gather_Associations (Names, Args);
17358 Process_Extended_Import_Export_Subprogram_Pragma (
17359 Arg_Internal => Internal,
17360 Arg_External => External,
17361 Arg_Parameter_Types => Parameter_Types,
17362 Arg_Result_Type => Result_Type,
17363 Arg_Mechanism => Mechanism,
17364 Arg_Result_Mechanism => Result_Mechanism);
17365 end Import_Function;
17367 -------------------
17368 -- Import_Object --
17369 -------------------
17371 -- pragma Import_Object (
17372 -- [Internal =>] LOCAL_NAME
17373 -- [, [External =>] EXTERNAL_SYMBOL]
17374 -- [, [Size =>] EXTERNAL_SYMBOL]);
17376 -- EXTERNAL_SYMBOL ::=
17378 -- | static_string_EXPRESSION
17380 when Pragma_Import_Object => Import_Object : declare
17381 Args : Args_List (1 .. 3);
17382 Names : constant Name_List (1 .. 3) := (
17387 Internal : Node_Id renames Args (1);
17388 External : Node_Id renames Args (2);
17389 Size : Node_Id renames Args (3);
17393 Gather_Associations (Names, Args);
17394 Process_Extended_Import_Export_Object_Pragma (
17395 Arg_Internal => Internal,
17396 Arg_External => External,
17400 ----------------------
17401 -- Import_Procedure --
17402 ----------------------
17404 -- pragma Import_Procedure (
17405 -- [Internal =>] LOCAL_NAME
17406 -- [, [External =>] EXTERNAL_SYMBOL]
17407 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17408 -- [, [Mechanism =>] MECHANISM]);
17410 -- EXTERNAL_SYMBOL ::=
17412 -- | static_string_EXPRESSION
17414 -- PARAMETER_TYPES ::=
17416 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17418 -- TYPE_DESIGNATOR ::=
17420 -- | subtype_Name ' Access
17424 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17426 -- MECHANISM_ASSOCIATION ::=
17427 -- [formal_parameter_NAME =>] MECHANISM_NAME
17429 -- MECHANISM_NAME ::=
17433 when Pragma_Import_Procedure => Import_Procedure : declare
17434 Args : Args_List (1 .. 4);
17435 Names : constant Name_List (1 .. 4) := (
17438 Name_Parameter_Types,
17441 Internal : Node_Id renames Args (1);
17442 External : Node_Id renames Args (2);
17443 Parameter_Types : Node_Id renames Args (3);
17444 Mechanism : Node_Id renames Args (4);
17448 Gather_Associations (Names, Args);
17449 Process_Extended_Import_Export_Subprogram_Pragma (
17450 Arg_Internal => Internal,
17451 Arg_External => External,
17452 Arg_Parameter_Types => Parameter_Types,
17453 Arg_Mechanism => Mechanism);
17454 end Import_Procedure;
17456 -----------------------------
17457 -- Import_Valued_Procedure --
17458 -----------------------------
17460 -- pragma Import_Valued_Procedure (
17461 -- [Internal =>] LOCAL_NAME
17462 -- [, [External =>] EXTERNAL_SYMBOL]
17463 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17464 -- [, [Mechanism =>] MECHANISM]);
17466 -- EXTERNAL_SYMBOL ::=
17468 -- | static_string_EXPRESSION
17470 -- PARAMETER_TYPES ::=
17472 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17474 -- TYPE_DESIGNATOR ::=
17476 -- | subtype_Name ' Access
17480 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17482 -- MECHANISM_ASSOCIATION ::=
17483 -- [formal_parameter_NAME =>] MECHANISM_NAME
17485 -- MECHANISM_NAME ::=
17489 when Pragma_Import_Valued_Procedure =>
17490 Import_Valued_Procedure : declare
17491 Args : Args_List (1 .. 4);
17492 Names : constant Name_List (1 .. 4) := (
17495 Name_Parameter_Types,
17498 Internal : Node_Id renames Args (1);
17499 External : Node_Id renames Args (2);
17500 Parameter_Types : Node_Id renames Args (3);
17501 Mechanism : Node_Id renames Args (4);
17505 Gather_Associations (Names, Args);
17506 Process_Extended_Import_Export_Subprogram_Pragma (
17507 Arg_Internal => Internal,
17508 Arg_External => External,
17509 Arg_Parameter_Types => Parameter_Types,
17510 Arg_Mechanism => Mechanism);
17511 end Import_Valued_Procedure;
17517 -- pragma Independent (LOCAL_NAME);
17519 when Pragma_Independent =>
17520 Process_Atomic_Independent_Shared_Volatile;
17522 ----------------------------
17523 -- Independent_Components --
17524 ----------------------------
17526 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17528 when Pragma_Independent_Components => Independent_Components : declare
17535 Check_Ada_83_Warning;
17537 Check_No_Identifiers;
17538 Check_Arg_Count (1);
17539 Check_Arg_Is_Local_Name (Arg1);
17540 E_Id := Get_Pragma_Arg (Arg1);
17542 if Etype (E_Id) = Any_Type then
17546 E := Entity (E_Id);
17548 -- A record type with a self-referential component of anonymous
17549 -- access type is given an incomplete view in order to handle the
17552 -- type Rec is record
17553 -- Self : access Rec;
17559 -- type Ptr is access Rec;
17560 -- type Rec is record
17564 -- Since the incomplete view is now the initial view of the type,
17565 -- the argument of the pragma will reference the incomplete view,
17566 -- but this view is illegal according to the semantics of the
17569 -- Obtain the full view of an internally-generated incomplete type
17570 -- only. This way an attempt to associate the pragma with a source
17571 -- incomplete type is still caught.
17573 if Ekind (E) = E_Incomplete_Type
17574 and then not Comes_From_Source (E)
17575 and then Present (Full_View (E))
17577 E := Full_View (E);
17580 -- A pragma that applies to a Ghost entity becomes Ghost for the
17581 -- purposes of legality checks and removal of ignored Ghost code.
17583 Mark_Ghost_Pragma (N, E);
17585 -- Check duplicate before we chain ourselves
17587 Check_Duplicate_Pragma (E);
17589 -- Check appropriate entity
17591 if Rep_Item_Too_Early (E, N)
17593 Rep_Item_Too_Late (E, N)
17598 D := Declaration_Node (E);
17600 -- The flag is set on the base type, or on the object
17602 if Nkind (D) = N_Full_Type_Declaration
17603 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17605 Set_Has_Independent_Components (Base_Type (E));
17606 Record_Independence_Check (N, Base_Type (E));
17608 -- For record type, set all components independent
17610 if Is_Record_Type (E) then
17611 C := First_Component (E);
17612 while Present (C) loop
17613 Set_Is_Independent (C);
17614 Next_Component (C);
17618 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17619 and then Nkind (D) = N_Object_Declaration
17620 and then Nkind (Object_Definition (D)) =
17621 N_Constrained_Array_Definition
17623 Set_Has_Independent_Components (E);
17624 Record_Independence_Check (N, E);
17627 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17629 end Independent_Components;
17631 -----------------------
17632 -- Initial_Condition --
17633 -----------------------
17635 -- pragma Initial_Condition (boolean_EXPRESSION);
17637 -- Characteristics:
17639 -- * Analysis - The annotation undergoes initial checks to verify
17640 -- the legal placement and context. Secondary checks preanalyze the
17643 -- Analyze_Initial_Condition_In_Decl_Part
17645 -- * Expansion - The annotation is expanded during the expansion of
17646 -- the package body whose declaration is subject to the annotation
17649 -- Expand_Pragma_Initial_Condition
17651 -- * Template - The annotation utilizes the generic template of the
17652 -- related package declaration.
17654 -- * Globals - Capture of global references must occur after full
17657 -- * Instance - The annotation is instantiated automatically when
17658 -- the related generic package is instantiated.
17660 when Pragma_Initial_Condition => Initial_Condition : declare
17661 Pack_Decl : Node_Id;
17662 Pack_Id : Entity_Id;
17666 Check_No_Identifiers;
17667 Check_Arg_Count (1);
17669 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17671 if Nkind (Pack_Decl) not in
17672 N_Generic_Package_Declaration | N_Package_Declaration
17678 Pack_Id := Defining_Entity (Pack_Decl);
17680 -- A pragma that applies to a Ghost entity becomes Ghost for the
17681 -- purposes of legality checks and removal of ignored Ghost code.
17683 Mark_Ghost_Pragma (N, Pack_Id);
17685 -- Chain the pragma on the contract for further processing by
17686 -- Analyze_Initial_Condition_In_Decl_Part.
17688 Add_Contract_Item (N, Pack_Id);
17690 -- The legality checks of pragmas Abstract_State, Initializes, and
17691 -- Initial_Condition are affected by the SPARK mode in effect. In
17692 -- addition, these three pragmas are subject to an inherent order:
17694 -- 1) Abstract_State
17696 -- 3) Initial_Condition
17698 -- Analyze all these pragmas in the order outlined above
17700 Analyze_If_Present (Pragma_SPARK_Mode);
17701 Analyze_If_Present (Pragma_Abstract_State);
17702 Analyze_If_Present (Pragma_Initializes);
17703 end Initial_Condition;
17705 ------------------------
17706 -- Initialize_Scalars --
17707 ------------------------
17709 -- pragma Initialize_Scalars
17710 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17712 -- TYPE_VALUE_PAIR ::=
17713 -- SCALAR_TYPE => static_EXPRESSION
17719 -- | Long_Long_Float
17731 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
17732 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
17733 -- This collection holds the individual pairs which specify the
17734 -- invalid values of their respective scalar types.
17736 procedure Analyze_Float_Value
17737 (Scal_Typ : Float_Scalar_Id;
17738 Val_Expr : Node_Id);
17739 -- Analyze a type value pair associated with float type Scal_Typ
17740 -- and expression Val_Expr.
17742 procedure Analyze_Integer_Value
17743 (Scal_Typ : Integer_Scalar_Id;
17744 Val_Expr : Node_Id);
17745 -- Analyze a type value pair associated with integer type Scal_Typ
17746 -- and expression Val_Expr.
17748 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
17749 -- Analyze type value pair Pair
17751 -------------------------
17752 -- Analyze_Float_Value --
17753 -------------------------
17755 procedure Analyze_Float_Value
17756 (Scal_Typ : Float_Scalar_Id;
17757 Val_Expr : Node_Id)
17760 Analyze_And_Resolve (Val_Expr, Any_Real);
17762 if Is_OK_Static_Expression (Val_Expr) then
17763 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
17766 Error_Msg_Name_1 := Scal_Typ;
17767 Error_Msg_N ("value for type % must be static", Val_Expr);
17769 end Analyze_Float_Value;
17771 ---------------------------
17772 -- Analyze_Integer_Value --
17773 ---------------------------
17775 procedure Analyze_Integer_Value
17776 (Scal_Typ : Integer_Scalar_Id;
17777 Val_Expr : Node_Id)
17780 Analyze_And_Resolve (Val_Expr, Any_Integer);
17782 if (Scal_Typ = Name_Signed_128
17783 or else Scal_Typ = Name_Unsigned_128)
17784 and then Ttypes.System_Max_Integer_Size < 128
17786 Error_Msg_Name_1 := Scal_Typ;
17787 Error_Msg_N ("value cannot be set for type %", Val_Expr);
17789 elsif Is_OK_Static_Expression (Val_Expr) then
17790 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
17793 Error_Msg_Name_1 := Scal_Typ;
17794 Error_Msg_N ("value for type % must be static", Val_Expr);
17796 end Analyze_Integer_Value;
17798 -----------------------------
17799 -- Analyze_Type_Value_Pair --
17800 -----------------------------
17802 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
17803 Scal_Typ : constant Name_Id := Chars (Pair);
17804 Val_Expr : constant Node_Id := Expression (Pair);
17805 Prev_Pair : Node_Id;
17808 if Scal_Typ in Scalar_Id then
17809 Prev_Pair := Seen (Scal_Typ);
17811 -- Prevent multiple attempts to set a value for a scalar
17814 if Present (Prev_Pair) then
17815 Error_Msg_Name_1 := Scal_Typ;
17817 ("cannot specify multiple invalid values for type %",
17820 Error_Msg_Sloc := Sloc (Prev_Pair);
17821 Error_Msg_N ("previous value set #", Pair);
17823 -- Ignore the effects of the pair, but do not halt the
17824 -- analysis of the pragma altogether.
17828 -- Otherwise capture the first pair for this scalar type
17831 Seen (Scal_Typ) := Pair;
17834 if Scal_Typ in Float_Scalar_Id then
17835 Analyze_Float_Value (Scal_Typ, Val_Expr);
17837 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
17838 Analyze_Integer_Value (Scal_Typ, Val_Expr);
17841 -- Otherwise the scalar family is illegal
17844 Error_Msg_Name_1 := Pname;
17846 ("argument of pragma % must denote valid scalar family",
17849 end Analyze_Type_Value_Pair;
17853 Pairs : constant List_Id := Pragma_Argument_Associations (N);
17856 -- Start of processing for Do_Initialize_Scalars
17860 Check_Valid_Configuration_Pragma;
17861 Check_Restriction (No_Initialize_Scalars, N);
17863 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17866 if Restriction_Active (No_Initialize_Scalars) then
17869 -- Initialize_Scalars creates false positives in CodePeer, and
17870 -- incorrect negative results in GNATprove mode, so ignore this
17871 -- pragma in these modes.
17873 elsif CodePeer_Mode or GNATprove_Mode then
17876 -- Otherwise analyze the pragma
17879 if Present (Pairs) then
17881 -- Install Standard in order to provide access to primitive
17882 -- types in case the expressions contain attributes such as
17885 Push_Scope (Standard_Standard);
17887 Pair := First (Pairs);
17888 while Present (Pair) loop
17889 Analyze_Type_Value_Pair (Pair);
17898 Init_Or_Norm_Scalars := True;
17899 Initialize_Scalars := True;
17901 end Do_Initialize_Scalars;
17907 -- pragma Initializes (INITIALIZATION_LIST);
17909 -- INITIALIZATION_LIST ::=
17911 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17913 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17918 -- | (INPUT {, INPUT})
17922 -- Characteristics:
17924 -- * Analysis - The annotation undergoes initial checks to verify
17925 -- the legal placement and context. Secondary checks preanalyze the
17928 -- Analyze_Initializes_In_Decl_Part
17930 -- * Expansion - None.
17932 -- * Template - The annotation utilizes the generic template of the
17933 -- related package declaration.
17935 -- * Globals - Capture of global references must occur after full
17938 -- * Instance - The annotation is instantiated automatically when
17939 -- the related generic package is instantiated.
17941 when Pragma_Initializes => Initializes : declare
17942 Pack_Decl : Node_Id;
17943 Pack_Id : Entity_Id;
17947 Check_No_Identifiers;
17948 Check_Arg_Count (1);
17950 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17952 if Nkind (Pack_Decl) not in
17953 N_Generic_Package_Declaration | N_Package_Declaration
17959 Pack_Id := Defining_Entity (Pack_Decl);
17961 -- A pragma that applies to a Ghost entity becomes Ghost for the
17962 -- purposes of legality checks and removal of ignored Ghost code.
17964 Mark_Ghost_Pragma (N, Pack_Id);
17965 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
17967 -- Chain the pragma on the contract for further processing by
17968 -- Analyze_Initializes_In_Decl_Part.
17970 Add_Contract_Item (N, Pack_Id);
17972 -- The legality checks of pragmas Abstract_State, Initializes, and
17973 -- Initial_Condition are affected by the SPARK mode in effect. In
17974 -- addition, these three pragmas are subject to an inherent order:
17976 -- 1) Abstract_State
17978 -- 3) Initial_Condition
17980 -- Analyze all these pragmas in the order outlined above
17982 Analyze_If_Present (Pragma_SPARK_Mode);
17983 Analyze_If_Present (Pragma_Abstract_State);
17984 Analyze_If_Present (Pragma_Initial_Condition);
17991 -- pragma Inline ( NAME {, NAME} );
17993 when Pragma_Inline =>
17995 -- Pragma always active unless in GNATprove mode. It is disabled
17996 -- in GNATprove mode because frontend inlining is applied
17997 -- independently of pragmas Inline and Inline_Always for
17998 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18001 if not GNATprove_Mode then
18003 -- Inline status is Enabled if option -gnatn is specified.
18004 -- However this status determines only the value of the
18005 -- Is_Inlined flag on the subprogram and does not prevent
18006 -- the pragma itself from being recorded for later use,
18007 -- in particular for a later modification of Is_Inlined
18008 -- independently of the -gnatn option.
18010 -- In other words, if -gnatn is specified for a unit, then
18011 -- all Inline pragmas processed for the compilation of this
18012 -- unit, including those in the spec of other units, are
18013 -- activated, so subprograms will be inlined across units.
18015 -- If -gnatn is not specified, no Inline pragma is activated
18016 -- here, which means that subprograms will not be inlined
18017 -- across units. The Is_Inlined flag will nevertheless be
18018 -- set later when bodies are analyzed, so subprograms will
18019 -- be inlined within the unit.
18021 if Inline_Active then
18022 Process_Inline (Enabled);
18024 Process_Inline (Disabled);
18028 -------------------
18029 -- Inline_Always --
18030 -------------------
18032 -- pragma Inline_Always ( NAME {, NAME} );
18034 when Pragma_Inline_Always =>
18037 -- Pragma always active unless in CodePeer mode or GNATprove
18038 -- mode. It is disabled in CodePeer mode because inlining is
18039 -- not helpful, and enabling it caused walk order issues. It
18040 -- is disabled in GNATprove mode because frontend inlining is
18041 -- applied independently of pragmas Inline and Inline_Always for
18042 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18045 if not CodePeer_Mode and not GNATprove_Mode then
18046 Process_Inline (Enabled);
18049 --------------------
18050 -- Inline_Generic --
18051 --------------------
18053 -- pragma Inline_Generic (NAME {, NAME});
18055 when Pragma_Inline_Generic =>
18057 Process_Generic_List;
18059 ----------------------
18060 -- Inspection_Point --
18061 ----------------------
18063 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18065 when Pragma_Inspection_Point => Inspection_Point : declare
18072 if Arg_Count > 0 then
18075 Exp := Get_Pragma_Arg (Arg);
18078 if not Is_Entity_Name (Exp)
18079 or else not Is_Object (Entity (Exp))
18081 Error_Pragma_Arg ("object name required", Arg);
18085 exit when No (Arg);
18088 end Inspection_Point;
18094 -- pragma Interface (
18095 -- [ Convention =>] convention_IDENTIFIER,
18096 -- [ Entity =>] LOCAL_NAME
18097 -- [, [External_Name =>] static_string_EXPRESSION ]
18098 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18100 when Pragma_Interface =>
18105 Name_External_Name,
18107 Check_At_Least_N_Arguments (2);
18108 Check_At_Most_N_Arguments (4);
18109 Process_Import_Or_Interface;
18111 -- In Ada 2005, the permission to use Interface (a reserved word)
18112 -- as a pragma name is considered an obsolescent feature, and this
18113 -- pragma was already obsolescent in Ada 95.
18115 if Ada_Version >= Ada_95 then
18117 (No_Obsolescent_Features, Pragma_Identifier (N));
18119 if Warn_On_Obsolescent_Feature then
18121 ("pragma Interface is an obsolescent feature?j?", N);
18123 ("|use pragma Import instead?j?", N);
18127 --------------------
18128 -- Interface_Name --
18129 --------------------
18131 -- pragma Interface_Name (
18132 -- [ Entity =>] LOCAL_NAME
18133 -- [,[External_Name =>] static_string_EXPRESSION ]
18134 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18136 when Pragma_Interface_Name => Interface_Name : declare
18138 Def_Id : Entity_Id;
18139 Hom_Id : Entity_Id;
18145 ((Name_Entity, Name_External_Name, Name_Link_Name));
18146 Check_At_Least_N_Arguments (2);
18147 Check_At_Most_N_Arguments (3);
18148 Id := Get_Pragma_Arg (Arg1);
18151 -- This is obsolete from Ada 95 on, but it is an implementation
18152 -- defined pragma, so we do not consider that it violates the
18153 -- restriction (No_Obsolescent_Features).
18155 if Ada_Version >= Ada_95 then
18156 if Warn_On_Obsolescent_Feature then
18158 ("pragma Interface_Name is an obsolescent feature?j?", N);
18160 ("|use pragma Import instead?j?", N);
18164 if not Is_Entity_Name (Id) then
18166 ("first argument for pragma% must be entity name", Arg1);
18167 elsif Etype (Id) = Any_Type then
18170 Def_Id := Entity (Id);
18173 -- Special DEC-compatible processing for the object case, forces
18174 -- object to be imported.
18176 if Ekind (Def_Id) = E_Variable then
18177 Kill_Size_Check_Code (Def_Id);
18178 Note_Possible_Modification (Id, Sure => False);
18180 -- Initialization is not allowed for imported variable
18182 if Present (Expression (Parent (Def_Id)))
18183 and then Comes_From_Source (Expression (Parent (Def_Id)))
18185 Error_Msg_Sloc := Sloc (Def_Id);
18187 ("no initialization allowed for declaration of& #",
18191 -- For compatibility, support VADS usage of providing both
18192 -- pragmas Interface and Interface_Name to obtain the effect
18193 -- of a single Import pragma.
18195 if Is_Imported (Def_Id)
18196 and then Present (First_Rep_Item (Def_Id))
18197 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18198 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18203 Set_Imported (Def_Id);
18206 Set_Is_Public (Def_Id);
18207 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18210 -- Otherwise must be subprogram
18212 elsif not Is_Subprogram (Def_Id) then
18214 ("argument of pragma% is not subprogram", Arg1);
18217 Check_At_Most_N_Arguments (3);
18221 -- Loop through homonyms
18224 Def_Id := Get_Base_Subprogram (Hom_Id);
18226 if Is_Imported (Def_Id) then
18227 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18231 exit when From_Aspect_Specification (N);
18232 Hom_Id := Homonym (Hom_Id);
18234 exit when No (Hom_Id)
18235 or else Scope (Hom_Id) /= Current_Scope;
18240 ("argument of pragma% is not imported subprogram",
18244 end Interface_Name;
18246 -----------------------
18247 -- Interrupt_Handler --
18248 -----------------------
18250 -- pragma Interrupt_Handler (handler_NAME);
18252 when Pragma_Interrupt_Handler =>
18253 Check_Ada_83_Warning;
18254 Check_Arg_Count (1);
18255 Check_No_Identifiers;
18257 if No_Run_Time_Mode then
18258 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18260 Check_Interrupt_Or_Attach_Handler;
18261 Process_Interrupt_Or_Attach_Handler;
18264 ------------------------
18265 -- Interrupt_Priority --
18266 ------------------------
18268 -- pragma Interrupt_Priority [(EXPRESSION)];
18270 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18271 P : constant Node_Id := Parent (N);
18276 Check_Ada_83_Warning;
18278 if Arg_Count /= 0 then
18279 Arg := Get_Pragma_Arg (Arg1);
18280 Check_Arg_Count (1);
18281 Check_No_Identifiers;
18283 -- The expression must be analyzed in the special manner
18284 -- described in "Handling of Default and Per-Object
18285 -- Expressions" in sem.ads.
18287 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18290 if Nkind (P) not in N_Task_Definition | N_Protected_Definition then
18295 Ent := Defining_Identifier (Parent (P));
18297 -- Check duplicate pragma before we chain the pragma in the Rep
18298 -- Item chain of Ent.
18300 Check_Duplicate_Pragma (Ent);
18301 Record_Rep_Item (Ent, N);
18303 -- Check the No_Task_At_Interrupt_Priority restriction
18305 if Nkind (P) = N_Task_Definition then
18306 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18309 end Interrupt_Priority;
18311 ---------------------
18312 -- Interrupt_State --
18313 ---------------------
18315 -- pragma Interrupt_State (
18316 -- [Name =>] INTERRUPT_ID,
18317 -- [State =>] INTERRUPT_STATE);
18319 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18320 -- INTERRUPT_STATE => System | Runtime | User
18322 -- Note: if the interrupt id is given as an identifier, then it must
18323 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18324 -- given as a static integer expression which must be in the range of
18325 -- Ada.Interrupts.Interrupt_ID.
18327 when Pragma_Interrupt_State => Interrupt_State : declare
18328 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18329 -- This is the entity Ada.Interrupts.Interrupt_ID;
18331 State_Type : Character;
18332 -- Set to 's'/'r'/'u' for System/Runtime/User
18335 -- Index to entry in Interrupt_States table
18338 -- Value of interrupt
18340 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18341 -- The first argument to the pragma
18343 Int_Ent : Entity_Id;
18344 -- Interrupt entity in Ada.Interrupts.Names
18348 Check_Arg_Order ((Name_Name, Name_State));
18349 Check_Arg_Count (2);
18351 Check_Optional_Identifier (Arg1, Name_Name);
18352 Check_Optional_Identifier (Arg2, Name_State);
18353 Check_Arg_Is_Identifier (Arg2);
18355 -- First argument is identifier
18357 if Nkind (Arg1X) = N_Identifier then
18359 -- Search list of names in Ada.Interrupts.Names
18361 Int_Ent := First_Entity (RTE (RE_Names));
18363 if No (Int_Ent) then
18364 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18366 elsif Chars (Int_Ent) = Chars (Arg1X) then
18367 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18371 Next_Entity (Int_Ent);
18374 -- First argument is not an identifier, so it must be a static
18375 -- expression of type Ada.Interrupts.Interrupt_ID.
18378 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18379 Int_Val := Expr_Value (Arg1X);
18381 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18383 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18386 ("value not in range of type "
18387 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18393 case Chars (Get_Pragma_Arg (Arg2)) is
18394 when Name_Runtime => State_Type := 'r';
18395 when Name_System => State_Type := 's';
18396 when Name_User => State_Type := 'u';
18399 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18402 -- Check if entry is already stored
18404 IST_Num := Interrupt_States.First;
18406 -- If entry not found, add it
18408 if IST_Num > Interrupt_States.Last then
18409 Interrupt_States.Append
18410 ((Interrupt_Number => UI_To_Int (Int_Val),
18411 Interrupt_State => State_Type,
18412 Pragma_Loc => Loc));
18415 -- Case of entry for the same entry
18417 elsif Int_Val = Interrupt_States.Table (IST_Num).
18420 -- If state matches, done, no need to make redundant entry
18423 State_Type = Interrupt_States.Table (IST_Num).
18426 -- Otherwise if state does not match, error
18429 Interrupt_States.Table (IST_Num).Pragma_Loc;
18431 ("state conflicts with that given #", Arg2);
18435 IST_Num := IST_Num + 1;
18437 end Interrupt_State;
18443 -- pragma Invariant
18444 -- ([Entity =>] type_LOCAL_NAME,
18445 -- [Check =>] EXPRESSION
18446 -- [,[Message =>] String_Expression]);
18448 when Pragma_Invariant => Invariant : declare
18455 Check_At_Least_N_Arguments (2);
18456 Check_At_Most_N_Arguments (3);
18457 Check_Optional_Identifier (Arg1, Name_Entity);
18458 Check_Optional_Identifier (Arg2, Name_Check);
18460 if Arg_Count = 3 then
18461 Check_Optional_Identifier (Arg3, Name_Message);
18462 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18465 Check_Arg_Is_Local_Name (Arg1);
18467 Typ_Arg := Get_Pragma_Arg (Arg1);
18468 Find_Type (Typ_Arg);
18469 Typ := Entity (Typ_Arg);
18471 -- Nothing to do of the related type is erroneous in some way
18473 if Typ = Any_Type then
18476 -- AI12-0041: Invariants are allowed in interface types
18478 elsif Is_Interface (Typ) then
18481 -- An invariant must apply to a private type, or appear in the
18482 -- private part of a package spec and apply to a completion.
18483 -- a class-wide invariant can only appear on a private declaration
18484 -- or private extension, not a completion.
18486 -- A [class-wide] invariant may be associated a [limited] private
18487 -- type or a private extension.
18489 elsif Ekind (Typ) in E_Limited_Private_Type
18491 | E_Record_Type_With_Private
18495 -- A non-class-wide invariant may be associated with the full view
18496 -- of a [limited] private type or a private extension.
18498 elsif Has_Private_Declaration (Typ)
18499 and then not Class_Present (N)
18503 -- A class-wide invariant may appear on the partial view only
18505 elsif Class_Present (N) then
18507 ("pragma % only allowed for private type", Arg1);
18510 -- A regular invariant may appear on both views
18514 ("pragma % only allowed for private type or corresponding "
18515 & "full view", Arg1);
18519 -- An invariant associated with an abstract type (this includes
18520 -- interfaces) must be class-wide.
18522 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18524 ("pragma % not allowed for abstract type", Arg1);
18528 -- A pragma that applies to a Ghost entity becomes Ghost for the
18529 -- purposes of legality checks and removal of ignored Ghost code.
18531 Mark_Ghost_Pragma (N, Typ);
18533 -- The pragma defines a type-specific invariant, the type is said
18534 -- to have invariants of its "own".
18536 Set_Has_Own_Invariants (Base_Type (Typ));
18538 -- If the invariant is class-wide, then it can be inherited by
18539 -- derived or interface implementing types. The type is said to
18540 -- have "inheritable" invariants.
18542 if Class_Present (N) then
18543 Set_Has_Inheritable_Invariants (Typ);
18546 -- Chain the pragma on to the rep item chain, for processing when
18547 -- the type is frozen.
18549 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18551 -- Create the declaration of the invariant procedure that will
18552 -- verify the invariant at run time. Interfaces are treated as the
18553 -- partial view of a private type in order to achieve uniformity
18554 -- with the general case. As a result, an interface receives only
18555 -- a "partial" invariant procedure, which is never called.
18557 Build_Invariant_Procedure_Declaration
18559 Partial_Invariant => Is_Interface (Typ));
18566 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18568 when Pragma_Keep_Names => Keep_Names : declare
18573 Check_Arg_Count (1);
18574 Check_Optional_Identifier (Arg1, Name_On);
18575 Check_Arg_Is_Local_Name (Arg1);
18577 Arg := Get_Pragma_Arg (Arg1);
18580 if Etype (Arg) = Any_Type then
18584 if not Is_Entity_Name (Arg)
18585 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18588 ("pragma% requires a local enumeration type", Arg1);
18591 Set_Discard_Names (Entity (Arg), False);
18598 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18600 when Pragma_License =>
18603 -- Do not analyze pragma any further in CodePeer mode, to avoid
18604 -- extraneous errors in this implementation-dependent pragma,
18605 -- which has a different profile on other compilers.
18607 if CodePeer_Mode then
18611 Check_Arg_Count (1);
18612 Check_No_Identifiers;
18613 Check_Valid_Configuration_Pragma;
18614 Check_Arg_Is_Identifier (Arg1);
18617 Sind : constant Source_File_Index :=
18618 Source_Index (Current_Sem_Unit);
18621 case Chars (Get_Pragma_Arg (Arg1)) is
18623 Set_License (Sind, GPL);
18625 when Name_Modified_GPL =>
18626 Set_License (Sind, Modified_GPL);
18628 when Name_Restricted =>
18629 Set_License (Sind, Restricted);
18631 when Name_Unrestricted =>
18632 Set_License (Sind, Unrestricted);
18635 Error_Pragma_Arg ("invalid license name", Arg1);
18643 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18645 when Pragma_Link_With => Link_With : declare
18651 if Operating_Mode = Generate_Code
18652 and then In_Extended_Main_Source_Unit (N)
18654 Check_At_Least_N_Arguments (1);
18655 Check_No_Identifiers;
18656 Check_Is_In_Decl_Part_Or_Package_Spec;
18657 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18661 while Present (Arg) loop
18662 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18664 -- Store argument, converting sequences of spaces to a
18665 -- single null character (this is one of the differences
18666 -- in processing between Link_With and Linker_Options).
18668 Arg_Store : declare
18669 C : constant Char_Code := Get_Char_Code (' ');
18670 S : constant String_Id :=
18671 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18672 L : constant Nat := String_Length (S);
18675 procedure Skip_Spaces;
18676 -- Advance F past any spaces
18682 procedure Skip_Spaces is
18684 while F <= L and then Get_String_Char (S, F) = C loop
18689 -- Start of processing for Arg_Store
18692 Skip_Spaces; -- skip leading spaces
18694 -- Loop through characters, changing any embedded
18695 -- sequence of spaces to a single null character (this
18696 -- is how Link_With/Linker_Options differ)
18699 if Get_String_Char (S, F) = C then
18702 Store_String_Char (ASCII.NUL);
18705 Store_String_Char (Get_String_Char (S, F));
18713 if Present (Arg) then
18714 Store_String_Char (ASCII.NUL);
18718 Store_Linker_Option_String (End_String);
18726 -- pragma Linker_Alias (
18727 -- [Entity =>] LOCAL_NAME
18728 -- [Target =>] static_string_EXPRESSION);
18730 when Pragma_Linker_Alias =>
18732 Check_Arg_Order ((Name_Entity, Name_Target));
18733 Check_Arg_Count (2);
18734 Check_Optional_Identifier (Arg1, Name_Entity);
18735 Check_Optional_Identifier (Arg2, Name_Target);
18736 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18737 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18739 -- The only processing required is to link this item on to the
18740 -- list of rep items for the given entity. This is accomplished
18741 -- by the call to Rep_Item_Too_Late (when no error is detected
18742 -- and False is returned).
18744 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
18747 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
18750 ------------------------
18751 -- Linker_Constructor --
18752 ------------------------
18754 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18756 -- Code is shared with Linker_Destructor
18758 -----------------------
18759 -- Linker_Destructor --
18760 -----------------------
18762 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18764 when Pragma_Linker_Constructor
18765 | Pragma_Linker_Destructor
18767 Linker_Constructor : declare
18773 Check_Arg_Count (1);
18774 Check_No_Identifiers;
18775 Check_Arg_Is_Local_Name (Arg1);
18776 Arg1_X := Get_Pragma_Arg (Arg1);
18778 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
18780 if not Is_Library_Level_Entity (Proc) then
18782 ("argument for pragma% must be library level entity", Arg1);
18785 -- The only processing required is to link this item on to the
18786 -- list of rep items for the given entity. This is accomplished
18787 -- by the call to Rep_Item_Too_Late (when no error is detected
18788 -- and False is returned).
18790 if Rep_Item_Too_Late (Proc, N) then
18793 Set_Has_Gigi_Rep_Item (Proc);
18795 end Linker_Constructor;
18797 --------------------
18798 -- Linker_Options --
18799 --------------------
18801 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18803 when Pragma_Linker_Options => Linker_Options : declare
18807 Check_Ada_83_Warning;
18808 Check_No_Identifiers;
18809 Check_Arg_Count (1);
18810 Check_Is_In_Decl_Part_Or_Package_Spec;
18811 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18812 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
18815 while Present (Arg) loop
18816 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18817 Store_String_Char (ASCII.NUL);
18819 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
18823 if Operating_Mode = Generate_Code
18824 and then In_Extended_Main_Source_Unit (N)
18826 Store_Linker_Option_String (End_String);
18828 end Linker_Options;
18830 --------------------
18831 -- Linker_Section --
18832 --------------------
18834 -- pragma Linker_Section (
18835 -- [Entity =>] LOCAL_NAME
18836 -- [Section =>] static_string_EXPRESSION);
18838 when Pragma_Linker_Section => Linker_Section : declare
18843 Ghost_Error_Posted : Boolean := False;
18844 -- Flag set when an error concerning the illegal mix of Ghost and
18845 -- non-Ghost subprograms is emitted.
18847 Ghost_Id : Entity_Id := Empty;
18848 -- The entity of the first Ghost subprogram encountered while
18849 -- processing the arguments of the pragma.
18853 Check_Arg_Order ((Name_Entity, Name_Section));
18854 Check_Arg_Count (2);
18855 Check_Optional_Identifier (Arg1, Name_Entity);
18856 Check_Optional_Identifier (Arg2, Name_Section);
18857 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18858 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
18860 -- Check kind of entity
18862 Arg := Get_Pragma_Arg (Arg1);
18863 Ent := Entity (Arg);
18865 case Ekind (Ent) is
18867 -- Objects (constants and variables) and types. For these cases
18868 -- all we need to do is to set the Linker_Section_pragma field,
18869 -- checking that we do not have a duplicate.
18875 LPE := Linker_Section_Pragma (Ent);
18877 if Present (LPE) then
18878 Error_Msg_Sloc := Sloc (LPE);
18880 ("Linker_Section already specified for &#", Arg1, Ent);
18883 Set_Linker_Section_Pragma (Ent, N);
18885 -- A pragma that applies to a Ghost entity becomes Ghost for
18886 -- the purposes of legality checks and removal of ignored
18889 Mark_Ghost_Pragma (N, Ent);
18893 when Subprogram_Kind =>
18895 -- Aspect case, entity already set
18897 if From_Aspect_Specification (N) then
18898 Set_Linker_Section_Pragma
18899 (Entity (Corresponding_Aspect (N)), N);
18901 -- Propagate it to its ultimate aliased entity to
18902 -- facilitate the backend processing this attribute
18903 -- in instantiations of generic subprograms.
18905 if Present (Alias (Entity (Corresponding_Aspect (N))))
18907 Set_Linker_Section_Pragma
18909 (Entity (Corresponding_Aspect (N))), N);
18912 -- Pragma case, we must climb the homonym chain, but skip
18913 -- any for which the linker section is already set.
18917 if No (Linker_Section_Pragma (Ent)) then
18918 Set_Linker_Section_Pragma (Ent, N);
18920 -- Propagate it to its ultimate aliased entity to
18921 -- facilitate the backend processing this attribute
18922 -- in instantiations of generic subprograms.
18924 if Present (Alias (Ent)) then
18925 Set_Linker_Section_Pragma
18926 (Ultimate_Alias (Ent), N);
18929 -- A pragma that applies to a Ghost entity becomes
18930 -- Ghost for the purposes of legality checks and
18931 -- removal of ignored Ghost code.
18933 Mark_Ghost_Pragma (N, Ent);
18935 -- Capture the entity of the first Ghost subprogram
18936 -- being processed for error detection purposes.
18938 if Is_Ghost_Entity (Ent) then
18939 if No (Ghost_Id) then
18943 -- Otherwise the subprogram is non-Ghost. It is
18944 -- illegal to mix references to Ghost and non-Ghost
18945 -- entities (SPARK RM 6.9).
18947 elsif Present (Ghost_Id)
18948 and then not Ghost_Error_Posted
18950 Ghost_Error_Posted := True;
18952 Error_Msg_Name_1 := Pname;
18954 ("pragma % cannot mention ghost and "
18955 & "non-ghost subprograms", N);
18957 Error_Msg_Sloc := Sloc (Ghost_Id);
18959 ("\& # declared as ghost", N, Ghost_Id);
18961 Error_Msg_Sloc := Sloc (Ent);
18963 ("\& # declared as non-ghost", N, Ent);
18967 Ent := Homonym (Ent);
18969 or else Scope (Ent) /= Current_Scope;
18973 -- All other cases are illegal
18977 ("pragma% applies only to objects, subprograms, and types",
18980 end Linker_Section;
18986 -- pragma List (On | Off)
18988 -- There is nothing to do here, since we did all the processing for
18989 -- this pragma in Par.Prag (so that it works properly even in syntax
18992 when Pragma_List =>
18999 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19001 when Pragma_Lock_Free => Lock_Free : declare
19002 P : constant Node_Id := Parent (N);
19008 Check_No_Identifiers;
19009 Check_At_Most_N_Arguments (1);
19011 -- Protected definition case
19013 if Nkind (P) = N_Protected_Definition then
19014 Ent := Defining_Identifier (Parent (P));
19018 if Arg_Count = 1 then
19019 Arg := Get_Pragma_Arg (Arg1);
19020 Val := Is_True (Static_Boolean (Arg));
19022 -- No arguments (expression is considered to be True)
19028 -- Check duplicate pragma before we chain the pragma in the Rep
19029 -- Item chain of Ent.
19031 Check_Duplicate_Pragma (Ent);
19032 Record_Rep_Item (Ent, N);
19033 Set_Uses_Lock_Free (Ent, Val);
19035 -- Anything else is incorrect placement
19042 --------------------
19043 -- Locking_Policy --
19044 --------------------
19046 -- pragma Locking_Policy (policy_IDENTIFIER);
19048 when Pragma_Locking_Policy => declare
19049 subtype LP_Range is Name_Id
19050 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19055 Check_Ada_83_Warning;
19056 Check_Arg_Count (1);
19057 Check_No_Identifiers;
19058 Check_Arg_Is_Locking_Policy (Arg1);
19059 Check_Valid_Configuration_Pragma;
19060 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19063 when Name_Ceiling_Locking => LP := 'C';
19064 when Name_Concurrent_Readers_Locking => LP := 'R';
19065 when Name_Inheritance_Locking => LP := 'I';
19068 if Locking_Policy /= ' '
19069 and then Locking_Policy /= LP
19071 Error_Msg_Sloc := Locking_Policy_Sloc;
19072 Error_Pragma ("locking policy incompatible with policy#");
19074 -- Set new policy, but always preserve System_Location since we
19075 -- like the error message with the run time name.
19078 Locking_Policy := LP;
19080 if Locking_Policy_Sloc /= System_Location then
19081 Locking_Policy_Sloc := Loc;
19086 -------------------
19087 -- Loop_Optimize --
19088 -------------------
19090 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19092 -- OPTIMIZATION_HINT ::=
19093 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19095 when Pragma_Loop_Optimize => Loop_Optimize : declare
19100 Check_At_Least_N_Arguments (1);
19101 Check_No_Identifiers;
19103 Hint := First (Pragma_Argument_Associations (N));
19104 while Present (Hint) loop
19105 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19113 Check_Loop_Pragma_Placement;
19120 -- pragma Loop_Variant
19121 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19123 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19125 -- CHANGE_DIRECTION ::= Increases | Decreases
19127 when Pragma_Loop_Variant => Loop_Variant : declare
19132 Check_At_Least_N_Arguments (1);
19133 Check_Loop_Pragma_Placement;
19135 -- Process all increasing / decreasing expressions
19137 Variant := First (Pragma_Argument_Associations (N));
19138 while Present (Variant) loop
19139 if Chars (Variant) = No_Name then
19140 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19142 elsif Chars (Variant) not in Name_Decreases | Name_Increases
19145 Name : String := Get_Name_String (Chars (Variant));
19148 -- It is a common mistake to write "Increasing" for
19149 -- "Increases" or "Decreasing" for "Decreases". Recognize
19150 -- specially names starting with "incr" or "decr" to
19151 -- suggest the corresponding name.
19153 System.Case_Util.To_Lower (Name);
19155 if Name'Length >= 4
19156 and then Name (1 .. 4) = "incr"
19158 Error_Pragma_Arg_Ident
19159 ("expect name `Increases`", Variant);
19161 elsif Name'Length >= 4
19162 and then Name (1 .. 4) = "decr"
19164 Error_Pragma_Arg_Ident
19165 ("expect name `Decreases`", Variant);
19168 Error_Pragma_Arg_Ident
19169 ("expect name `Increases` or `Decreases`", Variant);
19174 Preanalyze_Assert_Expression
19175 (Expression (Variant), Any_Discrete);
19181 -----------------------
19182 -- Machine_Attribute --
19183 -----------------------
19185 -- pragma Machine_Attribute (
19186 -- [Entity =>] LOCAL_NAME,
19187 -- [Attribute_Name =>] static_string_EXPRESSION
19188 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19190 when Pragma_Machine_Attribute => Machine_Attribute : declare
19192 Def_Id : Entity_Id;
19196 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19198 if Arg_Count >= 3 then
19199 Check_Optional_Identifier (Arg3, Name_Info);
19201 while Present (Arg) loop
19202 Check_Arg_Is_OK_Static_Expression (Arg);
19206 Check_Arg_Count (2);
19209 Check_Optional_Identifier (Arg1, Name_Entity);
19210 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19211 Check_Arg_Is_Local_Name (Arg1);
19212 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19213 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19215 if Is_Access_Type (Def_Id) then
19216 Def_Id := Designated_Type (Def_Id);
19219 if Rep_Item_Too_Early (Def_Id, N) then
19223 Def_Id := Underlying_Type (Def_Id);
19225 -- The only processing required is to link this item on to the
19226 -- list of rep items for the given entity. This is accomplished
19227 -- by the call to Rep_Item_Too_Late (when no error is detected
19228 -- and False is returned).
19230 if Rep_Item_Too_Late (Def_Id, N) then
19233 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19235 end Machine_Attribute;
19242 -- (MAIN_OPTION [, MAIN_OPTION]);
19245 -- [STACK_SIZE =>] static_integer_EXPRESSION
19246 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19247 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19249 when Pragma_Main => Main : declare
19250 Args : Args_List (1 .. 3);
19251 Names : constant Name_List (1 .. 3) := (
19253 Name_Task_Stack_Size_Default,
19254 Name_Time_Slicing_Enabled);
19260 Gather_Associations (Names, Args);
19262 for J in 1 .. 2 loop
19263 if Present (Args (J)) then
19264 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19268 if Present (Args (3)) then
19269 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19273 while Present (Nod) loop
19274 if Nkind (Nod) = N_Pragma
19275 and then Pragma_Name (Nod) = Name_Main
19277 Error_Msg_Name_1 := Pname;
19278 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19289 -- pragma Main_Storage
19290 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19292 -- MAIN_STORAGE_OPTION ::=
19293 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19294 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19296 when Pragma_Main_Storage => Main_Storage : declare
19297 Args : Args_List (1 .. 2);
19298 Names : constant Name_List (1 .. 2) := (
19299 Name_Working_Storage,
19306 Gather_Associations (Names, Args);
19308 for J in 1 .. 2 loop
19309 if Present (Args (J)) then
19310 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19314 Check_In_Main_Program;
19317 while Present (Nod) loop
19318 if Nkind (Nod) = N_Pragma
19319 and then Pragma_Name (Nod) = Name_Main_Storage
19321 Error_Msg_Name_1 := Pname;
19322 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19329 ----------------------------
19330 -- Max_Entry_Queue_Length --
19331 ----------------------------
19333 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19335 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19336 -- Pragma_Max_Queue_Length.
19338 when Pragma_Max_Entry_Queue_Length
19339 | Pragma_Max_Entry_Queue_Depth
19340 | Pragma_Max_Queue_Length
19342 Max_Entry_Queue_Length : declare
19344 Entry_Decl : Node_Id;
19345 Entry_Id : Entity_Id;
19349 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19350 or else Prag_Id = Pragma_Max_Queue_Length
19355 Check_Arg_Count (1);
19358 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19360 -- Entry declaration
19362 if Nkind (Entry_Decl) = N_Entry_Declaration then
19364 -- Entry illegally within a task
19366 if Nkind (Parent (N)) = N_Task_Definition then
19367 Error_Pragma ("pragma % cannot apply to task entries");
19371 Entry_Id := Defining_Entity (Entry_Decl);
19373 -- Otherwise the pragma is associated with an illegal construct
19377 ("pragma % must apply to a protected entry declaration");
19381 -- Mark the pragma as Ghost if the related subprogram is also
19382 -- Ghost. This also ensures that any expansion performed further
19383 -- below will produce Ghost nodes.
19385 Mark_Ghost_Pragma (N, Entry_Id);
19387 -- Analyze the Integer expression
19389 Arg := Get_Pragma_Arg (Arg1);
19390 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19392 Val := Expr_Value (Arg);
19396 ("argument for pragma% cannot be less than -1", Arg1);
19398 elsif not UI_Is_In_Int_Range (Val) then
19400 ("argument for pragma% out of range of Integer", Arg1);
19404 Record_Rep_Item (Entry_Id, N);
19405 end Max_Entry_Queue_Length;
19411 -- pragma Memory_Size (NUMERIC_LITERAL)
19413 when Pragma_Memory_Size =>
19416 -- Memory size is simply ignored
19418 Check_No_Identifiers;
19419 Check_Arg_Count (1);
19420 Check_Arg_Is_Integer_Literal (Arg1);
19428 -- The only correct use of this pragma is on its own in a file, in
19429 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19430 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19431 -- check for a file containing nothing but a No_Body pragma). If we
19432 -- attempt to process it during normal semantics processing, it means
19433 -- it was misplaced.
19435 when Pragma_No_Body =>
19439 -----------------------------
19440 -- No_Elaboration_Code_All --
19441 -----------------------------
19443 -- pragma No_Elaboration_Code_All;
19445 when Pragma_No_Elaboration_Code_All =>
19447 Check_Valid_Library_Unit_Pragma;
19449 -- Must appear for a spec or generic spec
19451 if Nkind (Unit (Cunit (Current_Sem_Unit))) not in
19452 N_Generic_Package_Declaration |
19453 N_Generic_Subprogram_Declaration |
19454 N_Package_Declaration |
19455 N_Subprogram_Declaration
19459 ("pragma% can only occur for package "
19460 & "or subprogram spec"));
19463 -- Set flag in unit table
19465 Set_No_Elab_Code_All (Current_Sem_Unit);
19467 -- Set restriction No_Elaboration_Code if this is the main unit
19469 if Current_Sem_Unit = Main_Unit then
19470 Set_Restriction (No_Elaboration_Code, N);
19473 -- If we are in the main unit or in an extended main source unit,
19474 -- then we also add it to the configuration restrictions so that
19475 -- it will apply to all units in the extended main source.
19477 if Current_Sem_Unit = Main_Unit
19478 or else In_Extended_Main_Source_Unit (N)
19480 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19483 -- If in main extended unit, activate transitive with test
19485 if In_Extended_Main_Source_Unit (N) then
19486 Opt.No_Elab_Code_All_Pragma := N;
19489 -----------------------------
19490 -- No_Component_Reordering --
19491 -----------------------------
19493 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19495 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19501 Check_At_Most_N_Arguments (1);
19503 if Arg_Count = 0 then
19504 Check_Valid_Configuration_Pragma;
19505 Opt.No_Component_Reordering := True;
19508 Check_Optional_Identifier (Arg2, Name_Entity);
19509 Check_Arg_Is_Local_Name (Arg1);
19510 E_Id := Get_Pragma_Arg (Arg1);
19512 if Etype (E_Id) = Any_Type then
19516 E := Entity (E_Id);
19518 if not Is_Record_Type (E) then
19519 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19522 Set_No_Reordering (Base_Type (E));
19524 end No_Comp_Reordering;
19526 --------------------------
19527 -- No_Heap_Finalization --
19528 --------------------------
19530 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19532 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19533 Context : constant Node_Id := Parent (N);
19534 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19540 Check_No_Identifiers;
19542 -- The pragma appears in a configuration file
19544 if No (Context) then
19545 Check_Arg_Count (0);
19546 Check_Valid_Configuration_Pragma;
19548 -- Detect a duplicate pragma
19550 if Present (No_Heap_Finalization_Pragma) then
19553 Prev => No_Heap_Finalization_Pragma);
19557 No_Heap_Finalization_Pragma := N;
19559 -- Otherwise the pragma should be associated with a library-level
19560 -- named access-to-object type.
19563 Check_Arg_Count (1);
19564 Check_Arg_Is_Local_Name (Arg1);
19566 Find_Type (Typ_Arg);
19567 Typ := Entity (Typ_Arg);
19569 -- The type being subjected to the pragma is erroneous
19571 if Typ = Any_Type then
19572 Error_Pragma ("cannot find type referenced by pragma %");
19574 -- The pragma is applied to an incomplete or generic formal
19575 -- type way too early.
19577 elsif Rep_Item_Too_Early (Typ, N) then
19581 Typ := Underlying_Type (Typ);
19584 -- The pragma must apply to an access-to-object type
19586 if Ekind (Typ) in E_Access_Type | E_General_Access_Type then
19589 -- Give a detailed error message on all other access type kinds
19591 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19593 ("pragma % cannot apply to access protected subprogram "
19596 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19598 ("pragma % cannot apply to access subprogram type");
19600 elsif Is_Anonymous_Access_Type (Typ) then
19602 ("pragma % cannot apply to anonymous access type");
19604 -- Give a general error message in case the pragma applies to a
19605 -- non-access type.
19609 ("pragma % must apply to library level access type");
19612 -- At this point the argument denotes an access-to-object type.
19613 -- Ensure that the type is declared at the library level.
19615 if Is_Library_Level_Entity (Typ) then
19618 -- Quietly ignore an access-to-object type originally declared
19619 -- at the library level within a generic, but instantiated at
19620 -- a non-library level. As a result the access-to-object type
19621 -- "loses" its No_Heap_Finalization property.
19623 elsif In_Instance then
19628 ("pragma % must apply to library level access type");
19631 -- Detect a duplicate pragma
19633 if Present (No_Heap_Finalization_Pragma) then
19636 Prev => No_Heap_Finalization_Pragma);
19640 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19642 if Present (Prev) then
19650 Record_Rep_Item (Typ, N);
19652 end No_Heap_Finalization;
19658 -- pragma No_Inline ( NAME {, NAME} );
19660 when Pragma_No_Inline =>
19662 Process_Inline (Suppressed);
19668 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19670 when Pragma_No_Return => No_Return : declare
19676 Ghost_Error_Posted : Boolean := False;
19677 -- Flag set when an error concerning the illegal mix of Ghost and
19678 -- non-Ghost subprograms is emitted.
19680 Ghost_Id : Entity_Id := Empty;
19681 -- The entity of the first Ghost procedure encountered while
19682 -- processing the arguments of the pragma.
19686 Check_At_Least_N_Arguments (1);
19688 -- Loop through arguments of pragma
19691 while Present (Arg) loop
19692 Check_Arg_Is_Local_Name (Arg);
19693 Id := Get_Pragma_Arg (Arg);
19696 if not Is_Entity_Name (Id) then
19697 Error_Pragma_Arg ("entity name required", Arg);
19700 if Etype (Id) = Any_Type then
19704 -- Loop to find matching procedures or functions (Ada 2020)
19710 and then Scope (E) = Current_Scope
19712 -- Ada 2020 (AI12-0269): A function can be No_Return
19714 if Ekind (E) in E_Generic_Procedure | E_Procedure
19715 or else (Ada_Version >= Ada_2020
19717 Ekind (E) in E_Generic_Function | E_Function)
19719 -- Check that the pragma is not applied to a body.
19720 -- First check the specless body case, to give a
19721 -- different error message. These checks do not apply
19722 -- if Relaxed_RM_Semantics, to accommodate other Ada
19723 -- compilers. Disable these checks under -gnatd.J.
19725 if not Debug_Flag_Dot_JJ then
19726 if Nkind (Parent (Declaration_Node (E))) =
19728 and then not Relaxed_RM_Semantics
19731 ("pragma% requires separate spec and must come "
19735 -- Now the "specful" body case
19737 if Rep_Item_Too_Late (E, N) then
19744 -- A pragma that applies to a Ghost entity becomes Ghost
19745 -- for the purposes of legality checks and removal of
19746 -- ignored Ghost code.
19748 Mark_Ghost_Pragma (N, E);
19750 -- Capture the entity of the first Ghost procedure being
19751 -- processed for error detection purposes.
19753 if Is_Ghost_Entity (E) then
19754 if No (Ghost_Id) then
19758 -- Otherwise the subprogram is non-Ghost. It is illegal
19759 -- to mix references to Ghost and non-Ghost entities
19762 elsif Present (Ghost_Id)
19763 and then not Ghost_Error_Posted
19765 Ghost_Error_Posted := True;
19767 Error_Msg_Name_1 := Pname;
19769 ("pragma % cannot mention ghost and non-ghost "
19770 & "procedures", N);
19772 Error_Msg_Sloc := Sloc (Ghost_Id);
19773 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
19775 Error_Msg_Sloc := Sloc (E);
19776 Error_Msg_NE ("\& # declared as non-ghost", N, E);
19779 -- Set flag on any alias as well
19781 if Is_Overloadable (E) and then Present (Alias (E)) then
19782 Set_No_Return (Alias (E));
19788 exit when From_Aspect_Specification (N);
19792 -- If entity in not in current scope it may be the enclosing
19793 -- suprogram body to which the aspect applies.
19796 if Entity (Id) = Current_Scope
19797 and then From_Aspect_Specification (N)
19799 Set_No_Return (Entity (Id));
19801 elsif Ada_Version >= Ada_2020 then
19803 ("no subprogram& found for pragma%", Arg);
19806 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
19818 -- pragma No_Run_Time;
19820 -- Note: this pragma is retained for backwards compatibility. See
19821 -- body of Rtsfind for full details on its handling.
19823 when Pragma_No_Run_Time =>
19825 Check_Valid_Configuration_Pragma;
19826 Check_Arg_Count (0);
19828 -- Remove backward compatibility if Build_Type is FSF or GPL and
19829 -- generate a warning.
19832 Ignore : constant Boolean := Build_Type in FSF .. GPL;
19835 Error_Pragma ("pragma% is ignored, has no effect??");
19837 No_Run_Time_Mode := True;
19838 Configurable_Run_Time_Mode := True;
19840 -- Set Duration to 32 bits if word size is 32
19842 if Ttypes.System_Word_Size = 32 then
19843 Duration_32_Bits_On_Target := True;
19846 -- Set appropriate restrictions
19848 Set_Restriction (No_Finalization, N);
19849 Set_Restriction (No_Exception_Handlers, N);
19850 Set_Restriction (Max_Tasks, N, 0);
19851 Set_Restriction (No_Tasking, N);
19855 -----------------------
19856 -- No_Tagged_Streams --
19857 -----------------------
19859 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19861 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
19867 Check_At_Most_N_Arguments (1);
19869 -- One argument case
19871 if Arg_Count = 1 then
19872 Check_Optional_Identifier (Arg1, Name_Entity);
19873 Check_Arg_Is_Local_Name (Arg1);
19874 E_Id := Get_Pragma_Arg (Arg1);
19876 if Etype (E_Id) = Any_Type then
19880 E := Entity (E_Id);
19882 Check_Duplicate_Pragma (E);
19884 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
19886 ("argument for pragma% must be root tagged type", Arg1);
19889 if Rep_Item_Too_Early (E, N)
19891 Rep_Item_Too_Late (E, N)
19895 Set_No_Tagged_Streams_Pragma (E, N);
19898 -- Zero argument case
19901 Check_Is_In_Decl_Part_Or_Package_Spec;
19902 No_Tagged_Streams := N;
19904 end No_Tagged_Strms;
19906 ------------------------
19907 -- No_Strict_Aliasing --
19908 ------------------------
19910 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19912 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
19918 Check_At_Most_N_Arguments (1);
19920 if Arg_Count = 0 then
19921 Check_Valid_Configuration_Pragma;
19922 Opt.No_Strict_Aliasing := True;
19925 Check_Optional_Identifier (Arg2, Name_Entity);
19926 Check_Arg_Is_Local_Name (Arg1);
19927 E_Id := Get_Pragma_Arg (Arg1);
19929 if Etype (E_Id) = Any_Type then
19933 E := Entity (E_Id);
19935 if not Is_Access_Type (E) then
19936 Error_Pragma_Arg ("pragma% requires access type", Arg1);
19939 Set_No_Strict_Aliasing (Base_Type (E));
19941 end No_Strict_Aliasing;
19943 -----------------------
19944 -- Normalize_Scalars --
19945 -----------------------
19947 -- pragma Normalize_Scalars;
19949 when Pragma_Normalize_Scalars =>
19950 Check_Ada_83_Warning;
19951 Check_Arg_Count (0);
19952 Check_Valid_Configuration_Pragma;
19954 -- Normalize_Scalars creates false positives in CodePeer, and
19955 -- incorrect negative results in GNATprove mode, so ignore this
19956 -- pragma in these modes.
19958 if not (CodePeer_Mode or GNATprove_Mode) then
19959 Normalize_Scalars := True;
19960 Init_Or_Norm_Scalars := True;
19967 -- pragma Obsolescent;
19969 -- pragma Obsolescent (
19970 -- [Message =>] static_string_EXPRESSION
19971 -- [,[Version =>] Ada_05]]);
19973 -- pragma Obsolescent (
19974 -- [Entity =>] NAME
19975 -- [,[Message =>] static_string_EXPRESSION
19976 -- [,[Version =>] Ada_05]] );
19978 when Pragma_Obsolescent => Obsolescent : declare
19982 procedure Set_Obsolescent (E : Entity_Id);
19983 -- Given an entity Ent, mark it as obsolescent if appropriate
19985 ---------------------
19986 -- Set_Obsolescent --
19987 ---------------------
19989 procedure Set_Obsolescent (E : Entity_Id) is
19998 -- A pragma that applies to a Ghost entity becomes Ghost for
19999 -- the purposes of legality checks and removal of ignored Ghost
20002 Mark_Ghost_Pragma (N, E);
20004 -- Entity name was given
20006 if Present (Ename) then
20008 -- If entity name matches, we are fine.
20010 if Chars (Ename) = Chars (Ent) then
20011 Set_Entity (Ename, Ent);
20012 Generate_Reference (Ent, Ename);
20014 -- If entity name does not match, only possibility is an
20015 -- enumeration literal from an enumeration type declaration.
20017 elsif Ekind (Ent) /= E_Enumeration_Type then
20019 ("pragma % entity name does not match declaration");
20022 Ent := First_Literal (E);
20026 ("pragma % entity name does not match any "
20027 & "enumeration literal");
20029 elsif Chars (Ent) = Chars (Ename) then
20030 Set_Entity (Ename, Ent);
20031 Generate_Reference (Ent, Ename);
20035 Next_Literal (Ent);
20041 -- Ent points to entity to be marked
20043 if Arg_Count >= 1 then
20045 -- Deal with static string argument
20047 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20048 S := Strval (Get_Pragma_Arg (Arg1));
20050 for J in 1 .. String_Length (S) loop
20051 if not In_Character_Range (Get_String_Char (S, J)) then
20053 ("pragma% argument does not allow wide characters",
20058 Obsolescent_Warnings.Append
20059 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20061 -- Check for Ada_05 parameter
20063 if Arg_Count /= 1 then
20064 Check_Arg_Count (2);
20067 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20070 Check_Arg_Is_Identifier (Argx);
20072 if Chars (Argx) /= Name_Ada_05 then
20073 Error_Msg_Name_2 := Name_Ada_05;
20075 ("only allowed argument for pragma% is %", Argx);
20078 if Ada_Version_Explicit < Ada_2005
20079 or else not Warn_On_Ada_2005_Compatibility
20087 -- Set flag if pragma active
20090 Set_Is_Obsolescent (Ent);
20094 end Set_Obsolescent;
20096 -- Start of processing for pragma Obsolescent
20101 Check_At_Most_N_Arguments (3);
20103 -- See if first argument specifies an entity name
20107 (Chars (Arg1) = Name_Entity
20109 Nkind (Get_Pragma_Arg (Arg1)) in
20110 N_Character_Literal | N_Identifier | N_Operator_Symbol)
20112 Ename := Get_Pragma_Arg (Arg1);
20114 -- Eliminate first argument, so we can share processing
20118 Arg_Count := Arg_Count - 1;
20120 -- No Entity name argument given
20126 if Arg_Count >= 1 then
20127 Check_Optional_Identifier (Arg1, Name_Message);
20129 if Arg_Count = 2 then
20130 Check_Optional_Identifier (Arg2, Name_Version);
20134 -- Get immediately preceding declaration
20137 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20141 -- Cases where we do not follow anything other than another pragma
20145 -- First case: library level compilation unit declaration with
20146 -- the pragma immediately following the declaration.
20148 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20150 (Defining_Entity (Unit (Parent (Parent (N)))));
20153 -- Case 2: library unit placement for package
20157 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20159 if Is_Package_Or_Generic_Package (Ent) then
20160 Set_Obsolescent (Ent);
20166 -- Cases where we must follow a declaration, including an
20167 -- abstract subprogram declaration, which is not in the
20168 -- other node subtypes.
20171 if Nkind (Decl) not in N_Declaration
20172 and then Nkind (Decl) not in N_Later_Decl_Item
20173 and then Nkind (Decl) not in N_Generic_Declaration
20174 and then Nkind (Decl) not in N_Renaming_Declaration
20175 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20178 ("pragma% misplaced, "
20179 & "must immediately follow a declaration");
20182 Set_Obsolescent (Defining_Entity (Decl));
20192 -- pragma Optimize (Time | Space | Off);
20194 -- The actual check for optimize is done in Gigi. Note that this
20195 -- pragma does not actually change the optimization setting, it
20196 -- simply checks that it is consistent with the pragma.
20198 when Pragma_Optimize =>
20199 Check_No_Identifiers;
20200 Check_Arg_Count (1);
20201 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20203 ------------------------
20204 -- Optimize_Alignment --
20205 ------------------------
20207 -- pragma Optimize_Alignment (Time | Space | Off);
20209 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20211 Check_No_Identifiers;
20212 Check_Arg_Count (1);
20213 Check_Valid_Configuration_Pragma;
20216 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20219 when Name_Off => Opt.Optimize_Alignment := 'O';
20220 when Name_Space => Opt.Optimize_Alignment := 'S';
20221 when Name_Time => Opt.Optimize_Alignment := 'T';
20224 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20228 -- Set indication that mode is set locally. If we are in fact in a
20229 -- configuration pragma file, this setting is harmless since the
20230 -- switch will get reset anyway at the start of each unit.
20232 Optimize_Alignment_Local := True;
20233 end Optimize_Alignment;
20239 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20241 when Pragma_Ordered => Ordered : declare
20242 Assoc : constant Node_Id := Arg1;
20248 Check_No_Identifiers;
20249 Check_Arg_Count (1);
20250 Check_Arg_Is_Local_Name (Arg1);
20252 Type_Id := Get_Pragma_Arg (Assoc);
20253 Find_Type (Type_Id);
20254 Typ := Entity (Type_Id);
20256 if Typ = Any_Type then
20259 Typ := Underlying_Type (Typ);
20262 if not Is_Enumeration_Type (Typ) then
20263 Error_Pragma ("pragma% must specify enumeration type");
20266 Check_First_Subtype (Arg1);
20267 Set_Has_Pragma_Ordered (Base_Type (Typ));
20270 -------------------
20271 -- Overflow_Mode --
20272 -------------------
20274 -- pragma Overflow_Mode
20275 -- ([General => ] MODE [, [Assertions => ] MODE]);
20277 -- MODE := STRICT | MINIMIZED | ELIMINATED
20279 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20280 -- since System.Bignums makes this assumption. This is true of nearly
20281 -- all (all?) targets.
20283 when Pragma_Overflow_Mode => Overflow_Mode : declare
20284 function Get_Overflow_Mode
20286 Arg : Node_Id) return Overflow_Mode_Type;
20287 -- Function to process one pragma argument, Arg. If an identifier
20288 -- is present, it must be Name. Mode type is returned if a valid
20289 -- argument exists, otherwise an error is signalled.
20291 -----------------------
20292 -- Get_Overflow_Mode --
20293 -----------------------
20295 function Get_Overflow_Mode
20297 Arg : Node_Id) return Overflow_Mode_Type
20299 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20302 Check_Optional_Identifier (Arg, Name);
20303 Check_Arg_Is_Identifier (Argx);
20305 if Chars (Argx) = Name_Strict then
20308 elsif Chars (Argx) = Name_Minimized then
20311 elsif Chars (Argx) = Name_Eliminated then
20312 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20314 ("Eliminated not implemented on this target", Argx);
20320 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20322 end Get_Overflow_Mode;
20324 -- Start of processing for Overflow_Mode
20328 Check_At_Least_N_Arguments (1);
20329 Check_At_Most_N_Arguments (2);
20331 -- Process first argument
20333 Scope_Suppress.Overflow_Mode_General :=
20334 Get_Overflow_Mode (Name_General, Arg1);
20336 -- Case of only one argument
20338 if Arg_Count = 1 then
20339 Scope_Suppress.Overflow_Mode_Assertions :=
20340 Scope_Suppress.Overflow_Mode_General;
20342 -- Case of two arguments present
20345 Scope_Suppress.Overflow_Mode_Assertions :=
20346 Get_Overflow_Mode (Name_Assertions, Arg2);
20350 --------------------------
20351 -- Overriding Renamings --
20352 --------------------------
20354 -- pragma Overriding_Renamings;
20356 when Pragma_Overriding_Renamings =>
20358 Check_Arg_Count (0);
20359 Check_Valid_Configuration_Pragma;
20360 Overriding_Renamings := True;
20366 -- pragma Pack (first_subtype_LOCAL_NAME);
20368 when Pragma_Pack => Pack : declare
20369 Assoc : constant Node_Id := Arg1;
20371 Ignore : Boolean := False;
20376 Check_No_Identifiers;
20377 Check_Arg_Count (1);
20378 Check_Arg_Is_Local_Name (Arg1);
20379 Type_Id := Get_Pragma_Arg (Assoc);
20381 if not Is_Entity_Name (Type_Id)
20382 or else not Is_Type (Entity (Type_Id))
20385 ("argument for pragma% must be type or subtype", Arg1);
20388 Find_Type (Type_Id);
20389 Typ := Entity (Type_Id);
20392 or else Rep_Item_Too_Early (Typ, N)
20396 Typ := Underlying_Type (Typ);
20399 -- A pragma that applies to a Ghost entity becomes Ghost for the
20400 -- purposes of legality checks and removal of ignored Ghost code.
20402 Mark_Ghost_Pragma (N, Typ);
20404 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20405 Error_Pragma ("pragma% must specify array or record type");
20408 Check_First_Subtype (Arg1);
20409 Check_Duplicate_Pragma (Typ);
20413 if Is_Array_Type (Typ) then
20414 Ctyp := Component_Type (Typ);
20416 -- Ignore pack that does nothing
20418 if Known_Static_Esize (Ctyp)
20419 and then Known_Static_RM_Size (Ctyp)
20420 and then Esize (Ctyp) = RM_Size (Ctyp)
20421 and then Addressable (Esize (Ctyp))
20426 -- Process OK pragma Pack. Note that if there is a separate
20427 -- component clause present, the Pack will be cancelled. This
20428 -- processing is in Freeze.
20430 if not Rep_Item_Too_Late (Typ, N) then
20432 -- In CodePeer mode, we do not need complex front-end
20433 -- expansions related to pragma Pack, so disable handling
20436 if CodePeer_Mode then
20439 -- Normal case where we do the pack action
20443 Set_Is_Packed (Base_Type (Typ));
20444 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20447 Set_Has_Pragma_Pack (Base_Type (Typ));
20451 -- For record types, the pack is always effective
20453 else pragma Assert (Is_Record_Type (Typ));
20454 if not Rep_Item_Too_Late (Typ, N) then
20455 Set_Is_Packed (Base_Type (Typ));
20456 Set_Has_Pragma_Pack (Base_Type (Typ));
20457 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20468 -- There is nothing to do here, since we did all the processing for
20469 -- this pragma in Par.Prag (so that it works properly even in syntax
20472 when Pragma_Page =>
20479 -- pragma Part_Of (ABSTRACT_STATE);
20481 -- ABSTRACT_STATE ::= NAME
20483 when Pragma_Part_Of => Part_Of : declare
20484 procedure Propagate_Part_Of
20485 (Pack_Id : Entity_Id;
20486 State_Id : Entity_Id;
20487 Instance : Node_Id);
20488 -- Propagate the Part_Of indicator to all abstract states and
20489 -- objects declared in the visible state space of a package
20490 -- denoted by Pack_Id. State_Id is the encapsulating state.
20491 -- Instance is the package instantiation node.
20493 -----------------------
20494 -- Propagate_Part_Of --
20495 -----------------------
20497 procedure Propagate_Part_Of
20498 (Pack_Id : Entity_Id;
20499 State_Id : Entity_Id;
20500 Instance : Node_Id)
20502 Has_Item : Boolean := False;
20503 -- Flag set when the visible state space contains at least one
20504 -- abstract state or variable.
20506 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20507 -- Propagate the Part_Of indicator to all abstract states and
20508 -- objects declared in the visible state space of a package
20509 -- denoted by Pack_Id.
20511 -----------------------
20512 -- Propagate_Part_Of --
20513 -----------------------
20515 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20516 Constits : Elist_Id;
20517 Item_Id : Entity_Id;
20520 -- Traverse the entity chain of the package and set relevant
20521 -- attributes of abstract states and objects declared in the
20522 -- visible state space of the package.
20524 Item_Id := First_Entity (Pack_Id);
20525 while Present (Item_Id)
20526 and then not In_Private_Part (Item_Id)
20528 -- Do not consider internally generated items
20530 if not Comes_From_Source (Item_Id) then
20533 -- Do not consider generic formals or their corresponding
20534 -- actuals because they are not part of a visible state.
20535 -- Note that both entities are marked as hidden.
20537 elsif Is_Hidden (Item_Id) then
20540 -- The Part_Of indicator turns an abstract state or an
20541 -- object into a constituent of the encapsulating state.
20542 -- Note that constants are considered here even though
20543 -- they may not depend on variable input. This check is
20544 -- left to the SPARK prover.
20546 elsif Ekind (Item_Id) in
20547 E_Abstract_State | E_Constant | E_Variable
20550 Constits := Part_Of_Constituents (State_Id);
20552 if No (Constits) then
20553 Constits := New_Elmt_List;
20554 Set_Part_Of_Constituents (State_Id, Constits);
20557 Append_Elmt (Item_Id, Constits);
20558 Set_Encapsulating_State (Item_Id, State_Id);
20560 -- Recursively handle nested packages and instantiations
20562 elsif Ekind (Item_Id) = E_Package then
20563 Propagate_Part_Of (Item_Id);
20566 Next_Entity (Item_Id);
20568 end Propagate_Part_Of;
20570 -- Start of processing for Propagate_Part_Of
20573 Propagate_Part_Of (Pack_Id);
20575 -- Detect a package instantiation that is subject to a Part_Of
20576 -- indicator, but has no visible state.
20578 if not Has_Item then
20580 ("package instantiation & has Part_Of indicator but "
20581 & "lacks visible state", Instance, Pack_Id);
20583 end Propagate_Part_Of;
20587 Constits : Elist_Id;
20589 Encap_Id : Entity_Id;
20590 Item_Id : Entity_Id;
20594 -- Start of processing for Part_Of
20598 Check_No_Identifiers;
20599 Check_Arg_Count (1);
20601 Stmt := Find_Related_Context (N, Do_Checks => True);
20603 -- Object declaration
20605 if Nkind (Stmt) = N_Object_Declaration then
20608 -- Package instantiation
20610 elsif Nkind (Stmt) = N_Package_Instantiation then
20613 -- Single concurrent type declaration
20615 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20618 -- Otherwise the pragma is associated with an illegal construct
20625 -- Extract the entity of the related object declaration or package
20626 -- instantiation. In the case of the instantiation, use the entity
20627 -- of the instance spec.
20629 if Nkind (Stmt) = N_Package_Instantiation then
20630 Stmt := Instance_Spec (Stmt);
20633 Item_Id := Defining_Entity (Stmt);
20635 -- A pragma that applies to a Ghost entity becomes Ghost for the
20636 -- purposes of legality checks and removal of ignored Ghost code.
20638 Mark_Ghost_Pragma (N, Item_Id);
20640 -- Chain the pragma on the contract for further processing by
20641 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20643 Add_Contract_Item (N, Item_Id);
20645 -- A variable may act as constituent of a single concurrent type
20646 -- which in turn could be declared after the variable. Due to this
20647 -- discrepancy, the full analysis of indicator Part_Of is delayed
20648 -- until the end of the enclosing declarative region (see routine
20649 -- Analyze_Part_Of_In_Decl_Part).
20651 if Ekind (Item_Id) = E_Variable then
20654 -- Otherwise indicator Part_Of applies to a constant or a package
20658 Encap := Get_Pragma_Arg (Arg1);
20660 -- Detect any discrepancies between the placement of the
20661 -- constant or package instantiation with respect to state
20662 -- space and the encapsulating state.
20666 Item_Id => Item_Id,
20668 Encap_Id => Encap_Id,
20672 pragma Assert (Present (Encap_Id));
20674 if Ekind (Item_Id) = E_Constant then
20675 Constits := Part_Of_Constituents (Encap_Id);
20677 if No (Constits) then
20678 Constits := New_Elmt_List;
20679 Set_Part_Of_Constituents (Encap_Id, Constits);
20682 Append_Elmt (Item_Id, Constits);
20683 Set_Encapsulating_State (Item_Id, Encap_Id);
20685 -- Propagate the Part_Of indicator to the visible state
20686 -- space of the package instantiation.
20690 (Pack_Id => Item_Id,
20691 State_Id => Encap_Id,
20698 ----------------------------------
20699 -- Partition_Elaboration_Policy --
20700 ----------------------------------
20702 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20704 when Pragma_Partition_Elaboration_Policy => PEP : declare
20705 subtype PEP_Range is Name_Id
20706 range First_Partition_Elaboration_Policy_Name
20707 .. Last_Partition_Elaboration_Policy_Name;
20708 PEP_Val : PEP_Range;
20713 Check_Arg_Count (1);
20714 Check_No_Identifiers;
20715 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20716 Check_Valid_Configuration_Pragma;
20717 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20720 when Name_Concurrent => PEP := 'C';
20721 when Name_Sequential => PEP := 'S';
20724 if Partition_Elaboration_Policy /= ' '
20725 and then Partition_Elaboration_Policy /= PEP
20727 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20729 ("partition elaboration policy incompatible with policy#");
20731 -- Set new policy, but always preserve System_Location since we
20732 -- like the error message with the run time name.
20735 Partition_Elaboration_Policy := PEP;
20737 if Partition_Elaboration_Policy_Sloc /= System_Location then
20738 Partition_Elaboration_Policy_Sloc := Loc;
20747 -- pragma Passive [(PASSIVE_FORM)];
20749 -- PASSIVE_FORM ::= Semaphore | No
20751 when Pragma_Passive =>
20754 if Nkind (Parent (N)) /= N_Task_Definition then
20755 Error_Pragma ("pragma% must be within task definition");
20758 if Arg_Count /= 0 then
20759 Check_Arg_Count (1);
20760 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
20763 ----------------------------------
20764 -- Preelaborable_Initialization --
20765 ----------------------------------
20767 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20769 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
20774 Check_Arg_Count (1);
20775 Check_No_Identifiers;
20776 Check_Arg_Is_Identifier (Arg1);
20777 Check_Arg_Is_Local_Name (Arg1);
20778 Check_First_Subtype (Arg1);
20779 Ent := Entity (Get_Pragma_Arg (Arg1));
20781 -- A pragma that applies to a Ghost entity becomes Ghost for the
20782 -- purposes of legality checks and removal of ignored Ghost code.
20784 Mark_Ghost_Pragma (N, Ent);
20786 -- The pragma may come from an aspect on a private declaration,
20787 -- even if the freeze point at which this is analyzed in the
20788 -- private part after the full view.
20790 if Has_Private_Declaration (Ent)
20791 and then From_Aspect_Specification (N)
20795 -- Check appropriate type argument
20797 elsif Is_Private_Type (Ent)
20798 or else Is_Protected_Type (Ent)
20799 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
20801 -- AI05-0028: The pragma applies to all composite types. Note
20802 -- that we apply this binding interpretation to earlier versions
20803 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20804 -- choice since there are other compilers that do the same.
20806 or else Is_Composite_Type (Ent)
20812 ("pragma % can only be applied to private, formal derived, "
20813 & "protected, or composite type", Arg1);
20816 -- Give an error if the pragma is applied to a protected type that
20817 -- does not qualify (due to having entries, or due to components
20818 -- that do not qualify).
20820 if Is_Protected_Type (Ent)
20821 and then not Has_Preelaborable_Initialization (Ent)
20824 ("protected type & does not have preelaborable "
20825 & "initialization", Ent);
20827 -- Otherwise mark the type as definitely having preelaborable
20831 Set_Known_To_Have_Preelab_Init (Ent);
20834 if Has_Pragma_Preelab_Init (Ent)
20835 and then Warn_On_Redundant_Constructs
20837 Error_Pragma ("?r?duplicate pragma%!");
20839 Set_Has_Pragma_Preelab_Init (Ent);
20843 --------------------
20844 -- Persistent_BSS --
20845 --------------------
20847 -- pragma Persistent_BSS [(object_NAME)];
20849 when Pragma_Persistent_BSS => Persistent_BSS : declare
20856 Check_At_Most_N_Arguments (1);
20858 -- Case of application to specific object (one argument)
20860 if Arg_Count = 1 then
20861 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20863 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
20865 Ekind (Entity (Get_Pragma_Arg (Arg1))) not in
20866 E_Variable | E_Constant
20868 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
20871 Ent := Entity (Get_Pragma_Arg (Arg1));
20873 -- A pragma that applies to a Ghost entity becomes Ghost for
20874 -- the purposes of legality checks and removal of ignored Ghost
20877 Mark_Ghost_Pragma (N, Ent);
20879 -- Check for duplication before inserting in list of
20880 -- representation items.
20882 Check_Duplicate_Pragma (Ent);
20884 if Rep_Item_Too_Late (Ent, N) then
20888 Decl := Parent (Ent);
20890 if Present (Expression (Decl)) then
20891 -- Variables in Persistent_BSS cannot be initialized, so
20892 -- turn off any initialization that might be caused by
20893 -- pragmas Initialize_Scalars or Normalize_Scalars.
20895 if Kill_Range_Check (Expression (Decl)) then
20898 Name_Suppress_Initialization,
20899 Pragma_Argument_Associations => New_List (
20900 Make_Pragma_Argument_Association (Loc,
20901 Expression => New_Occurrence_Of (Ent, Loc))));
20902 Insert_Before (N, Prag);
20907 ("object for pragma% cannot have initialization", Arg1);
20911 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
20913 ("object type for pragma% is not potentially persistent",
20918 Make_Linker_Section_Pragma
20919 (Ent, Loc, ".persistent.bss");
20920 Insert_After (N, Prag);
20923 -- Case of use as configuration pragma with no arguments
20926 Check_Valid_Configuration_Pragma;
20927 Persistent_BSS_Mode := True;
20929 end Persistent_BSS;
20931 --------------------
20932 -- Rename_Pragma --
20933 --------------------
20935 -- pragma Rename_Pragma (
20936 -- [New_Name =>] IDENTIFIER,
20937 -- [Renamed =>] pragma_IDENTIFIER);
20939 when Pragma_Rename_Pragma => Rename_Pragma : declare
20940 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
20941 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
20945 Check_Valid_Configuration_Pragma;
20946 Check_Arg_Count (2);
20947 Check_Optional_Identifier (Arg1, Name_New_Name);
20948 Check_Optional_Identifier (Arg2, Name_Renamed);
20950 if Nkind (New_Name) /= N_Identifier then
20951 Error_Pragma_Arg ("identifier expected", Arg1);
20954 if Nkind (Old_Name) /= N_Identifier then
20955 Error_Pragma_Arg ("identifier expected", Arg2);
20958 -- The New_Name arg should not be an existing pragma (but we allow
20959 -- it; it's just a warning). The Old_Name arg must be an existing
20962 if Is_Pragma_Name (Chars (New_Name)) then
20963 Error_Pragma_Arg ("??pragma is already defined", Arg1);
20966 if not Is_Pragma_Name (Chars (Old_Name)) then
20967 Error_Pragma_Arg ("existing pragma name expected", Arg1);
20970 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
20973 -----------------------------------
20974 -- Post/Post_Class/Postcondition --
20975 -----------------------------------
20977 -- pragma Post (Boolean_EXPRESSION);
20978 -- pragma Post_Class (Boolean_EXPRESSION);
20979 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
20980 -- [,[Message =>] String_EXPRESSION]);
20982 -- Characteristics:
20984 -- * Analysis - The annotation undergoes initial checks to verify
20985 -- the legal placement and context. Secondary checks preanalyze the
20988 -- Analyze_Pre_Post_Condition_In_Decl_Part
20990 -- * Expansion - The annotation is expanded during the expansion of
20991 -- the related subprogram [body] contract as performed in:
20993 -- Expand_Subprogram_Contract
20995 -- * Template - The annotation utilizes the generic template of the
20996 -- related subprogram [body] when it is:
20998 -- aspect on subprogram declaration
20999 -- aspect on stand-alone subprogram body
21000 -- pragma on stand-alone subprogram body
21002 -- The annotation must prepare its own template when it is:
21004 -- pragma on subprogram declaration
21006 -- * Globals - Capture of global references must occur after full
21009 -- * Instance - The annotation is instantiated automatically when
21010 -- the related generic subprogram [body] is instantiated except for
21011 -- the "pragma on subprogram declaration" case. In that scenario
21012 -- the annotation must instantiate itself.
21015 | Pragma_Post_Class
21016 | Pragma_Postcondition
21018 Analyze_Pre_Post_Condition;
21020 --------------------------------
21021 -- Pre/Pre_Class/Precondition --
21022 --------------------------------
21024 -- pragma Pre (Boolean_EXPRESSION);
21025 -- pragma Pre_Class (Boolean_EXPRESSION);
21026 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21027 -- [,[Message =>] String_EXPRESSION]);
21029 -- Characteristics:
21031 -- * Analysis - The annotation undergoes initial checks to verify
21032 -- the legal placement and context. Secondary checks preanalyze the
21035 -- Analyze_Pre_Post_Condition_In_Decl_Part
21037 -- * Expansion - The annotation is expanded during the expansion of
21038 -- the related subprogram [body] contract as performed in:
21040 -- Expand_Subprogram_Contract
21042 -- * Template - The annotation utilizes the generic template of the
21043 -- related subprogram [body] when it is:
21045 -- aspect on subprogram declaration
21046 -- aspect on stand-alone subprogram body
21047 -- pragma on stand-alone subprogram body
21049 -- The annotation must prepare its own template when it is:
21051 -- pragma on subprogram declaration
21053 -- * Globals - Capture of global references must occur after full
21056 -- * Instance - The annotation is instantiated automatically when
21057 -- the related generic subprogram [body] is instantiated except for
21058 -- the "pragma on subprogram declaration" case. In that scenario
21059 -- the annotation must instantiate itself.
21063 | Pragma_Precondition
21065 Analyze_Pre_Post_Condition;
21071 -- pragma Predicate
21072 -- ([Entity =>] type_LOCAL_NAME,
21073 -- [Check =>] boolean_EXPRESSION);
21075 when Pragma_Predicate => Predicate : declare
21082 Check_Arg_Count (2);
21083 Check_Optional_Identifier (Arg1, Name_Entity);
21084 Check_Optional_Identifier (Arg2, Name_Check);
21086 Check_Arg_Is_Local_Name (Arg1);
21088 Type_Id := Get_Pragma_Arg (Arg1);
21089 Find_Type (Type_Id);
21090 Typ := Entity (Type_Id);
21092 if Typ = Any_Type then
21096 -- A pragma that applies to a Ghost entity becomes Ghost for the
21097 -- purposes of legality checks and removal of ignored Ghost code.
21099 Mark_Ghost_Pragma (N, Typ);
21101 -- The remaining processing is simply to link the pragma on to
21102 -- the rep item chain, for processing when the type is frozen.
21103 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21104 -- mark the type as having predicates.
21106 -- If the current policy for predicate checking is Ignore mark the
21107 -- subtype accordingly. In the case of predicates we consider them
21108 -- enabled unless Ignore is specified (either directly or with a
21109 -- general Assertion_Policy pragma) to preserve existing warnings.
21111 Set_Has_Predicates (Typ);
21113 -- Indicate that the pragma must be processed at the point the
21114 -- type is frozen, as is done for the corresponding aspect.
21116 Set_Has_Delayed_Aspects (Typ);
21117 Set_Has_Delayed_Freeze (Typ);
21119 Set_Predicates_Ignored (Typ,
21120 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21121 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21124 -----------------------
21125 -- Predicate_Failure --
21126 -----------------------
21128 -- pragma Predicate_Failure
21129 -- ([Entity =>] type_LOCAL_NAME,
21130 -- [Message =>] string_EXPRESSION);
21132 when Pragma_Predicate_Failure => Predicate_Failure : declare
21139 Check_Arg_Count (2);
21140 Check_Optional_Identifier (Arg1, Name_Entity);
21141 Check_Optional_Identifier (Arg2, Name_Message);
21143 Check_Arg_Is_Local_Name (Arg1);
21145 Type_Id := Get_Pragma_Arg (Arg1);
21146 Find_Type (Type_Id);
21147 Typ := Entity (Type_Id);
21149 if Typ = Any_Type then
21153 -- A pragma that applies to a Ghost entity becomes Ghost for the
21154 -- purposes of legality checks and removal of ignored Ghost code.
21156 Mark_Ghost_Pragma (N, Typ);
21158 -- The remaining processing is simply to link the pragma on to
21159 -- the rep item chain, for processing when the type is frozen.
21160 -- This is accomplished by a call to Rep_Item_Too_Late.
21162 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21163 end Predicate_Failure;
21169 -- pragma Preelaborate [(library_unit_NAME)];
21171 -- Set the flag Is_Preelaborated of program unit name entity
21173 when Pragma_Preelaborate => Preelaborate : declare
21174 Pa : constant Node_Id := Parent (N);
21175 Pk : constant Node_Kind := Nkind (Pa);
21179 Check_Ada_83_Warning;
21180 Check_Valid_Library_Unit_Pragma;
21182 Ent := Find_Lib_Unit_Name;
21184 -- A pragma that applies to a Ghost entity becomes Ghost for the
21185 -- purposes of legality checks and removal of ignored Ghost code.
21187 Mark_Ghost_Pragma (N, Ent);
21188 Check_Duplicate_Pragma (Ent);
21190 -- This filters out pragmas inside generic parents that show up
21191 -- inside instantiations. Pragmas that come from aspects in the
21192 -- unit are not ignored.
21194 if Present (Ent) then
21195 if Pk = N_Package_Specification
21196 and then Present (Generic_Parent (Pa))
21197 and then not From_Aspect_Specification (N)
21202 if not Debug_Flag_U then
21203 Set_Is_Preelaborated (Ent);
21205 if Legacy_Elaboration_Checks then
21206 Set_Suppress_Elaboration_Warnings (Ent);
21213 -------------------------------
21214 -- Prefix_Exception_Messages --
21215 -------------------------------
21217 -- pragma Prefix_Exception_Messages;
21219 when Pragma_Prefix_Exception_Messages =>
21221 Check_Valid_Configuration_Pragma;
21222 Check_Arg_Count (0);
21223 Prefix_Exception_Messages := True;
21229 -- pragma Priority (EXPRESSION);
21231 when Pragma_Priority => Priority : declare
21232 P : constant Node_Id := Parent (N);
21237 Check_No_Identifiers;
21238 Check_Arg_Count (1);
21242 if Nkind (P) = N_Subprogram_Body then
21243 Check_In_Main_Program;
21245 Ent := Defining_Unit_Name (Specification (P));
21247 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21248 Ent := Defining_Identifier (Ent);
21251 Arg := Get_Pragma_Arg (Arg1);
21252 Analyze_And_Resolve (Arg, Standard_Integer);
21256 if not Is_OK_Static_Expression (Arg) then
21257 Flag_Non_Static_Expr
21258 ("main subprogram priority is not static!", Arg);
21261 -- If constraint error, then we already signalled an error
21263 elsif Raises_Constraint_Error (Arg) then
21266 -- Otherwise check in range except if Relaxed_RM_Semantics
21267 -- where we ignore the value if out of range.
21270 if not Relaxed_RM_Semantics
21271 and then not Is_In_Range (Arg, RTE (RE_Priority))
21274 ("main subprogram priority is out of range", Arg1);
21277 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21281 -- Load an arbitrary entity from System.Tasking.Stages or
21282 -- System.Tasking.Restricted.Stages (depending on the
21283 -- supported profile) to make sure that one of these packages
21284 -- is implicitly with'ed, since we need to have the tasking
21285 -- run time active for the pragma Priority to have any effect.
21286 -- Previously we with'ed the package System.Tasking, but this
21287 -- package does not trigger the required initialization of the
21288 -- run-time library.
21291 Discard : Entity_Id;
21292 pragma Warnings (Off, Discard);
21294 if Restricted_Profile then
21295 Discard := RTE (RE_Activate_Restricted_Tasks);
21297 Discard := RTE (RE_Activate_Tasks);
21301 -- Task or Protected, must be of type Integer
21303 elsif Nkind (P) in N_Protected_Definition | N_Task_Definition then
21304 Arg := Get_Pragma_Arg (Arg1);
21305 Ent := Defining_Identifier (Parent (P));
21307 -- The expression must be analyzed in the special manner
21308 -- described in "Handling of Default and Per-Object
21309 -- Expressions" in sem.ads.
21311 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21313 if not Is_OK_Static_Expression (Arg) then
21314 Check_Restriction (Static_Priorities, Arg);
21317 -- Anything else is incorrect
21323 -- Check duplicate pragma before we chain the pragma in the Rep
21324 -- Item chain of Ent.
21326 Check_Duplicate_Pragma (Ent);
21327 Record_Rep_Item (Ent, N);
21330 -----------------------------------
21331 -- Priority_Specific_Dispatching --
21332 -----------------------------------
21334 -- pragma Priority_Specific_Dispatching (
21335 -- policy_IDENTIFIER,
21336 -- first_priority_EXPRESSION,
21337 -- last_priority_EXPRESSION);
21339 when Pragma_Priority_Specific_Dispatching =>
21340 Priority_Specific_Dispatching : declare
21341 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21342 -- This is the entity System.Any_Priority;
21345 Lower_Bound : Node_Id;
21346 Upper_Bound : Node_Id;
21352 Check_Arg_Count (3);
21353 Check_No_Identifiers;
21354 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21355 Check_Valid_Configuration_Pragma;
21356 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21357 DP := Fold_Upper (Name_Buffer (1));
21359 Lower_Bound := Get_Pragma_Arg (Arg2);
21360 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21361 Lower_Val := Expr_Value (Lower_Bound);
21363 Upper_Bound := Get_Pragma_Arg (Arg3);
21364 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21365 Upper_Val := Expr_Value (Upper_Bound);
21367 -- It is not allowed to use Task_Dispatching_Policy and
21368 -- Priority_Specific_Dispatching in the same partition.
21370 if Task_Dispatching_Policy /= ' ' then
21371 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21373 ("pragma% incompatible with Task_Dispatching_Policy#");
21375 -- Check lower bound in range
21377 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21379 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21382 ("first_priority is out of range", Arg2);
21384 -- Check upper bound in range
21386 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21388 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21391 ("last_priority is out of range", Arg3);
21393 -- Check that the priority range is valid
21395 elsif Lower_Val > Upper_Val then
21397 ("last_priority_expression must be greater than or equal to "
21398 & "first_priority_expression");
21400 -- Store the new policy, but always preserve System_Location since
21401 -- we like the error message with the run-time name.
21404 -- Check overlapping in the priority ranges specified in other
21405 -- Priority_Specific_Dispatching pragmas within the same
21406 -- partition. We can only check those we know about.
21409 Specific_Dispatching.First .. Specific_Dispatching.Last
21411 if Specific_Dispatching.Table (J).First_Priority in
21412 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21413 or else Specific_Dispatching.Table (J).Last_Priority in
21414 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21417 Specific_Dispatching.Table (J).Pragma_Loc;
21419 ("priority range overlaps with "
21420 & "Priority_Specific_Dispatching#");
21424 -- The use of Priority_Specific_Dispatching is incompatible
21425 -- with Task_Dispatching_Policy.
21427 if Task_Dispatching_Policy /= ' ' then
21428 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21430 ("Priority_Specific_Dispatching incompatible "
21431 & "with Task_Dispatching_Policy#");
21434 -- The use of Priority_Specific_Dispatching forces ceiling
21437 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21438 Error_Msg_Sloc := Locking_Policy_Sloc;
21440 ("Priority_Specific_Dispatching incompatible "
21441 & "with Locking_Policy#");
21443 -- Set the Ceiling_Locking policy, but preserve System_Location
21444 -- since we like the error message with the run time name.
21447 Locking_Policy := 'C';
21449 if Locking_Policy_Sloc /= System_Location then
21450 Locking_Policy_Sloc := Loc;
21454 -- Add entry in the table
21456 Specific_Dispatching.Append
21457 ((Dispatching_Policy => DP,
21458 First_Priority => UI_To_Int (Lower_Val),
21459 Last_Priority => UI_To_Int (Upper_Val),
21460 Pragma_Loc => Loc));
21462 end Priority_Specific_Dispatching;
21468 -- pragma Profile (profile_IDENTIFIER);
21470 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21472 when Pragma_Profile =>
21474 Check_Arg_Count (1);
21475 Check_Valid_Configuration_Pragma;
21476 Check_No_Identifiers;
21479 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21482 if Nkind (Argx) /= N_Identifier then
21484 ("argument of pragma Profile must be an identifier", N);
21486 elsif Chars (Argx) = Name_Ravenscar then
21487 Set_Ravenscar_Profile (Ravenscar, N);
21489 elsif Chars (Argx) = Name_Jorvik then
21490 Set_Ravenscar_Profile (Jorvik, N);
21492 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21493 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21495 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21496 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21498 elsif Chars (Argx) = Name_Restricted then
21499 Set_Profile_Restrictions
21501 N, Warn => Treat_Restrictions_As_Warnings);
21503 elsif Chars (Argx) = Name_Rational then
21504 Set_Rational_Profile;
21506 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21507 Set_Profile_Restrictions
21508 (No_Implementation_Extensions,
21509 N, Warn => Treat_Restrictions_As_Warnings);
21512 Error_Pragma_Arg ("& is not a valid profile", Argx);
21516 ----------------------
21517 -- Profile_Warnings --
21518 ----------------------
21520 -- pragma Profile_Warnings (profile_IDENTIFIER);
21522 -- profile_IDENTIFIER => Restricted | Ravenscar
21524 when Pragma_Profile_Warnings =>
21526 Check_Arg_Count (1);
21527 Check_Valid_Configuration_Pragma;
21528 Check_No_Identifiers;
21531 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21534 if Chars (Argx) = Name_Ravenscar then
21535 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21537 elsif Chars (Argx) = Name_Restricted then
21538 Set_Profile_Restrictions (Restricted, N, Warn => True);
21540 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21541 Set_Profile_Restrictions
21542 (No_Implementation_Extensions, N, Warn => True);
21545 Error_Pragma_Arg ("& is not a valid profile", Argx);
21549 --------------------------
21550 -- Propagate_Exceptions --
21551 --------------------------
21553 -- pragma Propagate_Exceptions;
21555 -- Note: this pragma is obsolete and has no effect
21557 when Pragma_Propagate_Exceptions =>
21559 Check_Arg_Count (0);
21561 if Warn_On_Obsolescent_Feature then
21563 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21564 "and has no effect?j?", N);
21567 -----------------------------
21568 -- Provide_Shift_Operators --
21569 -----------------------------
21571 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21573 when Pragma_Provide_Shift_Operators =>
21574 Provide_Shift_Operators : declare
21577 procedure Declare_Shift_Operator (Nam : Name_Id);
21578 -- Insert declaration and pragma Instrinsic for named shift op
21580 ----------------------------
21581 -- Declare_Shift_Operator --
21582 ----------------------------
21584 procedure Declare_Shift_Operator (Nam : Name_Id) is
21590 Make_Subprogram_Declaration (Loc,
21591 Make_Function_Specification (Loc,
21592 Defining_Unit_Name =>
21593 Make_Defining_Identifier (Loc, Chars => Nam),
21595 Result_Definition =>
21596 Make_Identifier (Loc, Chars => Chars (Ent)),
21598 Parameter_Specifications => New_List (
21599 Make_Parameter_Specification (Loc,
21600 Defining_Identifier =>
21601 Make_Defining_Identifier (Loc, Name_Value),
21603 Make_Identifier (Loc, Chars => Chars (Ent))),
21605 Make_Parameter_Specification (Loc,
21606 Defining_Identifier =>
21607 Make_Defining_Identifier (Loc, Name_Amount),
21609 New_Occurrence_Of (Standard_Natural, Loc)))));
21613 Chars => Name_Import,
21614 Pragma_Argument_Associations => New_List (
21615 Make_Pragma_Argument_Association (Loc,
21616 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21617 Make_Pragma_Argument_Association (Loc,
21618 Expression => Make_Identifier (Loc, Nam))));
21620 Insert_After (N, Import);
21621 Insert_After (N, Func);
21622 end Declare_Shift_Operator;
21624 -- Start of processing for Provide_Shift_Operators
21628 Check_Arg_Count (1);
21629 Check_Arg_Is_Local_Name (Arg1);
21631 Arg1 := Get_Pragma_Arg (Arg1);
21633 -- We must have an entity name
21635 if not Is_Entity_Name (Arg1) then
21637 ("pragma % must apply to integer first subtype", Arg1);
21640 -- If no Entity, means there was a prior error so ignore
21642 if Present (Entity (Arg1)) then
21643 Ent := Entity (Arg1);
21645 -- Apply error checks
21647 if not Is_First_Subtype (Ent) then
21649 ("cannot apply pragma %",
21650 "\& is not a first subtype",
21653 elsif not Is_Integer_Type (Ent) then
21655 ("cannot apply pragma %",
21656 "\& is not an integer type",
21659 elsif Has_Shift_Operator (Ent) then
21661 ("cannot apply pragma %",
21662 "\& already has declared shift operators",
21665 elsif Is_Frozen (Ent) then
21667 ("pragma % appears too late",
21668 "\& is already frozen",
21672 -- Now declare the operators. We do this during analysis rather
21673 -- than expansion, since we want the operators available if we
21674 -- are operating in -gnatc mode.
21676 Declare_Shift_Operator (Name_Rotate_Left);
21677 Declare_Shift_Operator (Name_Rotate_Right);
21678 Declare_Shift_Operator (Name_Shift_Left);
21679 Declare_Shift_Operator (Name_Shift_Right);
21680 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21682 end Provide_Shift_Operators;
21688 -- pragma Psect_Object (
21689 -- [Internal =>] LOCAL_NAME,
21690 -- [, [External =>] EXTERNAL_SYMBOL]
21691 -- [, [Size =>] EXTERNAL_SYMBOL]);
21693 when Pragma_Common_Object
21694 | Pragma_Psect_Object
21696 Psect_Object : declare
21697 Args : Args_List (1 .. 3);
21698 Names : constant Name_List (1 .. 3) := (
21703 Internal : Node_Id renames Args (1);
21704 External : Node_Id renames Args (2);
21705 Size : Node_Id renames Args (3);
21707 Def_Id : Entity_Id;
21709 procedure Check_Arg (Arg : Node_Id);
21710 -- Checks that argument is either a string literal or an
21711 -- identifier, and posts error message if not.
21717 procedure Check_Arg (Arg : Node_Id) is
21719 if Nkind (Original_Node (Arg)) not in
21720 N_String_Literal | N_Identifier
21723 ("inappropriate argument for pragma %", Arg);
21727 -- Start of processing for Common_Object/Psect_Object
21731 Gather_Associations (Names, Args);
21732 Process_Extended_Import_Export_Internal_Arg (Internal);
21734 Def_Id := Entity (Internal);
21736 if Ekind (Def_Id) not in E_Constant | E_Variable then
21738 ("pragma% must designate an object", Internal);
21741 Check_Arg (Internal);
21743 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21745 ("cannot use pragma% for imported/exported object",
21749 if Is_Concurrent_Type (Etype (Internal)) then
21751 ("cannot specify pragma % for task/protected object",
21755 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
21757 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
21759 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
21762 if Ekind (Def_Id) = E_Constant then
21764 ("cannot specify pragma % for a constant", Internal);
21767 if Is_Record_Type (Etype (Internal)) then
21773 Ent := First_Entity (Etype (Internal));
21774 while Present (Ent) loop
21775 Decl := Declaration_Node (Ent);
21777 if Ekind (Ent) = E_Component
21778 and then Nkind (Decl) = N_Component_Declaration
21779 and then Present (Expression (Decl))
21780 and then Warn_On_Export_Import
21783 ("?x?object for pragma % has defaults", Internal);
21793 if Present (Size) then
21797 if Present (External) then
21798 Check_Arg_Is_External_Name (External);
21801 -- If all error tests pass, link pragma on to the rep item chain
21803 Record_Rep_Item (Def_Id, N);
21810 -- pragma Pure [(library_unit_NAME)];
21812 when Pragma_Pure => Pure : declare
21816 Check_Ada_83_Warning;
21818 -- If the pragma comes from a subprogram instantiation, nothing to
21819 -- check, this can happen at any level of nesting.
21821 if Is_Wrapper_Package (Current_Scope) then
21824 Check_Valid_Library_Unit_Pragma;
21827 Ent := Find_Lib_Unit_Name;
21829 -- A pragma that applies to a Ghost entity becomes Ghost for the
21830 -- purposes of legality checks and removal of ignored Ghost code.
21832 Mark_Ghost_Pragma (N, Ent);
21834 if not Debug_Flag_U then
21836 Set_Has_Pragma_Pure (Ent);
21838 if Legacy_Elaboration_Checks then
21839 Set_Suppress_Elaboration_Warnings (Ent);
21844 -------------------
21845 -- Pure_Function --
21846 -------------------
21848 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21850 when Pragma_Pure_Function => Pure_Function : declare
21851 Def_Id : Entity_Id;
21854 Effective : Boolean := False;
21855 Orig_Def : Entity_Id;
21856 Same_Decl : Boolean := False;
21860 Check_Arg_Count (1);
21861 Check_Optional_Identifier (Arg1, Name_Entity);
21862 Check_Arg_Is_Local_Name (Arg1);
21863 E_Id := Get_Pragma_Arg (Arg1);
21865 if Etype (E_Id) = Any_Type then
21869 -- Loop through homonyms (overloadings) of referenced entity
21871 E := Entity (E_Id);
21873 -- A pragma that applies to a Ghost entity becomes Ghost for the
21874 -- purposes of legality checks and removal of ignored Ghost code.
21876 Mark_Ghost_Pragma (N, E);
21878 if Present (E) then
21880 Def_Id := Get_Base_Subprogram (E);
21882 if Ekind (Def_Id) not in
21883 E_Function | E_Generic_Function | E_Operator
21886 ("pragma% requires a function name", Arg1);
21889 -- When we have a generic function we must jump up a level
21890 -- to the declaration of the wrapper package itself.
21892 Orig_Def := Def_Id;
21894 if Is_Generic_Instance (Def_Id) then
21895 while Nkind (Orig_Def) /= N_Package_Declaration loop
21896 Orig_Def := Parent (Orig_Def);
21900 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
21902 Set_Is_Pure (Def_Id);
21904 if not Has_Pragma_Pure_Function (Def_Id) then
21905 Set_Has_Pragma_Pure_Function (Def_Id);
21910 exit when From_Aspect_Specification (N);
21912 exit when No (E) or else Scope (E) /= Current_Scope;
21916 and then Warn_On_Redundant_Constructs
21919 ("pragma Pure_Function on& is redundant?r?",
21922 elsif not Same_Decl then
21924 ("pragma% argument must be in same declarative part",
21930 --------------------
21931 -- Queuing_Policy --
21932 --------------------
21934 -- pragma Queuing_Policy (policy_IDENTIFIER);
21936 when Pragma_Queuing_Policy => declare
21940 Check_Ada_83_Warning;
21941 Check_Arg_Count (1);
21942 Check_No_Identifiers;
21943 Check_Arg_Is_Queuing_Policy (Arg1);
21944 Check_Valid_Configuration_Pragma;
21945 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21946 QP := Fold_Upper (Name_Buffer (1));
21948 if Queuing_Policy /= ' '
21949 and then Queuing_Policy /= QP
21951 Error_Msg_Sloc := Queuing_Policy_Sloc;
21952 Error_Pragma ("queuing policy incompatible with policy#");
21954 -- Set new policy, but always preserve System_Location since we
21955 -- like the error message with the run time name.
21958 Queuing_Policy := QP;
21960 if Queuing_Policy_Sloc /= System_Location then
21961 Queuing_Policy_Sloc := Loc;
21970 -- pragma Rational, for compatibility with foreign compiler
21972 when Pragma_Rational =>
21973 Set_Rational_Profile;
21975 ---------------------
21976 -- Refined_Depends --
21977 ---------------------
21979 -- pragma Refined_Depends (DEPENDENCY_RELATION);
21981 -- DEPENDENCY_RELATION ::=
21983 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
21985 -- DEPENDENCY_CLAUSE ::=
21986 -- OUTPUT_LIST =>[+] INPUT_LIST
21987 -- | NULL_DEPENDENCY_CLAUSE
21989 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
21991 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
21993 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
21995 -- OUTPUT ::= NAME | FUNCTION_RESULT
21998 -- where FUNCTION_RESULT is a function Result attribute_reference
22000 -- Characteristics:
22002 -- * Analysis - The annotation undergoes initial checks to verify
22003 -- the legal placement and context. Secondary checks fully analyze
22004 -- the dependency clauses/global list in:
22006 -- Analyze_Refined_Depends_In_Decl_Part
22008 -- * Expansion - None.
22010 -- * Template - The annotation utilizes the generic template of the
22011 -- related subprogram body.
22013 -- * Globals - Capture of global references must occur after full
22016 -- * Instance - The annotation is instantiated automatically when
22017 -- the related generic subprogram body is instantiated.
22019 when Pragma_Refined_Depends => Refined_Depends : declare
22020 Body_Id : Entity_Id;
22022 Spec_Id : Entity_Id;
22025 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22029 -- Chain the pragma on the contract for further processing by
22030 -- Analyze_Refined_Depends_In_Decl_Part.
22032 Add_Contract_Item (N, Body_Id);
22034 -- The legality checks of pragmas Refined_Depends and
22035 -- Refined_Global are affected by the SPARK mode in effect and
22036 -- the volatility of the context. In addition these two pragmas
22037 -- are subject to an inherent order:
22039 -- 1) Refined_Global
22040 -- 2) Refined_Depends
22042 -- Analyze all these pragmas in the order outlined above
22044 Analyze_If_Present (Pragma_SPARK_Mode);
22045 Analyze_If_Present (Pragma_Volatile_Function);
22046 Analyze_If_Present (Pragma_Refined_Global);
22047 Analyze_Refined_Depends_In_Decl_Part (N);
22049 end Refined_Depends;
22051 --------------------
22052 -- Refined_Global --
22053 --------------------
22055 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22057 -- GLOBAL_SPECIFICATION ::=
22060 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22062 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22064 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22065 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22066 -- GLOBAL_ITEM ::= NAME
22068 -- Characteristics:
22070 -- * Analysis - The annotation undergoes initial checks to verify
22071 -- the legal placement and context. Secondary checks fully analyze
22072 -- the dependency clauses/global list in:
22074 -- Analyze_Refined_Global_In_Decl_Part
22076 -- * Expansion - None.
22078 -- * Template - The annotation utilizes the generic template of the
22079 -- related subprogram body.
22081 -- * Globals - Capture of global references must occur after full
22084 -- * Instance - The annotation is instantiated automatically when
22085 -- the related generic subprogram body is instantiated.
22087 when Pragma_Refined_Global => Refined_Global : declare
22088 Body_Id : Entity_Id;
22090 Spec_Id : Entity_Id;
22093 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22097 -- Chain the pragma on the contract for further processing by
22098 -- Analyze_Refined_Global_In_Decl_Part.
22100 Add_Contract_Item (N, Body_Id);
22102 -- The legality checks of pragmas Refined_Depends and
22103 -- Refined_Global are affected by the SPARK mode in effect and
22104 -- the volatility of the context. In addition these two pragmas
22105 -- are subject to an inherent order:
22107 -- 1) Refined_Global
22108 -- 2) Refined_Depends
22110 -- Analyze all these pragmas in the order outlined above
22112 Analyze_If_Present (Pragma_SPARK_Mode);
22113 Analyze_If_Present (Pragma_Volatile_Function);
22114 Analyze_Refined_Global_In_Decl_Part (N);
22115 Analyze_If_Present (Pragma_Refined_Depends);
22117 end Refined_Global;
22123 -- pragma Refined_Post (boolean_EXPRESSION);
22125 -- Characteristics:
22127 -- * Analysis - The annotation is fully analyzed immediately upon
22128 -- elaboration as it cannot forward reference entities.
22130 -- * Expansion - The annotation is expanded during the expansion of
22131 -- the related subprogram body contract as performed in:
22133 -- Expand_Subprogram_Contract
22135 -- * Template - The annotation utilizes the generic template of the
22136 -- related subprogram body.
22138 -- * Globals - Capture of global references must occur after full
22141 -- * Instance - The annotation is instantiated automatically when
22142 -- the related generic subprogram body is instantiated.
22144 when Pragma_Refined_Post => Refined_Post : declare
22145 Body_Id : Entity_Id;
22147 Spec_Id : Entity_Id;
22150 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22152 -- Fully analyze the pragma when it appears inside a subprogram
22153 -- body because it cannot benefit from forward references.
22157 -- Chain the pragma on the contract for completeness
22159 Add_Contract_Item (N, Body_Id);
22161 -- The legality checks of pragma Refined_Post are affected by
22162 -- the SPARK mode in effect and the volatility of the context.
22163 -- Analyze all pragmas in a specific order.
22165 Analyze_If_Present (Pragma_SPARK_Mode);
22166 Analyze_If_Present (Pragma_Volatile_Function);
22167 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22169 -- Currently it is not possible to inline pre/postconditions on
22170 -- a subprogram subject to pragma Inline_Always.
22172 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22176 -------------------
22177 -- Refined_State --
22178 -------------------
22180 -- pragma Refined_State (REFINEMENT_LIST);
22182 -- REFINEMENT_LIST ::=
22183 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22185 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22187 -- CONSTITUENT_LIST ::=
22190 -- | (CONSTITUENT {, CONSTITUENT})
22192 -- CONSTITUENT ::= object_NAME | state_NAME
22194 -- Characteristics:
22196 -- * Analysis - The annotation undergoes initial checks to verify
22197 -- the legal placement and context. Secondary checks preanalyze the
22198 -- refinement clauses in:
22200 -- Analyze_Refined_State_In_Decl_Part
22202 -- * Expansion - None.
22204 -- * Template - The annotation utilizes the template of the related
22207 -- * Globals - Capture of global references must occur after full
22210 -- * Instance - The annotation is instantiated automatically when
22211 -- the related generic package body is instantiated.
22213 when Pragma_Refined_State => Refined_State : declare
22214 Pack_Decl : Node_Id;
22215 Spec_Id : Entity_Id;
22219 Check_No_Identifiers;
22220 Check_Arg_Count (1);
22222 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22224 if Nkind (Pack_Decl) /= N_Package_Body then
22229 Spec_Id := Corresponding_Spec (Pack_Decl);
22231 -- A pragma that applies to a Ghost entity becomes Ghost for the
22232 -- purposes of legality checks and removal of ignored Ghost code.
22234 Mark_Ghost_Pragma (N, Spec_Id);
22236 -- Chain the pragma on the contract for further processing by
22237 -- Analyze_Refined_State_In_Decl_Part.
22239 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22241 -- The legality checks of pragma Refined_State are affected by the
22242 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22244 Analyze_If_Present (Pragma_SPARK_Mode);
22246 -- State refinement is allowed only when the corresponding package
22247 -- declaration has non-null pragma Abstract_State. Refinement not
22248 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22250 if SPARK_Mode /= Off
22252 (No (Abstract_States (Spec_Id))
22253 or else Has_Null_Abstract_State (Spec_Id))
22256 ("useless refinement, package & does not define abstract "
22257 & "states", N, Spec_Id);
22262 -----------------------
22263 -- Relative_Deadline --
22264 -----------------------
22266 -- pragma Relative_Deadline (time_span_EXPRESSION);
22268 when Pragma_Relative_Deadline => Relative_Deadline : declare
22269 P : constant Node_Id := Parent (N);
22274 Check_No_Identifiers;
22275 Check_Arg_Count (1);
22277 Arg := Get_Pragma_Arg (Arg1);
22279 -- The expression must be analyzed in the special manner described
22280 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22282 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22286 if Nkind (P) = N_Subprogram_Body then
22287 Check_In_Main_Program;
22289 -- Only Task and subprogram cases allowed
22291 elsif Nkind (P) /= N_Task_Definition then
22295 -- Check duplicate pragma before we set the corresponding flag
22297 if Has_Relative_Deadline_Pragma (P) then
22298 Error_Pragma ("duplicate pragma% not allowed");
22301 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22302 -- Relative_Deadline pragma node cannot be inserted in the Rep
22303 -- Item chain of Ent since it is rewritten by the expander as a
22304 -- procedure call statement that will break the chain.
22306 Set_Has_Relative_Deadline_Pragma (P);
22307 end Relative_Deadline;
22309 ------------------------
22310 -- Remote_Access_Type --
22311 ------------------------
22313 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22315 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22320 Check_Arg_Count (1);
22321 Check_Optional_Identifier (Arg1, Name_Entity);
22322 Check_Arg_Is_Local_Name (Arg1);
22324 E := Entity (Get_Pragma_Arg (Arg1));
22326 -- A pragma that applies to a Ghost entity becomes Ghost for the
22327 -- purposes of legality checks and removal of ignored Ghost code.
22329 Mark_Ghost_Pragma (N, E);
22331 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22332 and then Ekind (E) = E_General_Access_Type
22333 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22334 and then Scope (Root_Type (Directly_Designated_Type (E)))
22336 and then Is_Valid_Remote_Object_Type
22337 (Root_Type (Directly_Designated_Type (E)))
22339 Set_Is_Remote_Types (E);
22343 ("pragma% applies only to formal access-to-class-wide types",
22346 end Remote_Access_Type;
22348 ---------------------------
22349 -- Remote_Call_Interface --
22350 ---------------------------
22352 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22354 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22355 Cunit_Node : Node_Id;
22356 Cunit_Ent : Entity_Id;
22360 Check_Ada_83_Warning;
22361 Check_Valid_Library_Unit_Pragma;
22363 Cunit_Node := Cunit (Current_Sem_Unit);
22364 K := Nkind (Unit (Cunit_Node));
22365 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22367 -- A pragma that applies to a Ghost entity becomes Ghost for the
22368 -- purposes of legality checks and removal of ignored Ghost code.
22370 Mark_Ghost_Pragma (N, Cunit_Ent);
22372 if K = N_Package_Declaration
22373 or else K = N_Generic_Package_Declaration
22374 or else K = N_Subprogram_Declaration
22375 or else K = N_Generic_Subprogram_Declaration
22376 or else (K = N_Subprogram_Body
22377 and then Acts_As_Spec (Unit (Cunit_Node)))
22382 "pragma% must apply to package or subprogram declaration");
22385 Set_Is_Remote_Call_Interface (Cunit_Ent);
22386 end Remote_Call_Interface;
22392 -- pragma Remote_Types [(library_unit_NAME)];
22394 when Pragma_Remote_Types => Remote_Types : declare
22395 Cunit_Node : Node_Id;
22396 Cunit_Ent : Entity_Id;
22399 Check_Ada_83_Warning;
22400 Check_Valid_Library_Unit_Pragma;
22402 Cunit_Node := Cunit (Current_Sem_Unit);
22403 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22405 -- A pragma that applies to a Ghost entity becomes Ghost for the
22406 -- purposes of legality checks and removal of ignored Ghost code.
22408 Mark_Ghost_Pragma (N, Cunit_Ent);
22410 if Nkind (Unit (Cunit_Node)) not in
22411 N_Package_Declaration | N_Generic_Package_Declaration
22414 ("pragma% can only apply to a package declaration");
22417 Set_Is_Remote_Types (Cunit_Ent);
22424 -- pragma Ravenscar;
22426 when Pragma_Ravenscar =>
22428 Check_Arg_Count (0);
22429 Check_Valid_Configuration_Pragma;
22430 Set_Ravenscar_Profile (Ravenscar, N);
22432 if Warn_On_Obsolescent_Feature then
22434 ("pragma Ravenscar is an obsolescent feature?j?", N);
22436 ("|use pragma Profile (Ravenscar) instead?j?", N);
22439 -------------------------
22440 -- Restricted_Run_Time --
22441 -------------------------
22443 -- pragma Restricted_Run_Time;
22445 when Pragma_Restricted_Run_Time =>
22447 Check_Arg_Count (0);
22448 Check_Valid_Configuration_Pragma;
22449 Set_Profile_Restrictions
22450 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22452 if Warn_On_Obsolescent_Feature then
22454 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22457 ("|use pragma Profile (Restricted) instead?j?", N);
22464 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22467 -- restriction_IDENTIFIER
22468 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22470 when Pragma_Restrictions =>
22471 Process_Restrictions_Or_Restriction_Warnings
22472 (Warn => Treat_Restrictions_As_Warnings);
22474 --------------------------
22475 -- Restriction_Warnings --
22476 --------------------------
22478 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22481 -- restriction_IDENTIFIER
22482 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22484 when Pragma_Restriction_Warnings =>
22486 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22492 -- pragma Reviewable;
22494 when Pragma_Reviewable =>
22495 Check_Ada_83_Warning;
22496 Check_Arg_Count (0);
22498 -- Call dummy debugging function rv. This is done to assist front
22499 -- end debugging. By placing a Reviewable pragma in the source
22500 -- program, a breakpoint on rv catches this place in the source,
22501 -- allowing convenient stepping to the point of interest.
22505 --------------------------
22506 -- Secondary_Stack_Size --
22507 --------------------------
22509 -- pragma Secondary_Stack_Size (EXPRESSION);
22511 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22512 P : constant Node_Id := Parent (N);
22518 Check_No_Identifiers;
22519 Check_Arg_Count (1);
22521 if Nkind (P) = N_Task_Definition then
22522 Arg := Get_Pragma_Arg (Arg1);
22523 Ent := Defining_Identifier (Parent (P));
22525 -- The expression must be analyzed in the special manner
22526 -- described in "Handling of Default Expressions" in sem.ads.
22528 Preanalyze_Spec_Expression (Arg, Any_Integer);
22530 -- The pragma cannot appear if the No_Secondary_Stack
22531 -- restriction is in effect.
22533 Check_Restriction (No_Secondary_Stack, Arg);
22535 -- Anything else is incorrect
22541 -- Check duplicate pragma before we chain the pragma in the Rep
22542 -- Item chain of Ent.
22544 Check_Duplicate_Pragma (Ent);
22545 Record_Rep_Item (Ent, N);
22546 end Secondary_Stack_Size;
22548 --------------------------
22549 -- Short_Circuit_And_Or --
22550 --------------------------
22552 -- pragma Short_Circuit_And_Or;
22554 when Pragma_Short_Circuit_And_Or =>
22556 Check_Arg_Count (0);
22557 Check_Valid_Configuration_Pragma;
22558 Short_Circuit_And_Or := True;
22560 -------------------
22561 -- Share_Generic --
22562 -------------------
22564 -- pragma Share_Generic (GNAME {, GNAME});
22566 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22568 when Pragma_Share_Generic =>
22570 Process_Generic_List;
22576 -- pragma Shared (LOCAL_NAME);
22578 when Pragma_Shared =>
22580 Process_Atomic_Independent_Shared_Volatile;
22582 --------------------
22583 -- Shared_Passive --
22584 --------------------
22586 -- pragma Shared_Passive [(library_unit_NAME)];
22588 -- Set the flag Is_Shared_Passive of program unit name entity
22590 when Pragma_Shared_Passive => Shared_Passive : declare
22591 Cunit_Node : Node_Id;
22592 Cunit_Ent : Entity_Id;
22595 Check_Ada_83_Warning;
22596 Check_Valid_Library_Unit_Pragma;
22598 Cunit_Node := Cunit (Current_Sem_Unit);
22599 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22601 -- A pragma that applies to a Ghost entity becomes Ghost for the
22602 -- purposes of legality checks and removal of ignored Ghost code.
22604 Mark_Ghost_Pragma (N, Cunit_Ent);
22606 if Nkind (Unit (Cunit_Node)) not in
22607 N_Package_Declaration | N_Generic_Package_Declaration
22610 ("pragma% can only apply to a package declaration");
22613 Set_Is_Shared_Passive (Cunit_Ent);
22614 end Shared_Passive;
22616 -----------------------
22617 -- Short_Descriptors --
22618 -----------------------
22620 -- pragma Short_Descriptors;
22622 -- Recognize and validate, but otherwise ignore
22624 when Pragma_Short_Descriptors =>
22626 Check_Arg_Count (0);
22627 Check_Valid_Configuration_Pragma;
22629 ------------------------------
22630 -- Simple_Storage_Pool_Type --
22631 ------------------------------
22633 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22635 when Pragma_Simple_Storage_Pool_Type =>
22636 Simple_Storage_Pool_Type : declare
22642 Check_Arg_Count (1);
22643 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22645 Type_Id := Get_Pragma_Arg (Arg1);
22646 Find_Type (Type_Id);
22647 Typ := Entity (Type_Id);
22649 if Typ = Any_Type then
22653 -- A pragma that applies to a Ghost entity becomes Ghost for the
22654 -- purposes of legality checks and removal of ignored Ghost code.
22656 Mark_Ghost_Pragma (N, Typ);
22658 -- We require the pragma to apply to a type declared in a package
22659 -- declaration, but not (immediately) within a package body.
22661 if Ekind (Current_Scope) /= E_Package
22662 or else In_Package_Body (Current_Scope)
22665 ("pragma% can only apply to type declared immediately "
22666 & "within a package declaration");
22669 -- A simple storage pool type must be an immutably limited record
22670 -- or private type. If the pragma is given for a private type,
22671 -- the full type is similarly restricted (which is checked later
22672 -- in Freeze_Entity).
22674 if Is_Record_Type (Typ)
22675 and then not Is_Limited_View (Typ)
22678 ("pragma% can only apply to explicitly limited record type");
22680 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22682 ("pragma% can only apply to a private type that is limited");
22684 elsif not Is_Record_Type (Typ)
22685 and then not Is_Private_Type (Typ)
22688 ("pragma% can only apply to limited record or private type");
22691 Record_Rep_Item (Typ, N);
22692 end Simple_Storage_Pool_Type;
22694 ----------------------
22695 -- Source_File_Name --
22696 ----------------------
22698 -- There are five forms for this pragma:
22700 -- pragma Source_File_Name (
22701 -- [UNIT_NAME =>] unit_NAME,
22702 -- BODY_FILE_NAME => STRING_LITERAL
22703 -- [, [INDEX =>] INTEGER_LITERAL]);
22705 -- pragma Source_File_Name (
22706 -- [UNIT_NAME =>] unit_NAME,
22707 -- SPEC_FILE_NAME => STRING_LITERAL
22708 -- [, [INDEX =>] INTEGER_LITERAL]);
22710 -- pragma Source_File_Name (
22711 -- BODY_FILE_NAME => STRING_LITERAL
22712 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22713 -- [, CASING => CASING_SPEC]);
22715 -- pragma Source_File_Name (
22716 -- SPEC_FILE_NAME => STRING_LITERAL
22717 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22718 -- [, CASING => CASING_SPEC]);
22720 -- pragma Source_File_Name (
22721 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22722 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22723 -- [, CASING => CASING_SPEC]);
22725 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22727 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22728 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22729 -- only be used when no project file is used, while SFNP can only be
22730 -- used when a project file is used.
22732 -- No processing here. Processing was completed during parsing, since
22733 -- we need to have file names set as early as possible. Units are
22734 -- loaded well before semantic processing starts.
22736 -- The only processing we defer to this point is the check for
22737 -- correct placement.
22739 when Pragma_Source_File_Name =>
22741 Check_Valid_Configuration_Pragma;
22743 ------------------------------
22744 -- Source_File_Name_Project --
22745 ------------------------------
22747 -- See Source_File_Name for syntax
22749 -- No processing here. Processing was completed during parsing, since
22750 -- we need to have file names set as early as possible. Units are
22751 -- loaded well before semantic processing starts.
22753 -- The only processing we defer to this point is the check for
22754 -- correct placement.
22756 when Pragma_Source_File_Name_Project =>
22758 Check_Valid_Configuration_Pragma;
22760 -- Check that a pragma Source_File_Name_Project is used only in a
22761 -- configuration pragmas file.
22763 -- Pragmas Source_File_Name_Project should only be generated by
22764 -- the Project Manager in configuration pragmas files.
22766 -- This is really an ugly test. It seems to depend on some
22767 -- accidental and undocumented property. At the very least it
22768 -- needs to be documented, but it would be better to have a
22769 -- clean way of testing if we are in a configuration file???
22771 if Present (Parent (N)) then
22773 ("pragma% can only appear in a configuration pragmas file");
22776 ----------------------
22777 -- Source_Reference --
22778 ----------------------
22780 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22782 -- Nothing to do, all processing completed in Par.Prag, since we need
22783 -- the information for possible parser messages that are output.
22785 when Pragma_Source_Reference =>
22792 -- pragma SPARK_Mode [(On | Off)];
22794 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
22795 Mode_Id : SPARK_Mode_Type;
22797 procedure Check_Pragma_Conformance
22798 (Context_Pragma : Node_Id;
22799 Entity : Entity_Id;
22800 Entity_Pragma : Node_Id);
22801 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22802 -- conformance of pragma N depending the following scenarios:
22804 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22805 -- compatible with the pragma Context_Pragma that was inherited
22806 -- from the context:
22807 -- * If the mode of Context_Pragma is ON, then the new mode can
22809 -- * If the mode of Context_Pragma is OFF, then the only allowed
22810 -- new mode is also OFF. Emit error if this is not the case.
22812 -- If Entity is not Empty, verify that pragma N is compatible with
22813 -- pragma Entity_Pragma that belongs to Entity.
22814 -- * If Entity_Pragma is Empty, always issue an error as this
22815 -- corresponds to the case where a previous section of Entity
22816 -- has no SPARK_Mode set.
22817 -- * If the mode of Entity_Pragma is ON, then the new mode can
22819 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22820 -- new mode is also OFF. Emit error if this is not the case.
22822 procedure Check_Library_Level_Entity (E : Entity_Id);
22823 -- Subsidiary to routines Process_xxx. Verify that the related
22824 -- entity E subject to pragma SPARK_Mode is library-level.
22826 procedure Process_Body (Decl : Node_Id);
22827 -- Verify the legality of pragma SPARK_Mode when it appears as the
22828 -- top of the body declarations of entry, package, protected unit,
22829 -- subprogram or task unit body denoted by Decl.
22831 procedure Process_Overloadable (Decl : Node_Id);
22832 -- Verify the legality of pragma SPARK_Mode when it applies to an
22833 -- entry or [generic] subprogram declaration denoted by Decl.
22835 procedure Process_Private_Part (Decl : Node_Id);
22836 -- Verify the legality of pragma SPARK_Mode when it appears at the
22837 -- top of the private declarations of a package spec, protected or
22838 -- task unit declaration denoted by Decl.
22840 procedure Process_Statement_Part (Decl : Node_Id);
22841 -- Verify the legality of pragma SPARK_Mode when it appears at the
22842 -- top of the statement sequence of a package body denoted by node
22845 procedure Process_Visible_Part (Decl : Node_Id);
22846 -- Verify the legality of pragma SPARK_Mode when it appears at the
22847 -- top of the visible declarations of a package spec, protected or
22848 -- task unit declaration denoted by Decl. The routine is also used
22849 -- on protected or task units declared without a definition.
22851 procedure Set_SPARK_Context;
22852 -- Subsidiary to routines Process_xxx. Set the global variables
22853 -- which represent the mode of the context from pragma N. Ensure
22854 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22856 ------------------------------
22857 -- Check_Pragma_Conformance --
22858 ------------------------------
22860 procedure Check_Pragma_Conformance
22861 (Context_Pragma : Node_Id;
22862 Entity : Entity_Id;
22863 Entity_Pragma : Node_Id)
22865 Err_Id : Entity_Id;
22869 -- The current pragma may appear without an argument. If this
22870 -- is the case, associate all error messages with the pragma
22873 if Present (Arg1) then
22879 -- The mode of the current pragma is compared against that of
22880 -- an enclosing context.
22882 if Present (Context_Pragma) then
22883 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
22885 -- Issue an error if the new mode is less restrictive than
22886 -- that of the context.
22888 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
22889 and then Get_SPARK_Mode_From_Annotation (N) = On
22892 ("cannot change SPARK_Mode from Off to On", Err_N);
22893 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
22894 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
22899 -- The mode of the current pragma is compared against that of
22900 -- an initial package, protected type, subprogram or task type
22903 if Present (Entity) then
22905 -- A simple protected or task type is transformed into an
22906 -- anonymous type whose name cannot be used to issue error
22907 -- messages. Recover the original entity of the type.
22909 if Ekind (Entity) in E_Protected_Type | E_Task_Type then
22912 (Original_Node (Unit_Declaration_Node (Entity)));
22917 -- Both the initial declaration and the completion carry
22918 -- SPARK_Mode pragmas.
22920 if Present (Entity_Pragma) then
22921 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
22923 -- Issue an error if the new mode is less restrictive
22924 -- than that of the initial declaration.
22926 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
22927 and then Get_SPARK_Mode_From_Annotation (N) = On
22929 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
22930 Error_Msg_Sloc := Sloc (Entity_Pragma);
22932 ("\value Off was set for SPARK_Mode on&#",
22937 -- Otherwise the initial declaration lacks a SPARK_Mode
22938 -- pragma in which case the current pragma is illegal as
22939 -- it cannot "complete".
22941 elsif Get_SPARK_Mode_From_Annotation (N) = Off
22942 and then (Is_Generic_Unit (Entity) or else In_Instance)
22947 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
22948 Error_Msg_Sloc := Sloc (Err_Id);
22950 ("\no value was set for SPARK_Mode on&#",
22955 end Check_Pragma_Conformance;
22957 --------------------------------
22958 -- Check_Library_Level_Entity --
22959 --------------------------------
22961 procedure Check_Library_Level_Entity (E : Entity_Id) is
22962 procedure Add_Entity_To_Name_Buffer;
22963 -- Add the E_Kind of entity E to the name buffer
22965 -------------------------------
22966 -- Add_Entity_To_Name_Buffer --
22967 -------------------------------
22969 procedure Add_Entity_To_Name_Buffer is
22971 if Ekind (E) in E_Entry | E_Entry_Family then
22972 Add_Str_To_Name_Buffer ("entry");
22974 elsif Ekind (E) in E_Generic_Package
22978 Add_Str_To_Name_Buffer ("package");
22980 elsif Ekind (E) in E_Protected_Body | E_Protected_Type then
22981 Add_Str_To_Name_Buffer ("protected type");
22983 elsif Ekind (E) in E_Function
22984 | E_Generic_Function
22985 | E_Generic_Procedure
22987 | E_Subprogram_Body
22989 Add_Str_To_Name_Buffer ("subprogram");
22992 pragma Assert (Ekind (E) in E_Task_Body | E_Task_Type);
22993 Add_Str_To_Name_Buffer ("task type");
22995 end Add_Entity_To_Name_Buffer;
22999 Msg_1 : constant String := "incorrect placement of pragma%";
23002 -- Start of processing for Check_Library_Level_Entity
23005 -- A SPARK_Mode of On shall only apply to library-level
23006 -- entities, except for those in generic instances, which are
23007 -- ignored (even if the entity gets SPARK_Mode pragma attached
23008 -- in the AST, its effect is not taken into account unless the
23009 -- context already provides SPARK_Mode of On in GNATprove).
23011 if Get_SPARK_Mode_From_Annotation (N) = On
23012 and then not Is_Library_Level_Entity (E)
23013 and then Instantiation_Location (Sloc (N)) = No_Location
23015 Error_Msg_Name_1 := Pname;
23016 Error_Msg_N (Fix_Error (Msg_1), N);
23019 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23020 Add_Entity_To_Name_Buffer;
23022 Msg_2 := Name_Find;
23023 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23027 end Check_Library_Level_Entity;
23033 procedure Process_Body (Decl : Node_Id) is
23034 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23035 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23038 -- Ignore pragma when applied to the special body created for
23039 -- inlining, recognized by its internal name _Parent.
23041 if Chars (Body_Id) = Name_uParent then
23045 Check_Library_Level_Entity (Body_Id);
23047 -- For entry bodies, verify the legality against:
23048 -- * The mode of the context
23049 -- * The mode of the spec (if any)
23051 if Nkind (Decl) in N_Entry_Body | N_Subprogram_Body then
23053 -- A stand-alone subprogram body
23055 if Body_Id = Spec_Id then
23056 Check_Pragma_Conformance
23057 (Context_Pragma => SPARK_Pragma (Body_Id),
23059 Entity_Pragma => Empty);
23061 -- An entry or subprogram body that completes a previous
23065 Check_Pragma_Conformance
23066 (Context_Pragma => SPARK_Pragma (Body_Id),
23068 Entity_Pragma => SPARK_Pragma (Spec_Id));
23072 Set_SPARK_Pragma (Body_Id, N);
23073 Set_SPARK_Pragma_Inherited (Body_Id, False);
23075 -- For package bodies, verify the legality against:
23076 -- * The mode of the context
23077 -- * The mode of the private part
23079 -- This case is separated from protected and task bodies
23080 -- because the statement part of the package body inherits
23081 -- the mode of the body declarations.
23083 elsif Nkind (Decl) = N_Package_Body then
23084 Check_Pragma_Conformance
23085 (Context_Pragma => SPARK_Pragma (Body_Id),
23087 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23090 Set_SPARK_Pragma (Body_Id, N);
23091 Set_SPARK_Pragma_Inherited (Body_Id, False);
23092 Set_SPARK_Aux_Pragma (Body_Id, N);
23093 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23095 -- For protected and task bodies, verify the legality against:
23096 -- * The mode of the context
23097 -- * The mode of the private part
23101 (Nkind (Decl) in N_Protected_Body | N_Task_Body);
23103 Check_Pragma_Conformance
23104 (Context_Pragma => SPARK_Pragma (Body_Id),
23106 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23109 Set_SPARK_Pragma (Body_Id, N);
23110 Set_SPARK_Pragma_Inherited (Body_Id, False);
23114 --------------------------
23115 -- Process_Overloadable --
23116 --------------------------
23118 procedure Process_Overloadable (Decl : Node_Id) is
23119 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23120 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23123 Check_Library_Level_Entity (Spec_Id);
23125 -- Verify the legality against:
23126 -- * The mode of the context
23128 Check_Pragma_Conformance
23129 (Context_Pragma => SPARK_Pragma (Spec_Id),
23131 Entity_Pragma => Empty);
23133 Set_SPARK_Pragma (Spec_Id, N);
23134 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23136 -- When the pragma applies to the anonymous object created for
23137 -- a single task type, decorate the type as well. This scenario
23138 -- arises when the single task type lacks a task definition,
23139 -- therefore there is no issue with respect to a potential
23140 -- pragma SPARK_Mode in the private part.
23142 -- task type Anon_Task_Typ;
23143 -- Obj : Anon_Task_Typ;
23144 -- pragma SPARK_Mode ...;
23146 if Is_Single_Task_Object (Spec_Id) then
23147 Set_SPARK_Pragma (Spec_Typ, N);
23148 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23149 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23150 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23152 end Process_Overloadable;
23154 --------------------------
23155 -- Process_Private_Part --
23156 --------------------------
23158 procedure Process_Private_Part (Decl : Node_Id) is
23159 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23162 Check_Library_Level_Entity (Spec_Id);
23164 -- Verify the legality against:
23165 -- * The mode of the visible declarations
23167 Check_Pragma_Conformance
23168 (Context_Pragma => Empty,
23170 Entity_Pragma => SPARK_Pragma (Spec_Id));
23173 Set_SPARK_Aux_Pragma (Spec_Id, N);
23174 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23175 end Process_Private_Part;
23177 ----------------------------
23178 -- Process_Statement_Part --
23179 ----------------------------
23181 procedure Process_Statement_Part (Decl : Node_Id) is
23182 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23185 Check_Library_Level_Entity (Body_Id);
23187 -- Verify the legality against:
23188 -- * The mode of the body declarations
23190 Check_Pragma_Conformance
23191 (Context_Pragma => Empty,
23193 Entity_Pragma => SPARK_Pragma (Body_Id));
23196 Set_SPARK_Aux_Pragma (Body_Id, N);
23197 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23198 end Process_Statement_Part;
23200 --------------------------
23201 -- Process_Visible_Part --
23202 --------------------------
23204 procedure Process_Visible_Part (Decl : Node_Id) is
23205 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23206 Obj_Id : Entity_Id;
23209 Check_Library_Level_Entity (Spec_Id);
23211 -- Verify the legality against:
23212 -- * The mode of the context
23214 Check_Pragma_Conformance
23215 (Context_Pragma => SPARK_Pragma (Spec_Id),
23217 Entity_Pragma => Empty);
23219 -- A task unit declared without a definition does not set the
23220 -- SPARK_Mode of the context because the task does not have any
23221 -- entries that could inherit the mode.
23223 if Nkind (Decl) not in
23224 N_Single_Task_Declaration | N_Task_Type_Declaration
23229 Set_SPARK_Pragma (Spec_Id, N);
23230 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23231 Set_SPARK_Aux_Pragma (Spec_Id, N);
23232 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23234 -- When the pragma applies to a single protected or task type,
23235 -- decorate the corresponding anonymous object as well.
23237 -- protected Anon_Prot_Typ is
23238 -- pragma SPARK_Mode ...;
23240 -- end Anon_Prot_Typ;
23242 -- Obj : Anon_Prot_Typ;
23244 if Is_Single_Concurrent_Type (Spec_Id) then
23245 Obj_Id := Anonymous_Object (Spec_Id);
23247 Set_SPARK_Pragma (Obj_Id, N);
23248 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23250 end Process_Visible_Part;
23252 -----------------------
23253 -- Set_SPARK_Context --
23254 -----------------------
23256 procedure Set_SPARK_Context is
23258 SPARK_Mode := Mode_Id;
23259 SPARK_Mode_Pragma := N;
23260 end Set_SPARK_Context;
23268 -- Start of processing for Do_SPARK_Mode
23272 Check_No_Identifiers;
23273 Check_At_Most_N_Arguments (1);
23275 -- Check the legality of the mode (no argument = ON)
23277 if Arg_Count = 1 then
23278 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23279 Mode := Chars (Get_Pragma_Arg (Arg1));
23284 Mode_Id := Get_SPARK_Mode_Type (Mode);
23285 Context := Parent (N);
23287 -- When a SPARK_Mode pragma appears inside an instantiation whose
23288 -- enclosing context has SPARK_Mode set to "off", the pragma has
23289 -- no semantic effect.
23291 if Ignore_SPARK_Mode_Pragmas_In_Instance
23292 and then Mode_Id /= Off
23294 Rewrite (N, Make_Null_Statement (Loc));
23299 -- The pragma appears in a configuration file
23301 if No (Context) then
23302 Check_Valid_Configuration_Pragma;
23304 if Present (SPARK_Mode_Pragma) then
23307 Prev => SPARK_Mode_Pragma);
23313 -- The pragma acts as a configuration pragma in a compilation unit
23315 -- pragma SPARK_Mode ...;
23316 -- package Pack is ...;
23318 elsif Nkind (Context) = N_Compilation_Unit
23319 and then List_Containing (N) = Context_Items (Context)
23321 Check_Valid_Configuration_Pragma;
23324 -- Otherwise the placement of the pragma within the tree dictates
23325 -- its associated construct. Inspect the declarative list where
23326 -- the pragma resides to find a potential construct.
23330 while Present (Stmt) loop
23332 -- Skip prior pragmas, but check for duplicates. Note that
23333 -- this also takes care of pragmas generated for aspects.
23335 if Nkind (Stmt) = N_Pragma then
23336 if Pragma_Name (Stmt) = Pname then
23343 -- The pragma applies to an expression function that has
23344 -- already been rewritten into a subprogram declaration.
23346 -- function Expr_Func return ... is (...);
23347 -- pragma SPARK_Mode ...;
23349 elsif Nkind (Stmt) = N_Subprogram_Declaration
23350 and then Nkind (Original_Node (Stmt)) =
23351 N_Expression_Function
23353 Process_Overloadable (Stmt);
23356 -- The pragma applies to the anonymous object created for a
23357 -- single concurrent type.
23359 -- protected type Anon_Prot_Typ ...;
23360 -- Obj : Anon_Prot_Typ;
23361 -- pragma SPARK_Mode ...;
23363 elsif Nkind (Stmt) = N_Object_Declaration
23364 and then Is_Single_Concurrent_Object
23365 (Defining_Entity (Stmt))
23367 Process_Overloadable (Stmt);
23370 -- Skip internally generated code
23372 elsif not Comes_From_Source (Stmt) then
23375 -- The pragma applies to an entry or [generic] subprogram
23379 -- pragma SPARK_Mode ...;
23382 -- procedure Proc ...;
23383 -- pragma SPARK_Mode ...;
23385 elsif Nkind (Stmt) in N_Generic_Subprogram_Declaration
23386 | N_Subprogram_Declaration
23387 or else (Nkind (Stmt) = N_Entry_Declaration
23388 and then Is_Protected_Type
23389 (Scope (Defining_Entity (Stmt))))
23391 Process_Overloadable (Stmt);
23394 -- Otherwise the pragma does not apply to a legal construct
23395 -- or it does not appear at the top of a declarative or a
23396 -- statement list. Issue an error and stop the analysis.
23406 -- The pragma applies to a package or a subprogram that acts as
23407 -- a compilation unit.
23409 -- procedure Proc ...;
23410 -- pragma SPARK_Mode ...;
23412 if Nkind (Context) = N_Compilation_Unit_Aux then
23413 Context := Unit (Parent (Context));
23416 -- The pragma appears at the top of entry, package, protected
23417 -- unit, subprogram or task unit body declarations.
23419 -- entry Ent when ... is
23420 -- pragma SPARK_Mode ...;
23422 -- package body Pack is
23423 -- pragma SPARK_Mode ...;
23425 -- procedure Proc ... is
23426 -- pragma SPARK_Mode;
23428 -- protected body Prot is
23429 -- pragma SPARK_Mode ...;
23431 if Nkind (Context) in N_Entry_Body
23434 | N_Subprogram_Body
23437 Process_Body (Context);
23439 -- The pragma appears at the top of the visible or private
23440 -- declaration of a package spec, protected or task unit.
23443 -- pragma SPARK_Mode ...;
23445 -- pragma SPARK_Mode ...;
23447 -- protected [type] Prot is
23448 -- pragma SPARK_Mode ...;
23450 -- pragma SPARK_Mode ...;
23452 elsif Nkind (Context) in N_Package_Specification
23453 | N_Protected_Definition
23454 | N_Task_Definition
23456 if List_Containing (N) = Visible_Declarations (Context) then
23457 Process_Visible_Part (Parent (Context));
23459 Process_Private_Part (Parent (Context));
23462 -- The pragma appears at the top of package body statements
23464 -- package body Pack is
23466 -- pragma SPARK_Mode;
23468 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23469 and then Nkind (Parent (Context)) = N_Package_Body
23471 Process_Statement_Part (Parent (Context));
23473 -- The pragma appeared as an aspect of a [generic] subprogram
23474 -- declaration that acts as a compilation unit.
23477 -- procedure Proc ...;
23478 -- pragma SPARK_Mode ...;
23480 elsif Nkind (Context) in N_Generic_Subprogram_Declaration
23481 | N_Subprogram_Declaration
23483 Process_Overloadable (Context);
23485 -- The pragma does not apply to a legal construct, issue error
23493 --------------------------------
23494 -- Static_Elaboration_Desired --
23495 --------------------------------
23497 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23499 when Pragma_Static_Elaboration_Desired =>
23501 Check_At_Most_N_Arguments (1);
23503 if Is_Compilation_Unit (Current_Scope)
23504 and then Ekind (Current_Scope) = E_Package
23506 Set_Static_Elaboration_Desired (Current_Scope, True);
23508 Error_Pragma ("pragma% must apply to a library-level package");
23515 -- pragma Storage_Size (EXPRESSION);
23517 when Pragma_Storage_Size => Storage_Size : declare
23518 P : constant Node_Id := Parent (N);
23522 Check_No_Identifiers;
23523 Check_Arg_Count (1);
23525 -- The expression must be analyzed in the special manner described
23526 -- in "Handling of Default Expressions" in sem.ads.
23528 Arg := Get_Pragma_Arg (Arg1);
23529 Preanalyze_Spec_Expression (Arg, Any_Integer);
23531 if not Is_OK_Static_Expression (Arg) then
23532 Check_Restriction (Static_Storage_Size, Arg);
23535 if Nkind (P) /= N_Task_Definition then
23540 if Has_Storage_Size_Pragma (P) then
23541 Error_Pragma ("duplicate pragma% not allowed");
23543 Set_Has_Storage_Size_Pragma (P, True);
23546 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23554 -- pragma Storage_Unit (NUMERIC_LITERAL);
23556 -- Only permitted argument is System'Storage_Unit value
23558 when Pragma_Storage_Unit =>
23559 Check_No_Identifiers;
23560 Check_Arg_Count (1);
23561 Check_Arg_Is_Integer_Literal (Arg1);
23563 if Intval (Get_Pragma_Arg (Arg1)) /=
23564 UI_From_Int (Ttypes.System_Storage_Unit)
23566 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23568 ("the only allowed argument for pragma% is ^", Arg1);
23571 --------------------
23572 -- Stream_Convert --
23573 --------------------
23575 -- pragma Stream_Convert (
23576 -- [Entity =>] type_LOCAL_NAME,
23577 -- [Read =>] function_NAME,
23578 -- [Write =>] function NAME);
23580 when Pragma_Stream_Convert => Stream_Convert : declare
23581 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23582 -- Check that the given argument is the name of a local function
23583 -- of one argument that is not overloaded earlier in the current
23584 -- local scope. A check is also made that the argument is a
23585 -- function with one parameter.
23587 --------------------------------------
23588 -- Check_OK_Stream_Convert_Function --
23589 --------------------------------------
23591 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23595 Check_Arg_Is_Local_Name (Arg);
23596 Ent := Entity (Get_Pragma_Arg (Arg));
23598 if Has_Homonym (Ent) then
23600 ("argument for pragma% may not be overloaded", Arg);
23603 if Ekind (Ent) /= E_Function
23604 or else No (First_Formal (Ent))
23605 or else Present (Next_Formal (First_Formal (Ent)))
23608 ("argument for pragma% must be function of one argument",
23610 elsif Is_Abstract_Subprogram (Ent) then
23612 ("argument for pragma% cannot be abstract", Arg);
23614 end Check_OK_Stream_Convert_Function;
23616 -- Start of processing for Stream_Convert
23620 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23621 Check_Arg_Count (3);
23622 Check_Optional_Identifier (Arg1, Name_Entity);
23623 Check_Optional_Identifier (Arg2, Name_Read);
23624 Check_Optional_Identifier (Arg3, Name_Write);
23625 Check_Arg_Is_Local_Name (Arg1);
23626 Check_OK_Stream_Convert_Function (Arg2);
23627 Check_OK_Stream_Convert_Function (Arg3);
23630 Typ : constant Entity_Id :=
23631 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23632 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23633 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23636 Check_First_Subtype (Arg1);
23638 -- Check for too early or too late. Note that we don't enforce
23639 -- the rule about primitive operations in this case, since, as
23640 -- is the case for explicit stream attributes themselves, these
23641 -- restrictions are not appropriate. Note that the chaining of
23642 -- the pragma by Rep_Item_Too_Late is actually the critical
23643 -- processing done for this pragma.
23645 if Rep_Item_Too_Early (Typ, N)
23647 Rep_Item_Too_Late (Typ, N, FOnly => True)
23652 -- Return if previous error
23654 if Etype (Typ) = Any_Type
23656 Etype (Read) = Any_Type
23658 Etype (Write) = Any_Type
23665 if Underlying_Type (Etype (Read)) /= Typ then
23667 ("incorrect return type for function&", Arg2);
23670 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23672 ("incorrect parameter type for function&", Arg3);
23675 if Underlying_Type (Etype (First_Formal (Read))) /=
23676 Underlying_Type (Etype (Write))
23679 ("result type of & does not match Read parameter type",
23683 end Stream_Convert;
23689 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23691 -- This is processed by the parser since some of the style checks
23692 -- take place during source scanning and parsing. This means that
23693 -- we don't need to issue error messages here.
23695 when Pragma_Style_Checks => Style_Checks : declare
23696 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23702 Check_No_Identifiers;
23704 -- Two argument form
23706 if Arg_Count = 2 then
23707 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23714 E_Id := Get_Pragma_Arg (Arg2);
23717 if not Is_Entity_Name (E_Id) then
23719 ("second argument of pragma% must be entity name",
23723 E := Entity (E_Id);
23725 if not Ignore_Style_Checks_Pragmas then
23730 Set_Suppress_Style_Checks
23731 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23732 exit when No (Homonym (E));
23739 -- One argument form
23742 Check_Arg_Count (1);
23744 if Nkind (A) = N_String_Literal then
23748 Slen : constant Natural := Natural (String_Length (S));
23749 Options : String (1 .. Slen);
23755 C := Get_String_Char (S, Pos (J));
23756 exit when not In_Character_Range (C);
23757 Options (J) := Get_Character (C);
23759 -- If at end of string, set options. As per discussion
23760 -- above, no need to check for errors, since we issued
23761 -- them in the parser.
23764 if not Ignore_Style_Checks_Pragmas then
23765 Set_Style_Check_Options (Options);
23775 elsif Nkind (A) = N_Identifier then
23776 if Chars (A) = Name_All_Checks then
23777 if not Ignore_Style_Checks_Pragmas then
23779 Set_GNAT_Style_Check_Options;
23781 Set_Default_Style_Check_Options;
23785 elsif Chars (A) = Name_On then
23786 if not Ignore_Style_Checks_Pragmas then
23787 Style_Check := True;
23790 elsif Chars (A) = Name_Off then
23791 if not Ignore_Style_Checks_Pragmas then
23792 Style_Check := False;
23799 ------------------------
23800 -- Subprogram_Variant --
23801 ------------------------
23803 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM
23804 -- {, SUBPROGRAM_VARIANT_ITEM } );
23806 -- SUBPROGRAM_VARIANT_ITEM ::=
23807 -- CHANGE_DIRECTION => discrete_EXPRESSION
23809 -- CHANGE_DIRECTION ::= Increases | Decreases
23811 -- Characteristics:
23813 -- * Analysis - The annotation undergoes initial checks to verify
23814 -- the legal placement and context. Secondary checks preanalyze the
23817 -- Analyze_Subprogram_Variant_In_Decl_Part
23819 -- * Expansion - The annotation is expanded during the expansion of
23820 -- the related subprogram [body] contract as performed in:
23822 -- Expand_Subprogram_Contract
23824 -- * Template - The annotation utilizes the generic template of the
23825 -- related subprogram [body] when it is:
23827 -- aspect on subprogram declaration
23828 -- aspect on stand-alone subprogram body
23829 -- pragma on stand-alone subprogram body
23831 -- The annotation must prepare its own template when it is:
23833 -- pragma on subprogram declaration
23835 -- * Globals - Capture of global references must occur after full
23838 -- * Instance - The annotation is instantiated automatically when
23839 -- the related generic subprogram [body] is instantiated except for
23840 -- the "pragma on subprogram declaration" case. In that scenario
23841 -- the annotation must instantiate itself.
23843 when Pragma_Subprogram_Variant => Subprogram_Variant : declare
23844 Spec_Id : Entity_Id;
23845 Subp_Decl : Node_Id;
23846 Subp_Spec : Node_Id;
23850 Check_No_Identifiers;
23851 Check_Arg_Count (1);
23853 -- Ensure the proper placement of the pragma. Subprogram_Variant
23854 -- must be associated with a subprogram declaration or a body that
23858 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
23860 -- Generic subprogram
23862 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
23865 -- Body acts as spec
23867 elsif Nkind (Subp_Decl) = N_Subprogram_Body
23868 and then No (Corresponding_Spec (Subp_Decl))
23872 -- Body stub acts as spec
23874 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
23875 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
23881 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
23882 Subp_Spec := Specification (Subp_Decl);
23884 -- Pragma Subprogram_Variant is forbidden on null procedures,
23885 -- as this may lead to potential ambiguities in behavior when
23886 -- interface null procedures are involved. Also, it just
23887 -- wouldn't make sense, because null procedure is not
23890 if Nkind (Subp_Spec) = N_Procedure_Specification
23891 and then Null_Present (Subp_Spec)
23893 Error_Msg_N (Fix_Error
23894 ("pragma % cannot apply to null procedure"), N);
23903 Spec_Id := Unique_Defining_Entity (Subp_Decl);
23905 -- A pragma that applies to a Ghost entity becomes Ghost for the
23906 -- purposes of legality checks and removal of ignored Ghost code.
23908 Mark_Ghost_Pragma (N, Spec_Id);
23909 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
23911 -- Chain the pragma on the contract for further processing by
23912 -- Analyze_Subprogram_Variant_In_Decl_Part.
23914 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
23916 -- Fully analyze the pragma when it appears inside a subprogram
23917 -- body because it cannot benefit from forward references.
23919 if Nkind (Subp_Decl) in N_Subprogram_Body
23920 | N_Subprogram_Body_Stub
23922 -- The legality checks of pragma Subprogram_Variant are
23923 -- affected by the SPARK mode in effect and the volatility
23924 -- of the context. Analyze all pragmas in a specific order.
23926 Analyze_If_Present (Pragma_SPARK_Mode);
23927 Analyze_If_Present (Pragma_Volatile_Function);
23928 Analyze_Subprogram_Variant_In_Decl_Part (N);
23930 end Subprogram_Variant;
23936 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23938 when Pragma_Subtitle =>
23940 Check_Arg_Count (1);
23941 Check_Optional_Identifier (Arg1, Name_Subtitle);
23942 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
23949 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23951 when Pragma_Suppress =>
23952 Process_Suppress_Unsuppress (Suppress_Case => True);
23958 -- pragma Suppress_All;
23960 -- The only check made here is that the pragma has no arguments.
23961 -- There are no placement rules, and the processing required (setting
23962 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23963 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23964 -- then creates and inserts a pragma Suppress (All_Checks).
23966 when Pragma_Suppress_All =>
23968 Check_Arg_Count (0);
23970 -------------------------
23971 -- Suppress_Debug_Info --
23972 -------------------------
23974 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23976 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
23977 Nam_Id : Entity_Id;
23981 Check_Arg_Count (1);
23982 Check_Optional_Identifier (Arg1, Name_Entity);
23983 Check_Arg_Is_Local_Name (Arg1);
23985 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
23987 -- A pragma that applies to a Ghost entity becomes Ghost for the
23988 -- purposes of legality checks and removal of ignored Ghost code.
23990 Mark_Ghost_Pragma (N, Nam_Id);
23991 Set_Debug_Info_Off (Nam_Id);
23992 end Suppress_Debug_Info;
23994 ----------------------------------
23995 -- Suppress_Exception_Locations --
23996 ----------------------------------
23998 -- pragma Suppress_Exception_Locations;
24000 when Pragma_Suppress_Exception_Locations =>
24002 Check_Arg_Count (0);
24003 Check_Valid_Configuration_Pragma;
24004 Exception_Locations_Suppressed := True;
24006 -----------------------------
24007 -- Suppress_Initialization --
24008 -----------------------------
24010 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24012 when Pragma_Suppress_Initialization => Suppress_Init : declare
24018 Check_Arg_Count (1);
24019 Check_Optional_Identifier (Arg1, Name_Entity);
24020 Check_Arg_Is_Local_Name (Arg1);
24022 E_Id := Get_Pragma_Arg (Arg1);
24024 if Etype (E_Id) = Any_Type then
24028 E := Entity (E_Id);
24030 -- A pragma that applies to a Ghost entity becomes Ghost for the
24031 -- purposes of legality checks and removal of ignored Ghost code.
24033 Mark_Ghost_Pragma (N, E);
24035 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24037 ("pragma% requires variable, type or subtype", Arg1);
24040 if Rep_Item_Too_Early (E, N)
24042 Rep_Item_Too_Late (E, N, FOnly => True)
24047 -- For incomplete/private type, set flag on full view
24049 if Is_Incomplete_Or_Private_Type (E) then
24050 if No (Full_View (Base_Type (E))) then
24052 ("argument of pragma% cannot be an incomplete type", Arg1);
24054 Set_Suppress_Initialization (Full_View (E));
24057 -- For first subtype, set flag on base type
24059 elsif Is_First_Subtype (E) then
24060 Set_Suppress_Initialization (Base_Type (E));
24062 -- For other than first subtype, set flag on subtype or variable
24065 Set_Suppress_Initialization (E);
24073 -- pragma System_Name (DIRECT_NAME);
24075 -- Syntax check: one argument, which must be the identifier GNAT or
24076 -- the identifier GCC, no other identifiers are acceptable.
24078 when Pragma_System_Name =>
24080 Check_No_Identifiers;
24081 Check_Arg_Count (1);
24082 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24084 -----------------------------
24085 -- Task_Dispatching_Policy --
24086 -----------------------------
24088 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24090 when Pragma_Task_Dispatching_Policy => declare
24094 Check_Ada_83_Warning;
24095 Check_Arg_Count (1);
24096 Check_No_Identifiers;
24097 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24098 Check_Valid_Configuration_Pragma;
24099 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24100 DP := Fold_Upper (Name_Buffer (1));
24102 if Task_Dispatching_Policy /= ' '
24103 and then Task_Dispatching_Policy /= DP
24105 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24107 ("task dispatching policy incompatible with policy#");
24109 -- Set new policy, but always preserve System_Location since we
24110 -- like the error message with the run time name.
24113 Task_Dispatching_Policy := DP;
24115 if Task_Dispatching_Policy_Sloc /= System_Location then
24116 Task_Dispatching_Policy_Sloc := Loc;
24125 -- pragma Task_Info (EXPRESSION);
24127 when Pragma_Task_Info => Task_Info : declare
24128 P : constant Node_Id := Parent (N);
24134 if Warn_On_Obsolescent_Feature then
24136 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24137 & "instead?j?", N);
24140 if Nkind (P) /= N_Task_Definition then
24141 Error_Pragma ("pragma% must appear in task definition");
24144 Check_No_Identifiers;
24145 Check_Arg_Count (1);
24147 Analyze_And_Resolve
24148 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24150 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24154 Ent := Defining_Identifier (Parent (P));
24156 -- Check duplicate pragma before we chain the pragma in the Rep
24157 -- Item chain of Ent.
24160 (Ent, Name_Task_Info, Check_Parents => False)
24162 Error_Pragma ("duplicate pragma% not allowed");
24165 Record_Rep_Item (Ent, N);
24172 -- pragma Task_Name (string_EXPRESSION);
24174 when Pragma_Task_Name => Task_Name : declare
24175 P : constant Node_Id := Parent (N);
24180 Check_No_Identifiers;
24181 Check_Arg_Count (1);
24183 Arg := Get_Pragma_Arg (Arg1);
24185 -- The expression is used in the call to Create_Task, and must be
24186 -- expanded there, not in the context of the current spec. It must
24187 -- however be analyzed to capture global references, in case it
24188 -- appears in a generic context.
24190 Preanalyze_And_Resolve (Arg, Standard_String);
24192 if Nkind (P) /= N_Task_Definition then
24196 Ent := Defining_Identifier (Parent (P));
24198 -- Check duplicate pragma before we chain the pragma in the Rep
24199 -- Item chain of Ent.
24202 (Ent, Name_Task_Name, Check_Parents => False)
24204 Error_Pragma ("duplicate pragma% not allowed");
24207 Record_Rep_Item (Ent, N);
24214 -- pragma Task_Storage (
24215 -- [Task_Type =>] LOCAL_NAME,
24216 -- [Top_Guard =>] static_integer_EXPRESSION);
24218 when Pragma_Task_Storage => Task_Storage : declare
24219 Args : Args_List (1 .. 2);
24220 Names : constant Name_List (1 .. 2) := (
24224 Task_Type : Node_Id renames Args (1);
24225 Top_Guard : Node_Id renames Args (2);
24231 Gather_Associations (Names, Args);
24233 if No (Task_Type) then
24235 ("missing task_type argument for pragma%");
24238 Check_Arg_Is_Local_Name (Task_Type);
24240 Ent := Entity (Task_Type);
24242 if not Is_Task_Type (Ent) then
24244 ("argument for pragma% must be task type", Task_Type);
24247 if No (Top_Guard) then
24249 ("pragma% takes two arguments", Task_Type);
24251 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24254 Check_First_Subtype (Task_Type);
24256 if Rep_Item_Too_Late (Ent, N) then
24265 -- pragma Test_Case
24266 -- ([Name =>] Static_String_EXPRESSION
24267 -- ,[Mode =>] MODE_TYPE
24268 -- [, Requires => Boolean_EXPRESSION]
24269 -- [, Ensures => Boolean_EXPRESSION]);
24271 -- MODE_TYPE ::= Nominal | Robustness
24273 -- Characteristics:
24275 -- * Analysis - The annotation undergoes initial checks to verify
24276 -- the legal placement and context. Secondary checks preanalyze the
24279 -- Analyze_Test_Case_In_Decl_Part
24281 -- * Expansion - None.
24283 -- * Template - The annotation utilizes the generic template of the
24284 -- related subprogram when it is:
24286 -- aspect on subprogram declaration
24288 -- The annotation must prepare its own template when it is:
24290 -- pragma on subprogram declaration
24292 -- * Globals - Capture of global references must occur after full
24295 -- * Instance - The annotation is instantiated automatically when
24296 -- the related generic subprogram is instantiated except for the
24297 -- "pragma on subprogram declaration" case. In that scenario the
24298 -- annotation must instantiate itself.
24300 when Pragma_Test_Case => Test_Case : declare
24301 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24302 -- Ensure that the contract of subprogram Subp_Id does not contain
24303 -- another Test_Case pragma with the same Name as the current one.
24305 -------------------------
24306 -- Check_Distinct_Name --
24307 -------------------------
24309 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24310 Items : constant Node_Id := Contract (Subp_Id);
24311 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24315 -- Inspect all Test_Case pragma of the related subprogram
24316 -- looking for one with a duplicate "Name" argument.
24318 if Present (Items) then
24319 Prag := Contract_Test_Cases (Items);
24320 while Present (Prag) loop
24321 if Pragma_Name (Prag) = Name_Test_Case
24323 and then String_Equal
24324 (Name, Get_Name_From_CTC_Pragma (Prag))
24326 Error_Msg_Sloc := Sloc (Prag);
24327 Error_Pragma ("name for pragma % is already used #");
24330 Prag := Next_Pragma (Prag);
24333 end Check_Distinct_Name;
24337 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24340 Subp_Decl : Node_Id;
24341 Subp_Id : Entity_Id;
24343 -- Start of processing for Test_Case
24347 Check_At_Least_N_Arguments (2);
24348 Check_At_Most_N_Arguments (4);
24350 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24354 Check_Optional_Identifier (Arg1, Name_Name);
24355 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24359 Check_Optional_Identifier (Arg2, Name_Mode);
24360 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24362 -- Arguments "Requires" and "Ensures"
24364 if Present (Arg3) then
24365 if Present (Arg4) then
24366 Check_Identifier (Arg3, Name_Requires);
24367 Check_Identifier (Arg4, Name_Ensures);
24369 Check_Identifier_Is_One_Of
24370 (Arg3, Name_Requires, Name_Ensures);
24374 -- Pragma Test_Case must be associated with a subprogram declared
24375 -- in a library-level package. First determine whether the current
24376 -- compilation unit is a legal context.
24378 if Nkind (Pack_Decl) in N_Package_Declaration
24379 | N_Generic_Package_Declaration
24383 -- Otherwise the placement is illegal
24387 ("pragma % must be specified within a package declaration");
24391 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24393 -- Find the enclosing context
24395 Context := Parent (Subp_Decl);
24397 if Present (Context) then
24398 Context := Parent (Context);
24401 -- Verify the placement of the pragma
24403 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24405 ("pragma % cannot be applied to abstract subprogram");
24408 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24409 Error_Pragma ("pragma % cannot be applied to entry");
24412 -- The context is a [generic] subprogram declared at the top level
24413 -- of the [generic] package unit.
24415 elsif Nkind (Subp_Decl) in N_Generic_Subprogram_Declaration
24416 | N_Subprogram_Declaration
24417 and then Present (Context)
24418 and then Nkind (Context) in N_Generic_Package_Declaration
24419 | N_Package_Declaration
24423 -- Otherwise the placement is illegal
24427 ("pragma % must be applied to a library-level subprogram "
24432 Subp_Id := Defining_Entity (Subp_Decl);
24434 -- A pragma that applies to a Ghost entity becomes Ghost for the
24435 -- purposes of legality checks and removal of ignored Ghost code.
24437 Mark_Ghost_Pragma (N, Subp_Id);
24439 -- Chain the pragma on the contract for further processing by
24440 -- Analyze_Test_Case_In_Decl_Part.
24442 Add_Contract_Item (N, Subp_Id);
24444 -- Preanalyze the original aspect argument "Name" for a generic
24445 -- subprogram to properly capture global references.
24447 if Is_Generic_Subprogram (Subp_Id) then
24448 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24450 if Present (Asp_Arg) then
24452 -- The argument appears with an identifier in association
24455 if Nkind (Asp_Arg) = N_Component_Association then
24456 Asp_Arg := Expression (Asp_Arg);
24459 Check_Expr_Is_OK_Static_Expression
24460 (Asp_Arg, Standard_String);
24464 -- Ensure that the all Test_Case pragmas of the related subprogram
24465 -- have distinct names.
24467 Check_Distinct_Name (Subp_Id);
24469 -- Fully analyze the pragma when it appears inside an entry
24470 -- or subprogram body because it cannot benefit from forward
24473 if Nkind (Subp_Decl) in N_Entry_Body
24474 | N_Subprogram_Body
24475 | N_Subprogram_Body_Stub
24477 -- The legality checks of pragma Test_Case are affected by the
24478 -- SPARK mode in effect and the volatility of the context.
24479 -- Analyze all pragmas in a specific order.
24481 Analyze_If_Present (Pragma_SPARK_Mode);
24482 Analyze_If_Present (Pragma_Volatile_Function);
24483 Analyze_Test_Case_In_Decl_Part (N);
24487 --------------------------
24488 -- Thread_Local_Storage --
24489 --------------------------
24491 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24493 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24499 Check_Arg_Count (1);
24500 Check_Optional_Identifier (Arg1, Name_Entity);
24501 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24503 Id := Get_Pragma_Arg (Arg1);
24506 if not Is_Entity_Name (Id)
24507 or else Ekind (Entity (Id)) /= E_Variable
24509 Error_Pragma_Arg ("local variable name required", Arg1);
24514 -- A pragma that applies to a Ghost entity becomes Ghost for the
24515 -- purposes of legality checks and removal of ignored Ghost code.
24517 Mark_Ghost_Pragma (N, E);
24519 if Rep_Item_Too_Early (E, N)
24521 Rep_Item_Too_Late (E, N)
24526 Set_Has_Pragma_Thread_Local_Storage (E);
24527 Set_Has_Gigi_Rep_Item (E);
24528 end Thread_Local_Storage;
24534 -- pragma Time_Slice (static_duration_EXPRESSION);
24536 when Pragma_Time_Slice => Time_Slice : declare
24542 Check_Arg_Count (1);
24543 Check_No_Identifiers;
24544 Check_In_Main_Program;
24545 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24547 if not Error_Posted (Arg1) then
24549 while Present (Nod) loop
24550 if Nkind (Nod) = N_Pragma
24551 and then Pragma_Name (Nod) = Name_Time_Slice
24553 Error_Msg_Name_1 := Pname;
24554 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24561 -- Process only if in main unit
24563 if Get_Source_Unit (Loc) = Main_Unit then
24564 Opt.Time_Slice_Set := True;
24565 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24567 if Val <= Ureal_0 then
24568 Opt.Time_Slice_Value := 0;
24570 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24571 Opt.Time_Slice_Value := 1_000_000_000;
24574 Opt.Time_Slice_Value :=
24575 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24584 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24586 -- TITLING_OPTION ::=
24587 -- [Title =>] STRING_LITERAL
24588 -- | [Subtitle =>] STRING_LITERAL
24590 when Pragma_Title => Title : declare
24591 Args : Args_List (1 .. 2);
24592 Names : constant Name_List (1 .. 2) := (
24598 Gather_Associations (Names, Args);
24601 for J in 1 .. 2 loop
24602 if Present (Args (J)) then
24603 Check_Arg_Is_OK_Static_Expression
24604 (Args (J), Standard_String);
24609 ----------------------------
24610 -- Type_Invariant[_Class] --
24611 ----------------------------
24613 -- pragma Type_Invariant[_Class]
24614 -- ([Entity =>] type_LOCAL_NAME,
24615 -- [Check =>] EXPRESSION);
24617 when Pragma_Type_Invariant
24618 | Pragma_Type_Invariant_Class
24620 Type_Invariant : declare
24621 I_Pragma : Node_Id;
24624 Check_Arg_Count (2);
24626 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24627 -- setting Class_Present for the Type_Invariant_Class case.
24629 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24630 I_Pragma := New_Copy (N);
24631 Set_Pragma_Identifier
24632 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24633 Rewrite (N, I_Pragma);
24634 Set_Analyzed (N, False);
24636 end Type_Invariant;
24638 ---------------------
24639 -- Unchecked_Union --
24640 ---------------------
24642 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24644 when Pragma_Unchecked_Union => Unchecked_Union : declare
24645 Assoc : constant Node_Id := Arg1;
24646 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24656 Check_No_Identifiers;
24657 Check_Arg_Count (1);
24658 Check_Arg_Is_Local_Name (Arg1);
24660 Find_Type (Type_Id);
24662 Typ := Entity (Type_Id);
24664 -- A pragma that applies to a Ghost entity becomes Ghost for the
24665 -- purposes of legality checks and removal of ignored Ghost code.
24667 Mark_Ghost_Pragma (N, Typ);
24670 or else Rep_Item_Too_Early (Typ, N)
24674 Typ := Underlying_Type (Typ);
24677 if Rep_Item_Too_Late (Typ, N) then
24681 Check_First_Subtype (Arg1);
24683 -- Note remaining cases are references to a type in the current
24684 -- declarative part. If we find an error, we post the error on
24685 -- the relevant type declaration at an appropriate point.
24687 if not Is_Record_Type (Typ) then
24688 Error_Msg_N ("unchecked union must be record type", Typ);
24691 elsif Is_Tagged_Type (Typ) then
24692 Error_Msg_N ("unchecked union must not be tagged", Typ);
24695 elsif not Has_Discriminants (Typ) then
24697 ("unchecked union must have one discriminant", Typ);
24700 -- Note: in previous versions of GNAT we used to check for limited
24701 -- types and give an error, but in fact the standard does allow
24702 -- Unchecked_Union on limited types, so this check was removed.
24704 -- Similarly, GNAT used to require that all discriminants have
24705 -- default values, but this is not mandated by the RM.
24707 -- Proceed with basic error checks completed
24710 Tdef := Type_Definition (Declaration_Node (Typ));
24711 Clist := Component_List (Tdef);
24713 -- Check presence of component list and variant part
24715 if No (Clist) or else No (Variant_Part (Clist)) then
24717 ("unchecked union must have variant part", Tdef);
24721 -- Check components
24723 Comp := First_Non_Pragma (Component_Items (Clist));
24724 while Present (Comp) loop
24725 Check_Component (Comp, Typ);
24726 Next_Non_Pragma (Comp);
24729 -- Check variant part
24731 Vpart := Variant_Part (Clist);
24733 Variant := First_Non_Pragma (Variants (Vpart));
24734 while Present (Variant) loop
24735 Check_Variant (Variant, Typ);
24736 Next_Non_Pragma (Variant);
24740 Set_Is_Unchecked_Union (Typ);
24741 Set_Convention (Typ, Convention_C);
24742 Set_Has_Unchecked_Union (Base_Type (Typ));
24743 Set_Is_Unchecked_Union (Base_Type (Typ));
24744 end Unchecked_Union;
24746 ----------------------------
24747 -- Unevaluated_Use_Of_Old --
24748 ----------------------------
24750 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24752 when Pragma_Unevaluated_Use_Of_Old =>
24754 Check_Arg_Count (1);
24755 Check_No_Identifiers;
24756 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24758 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24759 -- a declarative part or a package spec.
24761 if not Is_Configuration_Pragma then
24762 Check_Is_In_Decl_Part_Or_Package_Spec;
24765 -- Store proper setting of Uneval_Old
24767 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24768 Uneval_Old := Fold_Upper (Name_Buffer (1));
24770 ------------------------
24771 -- Unimplemented_Unit --
24772 ------------------------
24774 -- pragma Unimplemented_Unit;
24776 -- Note: this only gives an error if we are generating code, or if
24777 -- we are in a generic library unit (where the pragma appears in the
24778 -- body, not in the spec).
24780 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24781 Cunitent : constant Entity_Id :=
24782 Cunit_Entity (Get_Source_Unit (Loc));
24783 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24787 Check_Arg_Count (0);
24789 if Operating_Mode = Generate_Code
24790 or else Ent_Kind = E_Generic_Function
24791 or else Ent_Kind = E_Generic_Procedure
24792 or else Ent_Kind = E_Generic_Package
24794 Get_Name_String (Chars (Cunitent));
24795 Set_Casing (Mixed_Case);
24796 Write_Str (Name_Buffer (1 .. Name_Len));
24797 Write_Str (" is not supported in this configuration");
24799 raise Unrecoverable_Error;
24801 end Unimplemented_Unit;
24803 ------------------------
24804 -- Universal_Aliasing --
24805 ------------------------
24807 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24809 when Pragma_Universal_Aliasing => Universal_Alias : declare
24815 Check_Arg_Count (1);
24816 Check_Optional_Identifier (Arg2, Name_Entity);
24817 Check_Arg_Is_Local_Name (Arg1);
24818 E_Id := Get_Pragma_Arg (Arg1);
24820 if Etype (E_Id) = Any_Type then
24824 E := Entity (E_Id);
24826 if not Is_Type (E) then
24827 Error_Pragma_Arg ("pragma% requires type", Arg1);
24830 -- A pragma that applies to a Ghost entity becomes Ghost for the
24831 -- purposes of legality checks and removal of ignored Ghost code.
24833 Mark_Ghost_Pragma (N, E);
24834 Set_Universal_Aliasing (Base_Type (E));
24835 Record_Rep_Item (E, N);
24836 end Universal_Alias;
24838 --------------------
24839 -- Universal_Data --
24840 --------------------
24842 -- pragma Universal_Data [(library_unit_NAME)];
24844 when Pragma_Universal_Data =>
24846 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24852 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24854 when Pragma_Unmodified =>
24855 Analyze_Unmodified_Or_Unused;
24861 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24863 -- or when used in a context clause:
24865 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24867 when Pragma_Unreferenced =>
24868 Analyze_Unreferenced_Or_Unused;
24870 --------------------------
24871 -- Unreferenced_Objects --
24872 --------------------------
24874 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24876 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
24878 Arg_Expr : Node_Id;
24879 Arg_Id : Entity_Id;
24881 Ghost_Error_Posted : Boolean := False;
24882 -- Flag set when an error concerning the illegal mix of Ghost and
24883 -- non-Ghost types is emitted.
24885 Ghost_Id : Entity_Id := Empty;
24886 -- The entity of the first Ghost type encountered while processing
24887 -- the arguments of the pragma.
24891 Check_At_Least_N_Arguments (1);
24894 while Present (Arg) loop
24895 Check_No_Identifier (Arg);
24896 Check_Arg_Is_Local_Name (Arg);
24897 Arg_Expr := Get_Pragma_Arg (Arg);
24899 if Is_Entity_Name (Arg_Expr) then
24900 Arg_Id := Entity (Arg_Expr);
24902 if Is_Type (Arg_Id) then
24903 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
24905 -- A pragma that applies to a Ghost entity becomes Ghost
24906 -- for the purposes of legality checks and removal of
24907 -- ignored Ghost code.
24909 Mark_Ghost_Pragma (N, Arg_Id);
24911 -- Capture the entity of the first Ghost type being
24912 -- processed for error detection purposes.
24914 if Is_Ghost_Entity (Arg_Id) then
24915 if No (Ghost_Id) then
24916 Ghost_Id := Arg_Id;
24919 -- Otherwise the type is non-Ghost. It is illegal to mix
24920 -- references to Ghost and non-Ghost entities
24923 elsif Present (Ghost_Id)
24924 and then not Ghost_Error_Posted
24926 Ghost_Error_Posted := True;
24928 Error_Msg_Name_1 := Pname;
24930 ("pragma % cannot mention ghost and non-ghost types",
24933 Error_Msg_Sloc := Sloc (Ghost_Id);
24934 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
24936 Error_Msg_Sloc := Sloc (Arg_Id);
24937 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
24941 ("argument for pragma% must be type or subtype", Arg);
24945 ("argument for pragma% must be type or subtype", Arg);
24950 end Unreferenced_Objects;
24952 ------------------------------
24953 -- Unreserve_All_Interrupts --
24954 ------------------------------
24956 -- pragma Unreserve_All_Interrupts;
24958 when Pragma_Unreserve_All_Interrupts =>
24960 Check_Arg_Count (0);
24962 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
24963 Unreserve_All_Interrupts := True;
24970 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24972 when Pragma_Unsuppress =>
24974 Process_Suppress_Unsuppress (Suppress_Case => False);
24980 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24982 when Pragma_Unused =>
24983 Analyze_Unmodified_Or_Unused (Is_Unused => True);
24984 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
24986 -------------------
24987 -- Use_VADS_Size --
24988 -------------------
24990 -- pragma Use_VADS_Size;
24992 when Pragma_Use_VADS_Size =>
24994 Check_Arg_Count (0);
24995 Check_Valid_Configuration_Pragma;
24996 Use_VADS_Size := True;
24998 ---------------------
24999 -- Validity_Checks --
25000 ---------------------
25002 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25004 when Pragma_Validity_Checks => Validity_Checks : declare
25005 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25011 Check_Arg_Count (1);
25012 Check_No_Identifiers;
25014 -- Pragma always active unless in CodePeer or GNATprove modes,
25015 -- which use a fixed configuration of validity checks.
25017 if not (CodePeer_Mode or GNATprove_Mode) then
25018 if Nkind (A) = N_String_Literal then
25022 Slen : constant Natural := Natural (String_Length (S));
25023 Options : String (1 .. Slen);
25027 -- Couldn't we use a for loop here over Options'Range???
25031 C := Get_String_Char (S, Pos (J));
25033 -- This is a weird test, it skips setting validity
25034 -- checks entirely if any element of S is out of
25035 -- range of Character, what is that about ???
25037 exit when not In_Character_Range (C);
25038 Options (J) := Get_Character (C);
25041 Set_Validity_Check_Options (Options);
25049 elsif Nkind (A) = N_Identifier then
25050 if Chars (A) = Name_All_Checks then
25051 Set_Validity_Check_Options ("a");
25052 elsif Chars (A) = Name_On then
25053 Validity_Checks_On := True;
25054 elsif Chars (A) = Name_Off then
25055 Validity_Checks_On := False;
25059 end Validity_Checks;
25065 -- pragma Volatile (LOCAL_NAME);
25067 when Pragma_Volatile =>
25068 Process_Atomic_Independent_Shared_Volatile;
25070 -------------------------
25071 -- Volatile_Components --
25072 -------------------------
25074 -- pragma Volatile_Components (array_LOCAL_NAME);
25076 -- Volatile is handled by the same circuit as Atomic_Components
25078 --------------------------
25079 -- Volatile_Full_Access --
25080 --------------------------
25082 -- pragma Volatile_Full_Access (LOCAL_NAME);
25084 when Pragma_Volatile_Full_Access =>
25086 Process_Atomic_Independent_Shared_Volatile;
25088 -----------------------
25089 -- Volatile_Function --
25090 -----------------------
25092 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25094 when Pragma_Volatile_Function => Volatile_Function : declare
25095 Over_Id : Entity_Id;
25096 Spec_Id : Entity_Id;
25097 Subp_Decl : Node_Id;
25101 Check_No_Identifiers;
25102 Check_At_Most_N_Arguments (1);
25105 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25107 -- Generic subprogram
25109 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25112 -- Body acts as spec
25114 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25115 and then No (Corresponding_Spec (Subp_Decl))
25119 -- Body stub acts as spec
25121 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25122 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25128 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25136 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25138 if Ekind (Spec_Id) not in E_Function | E_Generic_Function then
25143 -- A pragma that applies to a Ghost entity becomes Ghost for the
25144 -- purposes of legality checks and removal of ignored Ghost code.
25146 Mark_Ghost_Pragma (N, Spec_Id);
25148 -- Chain the pragma on the contract for completeness
25150 Add_Contract_Item (N, Spec_Id);
25152 -- The legality checks of pragma Volatile_Function are affected by
25153 -- the SPARK mode in effect. Analyze all pragmas in a specific
25156 Analyze_If_Present (Pragma_SPARK_Mode);
25158 -- A volatile function cannot override a non-volatile function
25159 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25160 -- in New_Overloaded_Entity, however at that point the pragma has
25161 -- not been processed yet.
25163 Over_Id := Overridden_Operation (Spec_Id);
25165 if Present (Over_Id)
25166 and then not Is_Volatile_Function (Over_Id)
25169 ("incompatible volatile function values in effect", Spec_Id);
25171 Error_Msg_Sloc := Sloc (Over_Id);
25173 ("\& declared # with Volatile_Function value False",
25176 Error_Msg_Sloc := Sloc (Spec_Id);
25178 ("\overridden # with Volatile_Function value True",
25182 -- Analyze the Boolean expression (if any)
25184 if Present (Arg1) then
25185 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25187 end Volatile_Function;
25189 ----------------------
25190 -- Warning_As_Error --
25191 ----------------------
25193 -- pragma Warning_As_Error (static_string_EXPRESSION);
25195 when Pragma_Warning_As_Error =>
25197 Check_Arg_Count (1);
25198 Check_No_Identifiers;
25199 Check_Valid_Configuration_Pragma;
25201 if not Is_Static_String_Expression (Arg1) then
25203 ("argument of pragma% must be static string expression",
25206 -- OK static string expression
25209 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25210 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25211 new String'(Acquire_Warning_Match_String
25212 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25219 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25221 -- DETAILS ::= On | Off
25222 -- DETAILS ::= On | Off, local_NAME
25223 -- DETAILS ::= static_string_EXPRESSION
25224 -- DETAILS ::= On | Off, static_string_EXPRESSION
25226 -- TOOL_NAME ::= GNAT | GNATprove
25228 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25230 -- Note: If the first argument matches an allowed tool name, it is
25231 -- always considered to be a tool name, even if there is a string
25232 -- variable of that name.
25234 -- Note if the second argument of DETAILS is a local_NAME then the
25235 -- second form is always understood. If the intention is to use
25236 -- the fourth form, then you can write NAME & "" to force the
25237 -- intepretation as a static_string_EXPRESSION.
25239 when Pragma_Warnings => Warnings : declare
25240 Reason : String_Id;
25244 Check_At_Least_N_Arguments (1);
25246 -- See if last argument is labeled Reason. If so, make sure we
25247 -- have a string literal or a concatenation of string literals,
25248 -- and acquire the REASON string. Then remove the REASON argument
25249 -- by decreasing Num_Args by one; Remaining processing looks only
25250 -- at first Num_Args arguments).
25253 Last_Arg : constant Node_Id :=
25254 Last (Pragma_Argument_Associations (N));
25257 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25258 and then Chars (Last_Arg) = Name_Reason
25261 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25262 Reason := End_String;
25263 Arg_Count := Arg_Count - 1;
25265 -- Not allowed in compiler units (bootstrap issues)
25267 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25269 -- No REASON string, set null string as reason
25272 Reason := Null_String_Id;
25276 -- Now proceed with REASON taken care of and eliminated
25278 Check_No_Identifiers;
25280 -- If debug flag -gnatd.i is set, pragma is ignored
25282 if Debug_Flag_Dot_I then
25286 -- Process various forms of the pragma
25289 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25290 Shifted_Args : List_Id;
25293 -- See if first argument is a tool name, currently either
25294 -- GNAT or GNATprove. If so, either ignore the pragma if the
25295 -- tool used does not match, or continue as if no tool name
25296 -- was given otherwise, by shifting the arguments.
25298 if Nkind (Argx) = N_Identifier
25299 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25301 if Chars (Argx) = Name_Gnat then
25302 if CodePeer_Mode or GNATprove_Mode then
25303 Rewrite (N, Make_Null_Statement (Loc));
25308 elsif Chars (Argx) = Name_Gnatprove then
25309 if not GNATprove_Mode then
25310 Rewrite (N, Make_Null_Statement (Loc));
25316 raise Program_Error;
25319 -- At this point, the pragma Warnings applies to the tool,
25320 -- so continue with shifted arguments.
25322 Arg_Count := Arg_Count - 1;
25324 if Arg_Count = 1 then
25325 Shifted_Args := New_List (New_Copy (Arg2));
25326 elsif Arg_Count = 2 then
25327 Shifted_Args := New_List (New_Copy (Arg2),
25329 elsif Arg_Count = 3 then
25330 Shifted_Args := New_List (New_Copy (Arg2),
25334 raise Program_Error;
25339 Chars => Name_Warnings,
25340 Pragma_Argument_Associations => Shifted_Args));
25345 -- One argument case
25347 if Arg_Count = 1 then
25349 -- On/Off one argument case was processed by parser
25351 if Nkind (Argx) = N_Identifier
25352 and then Chars (Argx) in Name_On | Name_Off
25356 -- One argument case must be ON/OFF or static string expr
25358 elsif not Is_Static_String_Expression (Arg1) then
25360 ("argument of pragma% must be On/Off or static string "
25361 & "expression", Arg1);
25363 -- One argument string expression case
25367 Lit : constant Node_Id := Expr_Value_S (Argx);
25368 Str : constant String_Id := Strval (Lit);
25369 Len : constant Nat := String_Length (Str);
25377 while J <= Len loop
25378 C := Get_String_Char (Str, J);
25379 OK := In_Character_Range (C);
25382 Chr := Get_Character (C);
25384 -- Dash case: only -Wxxx is accepted
25391 C := Get_String_Char (Str, J);
25392 Chr := Get_Character (C);
25393 exit when Chr = 'W';
25398 elsif J < Len and then Chr = '.' then
25400 C := Get_String_Char (Str, J);
25401 Chr := Get_Character (C);
25403 if not Set_Dot_Warning_Switch (Chr) then
25405 ("invalid warning switch character "
25406 & '.' & Chr, Arg1);
25412 OK := Set_Warning_Switch (Chr);
25417 ("invalid warning switch character " & Chr,
25423 ("invalid wide character in warning switch ",
25432 -- Two or more arguments (must be two)
25435 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25436 Check_Arg_Count (2);
25444 E_Id := Get_Pragma_Arg (Arg2);
25447 -- In the expansion of an inlined body, a reference to
25448 -- the formal may be wrapped in a conversion if the
25449 -- actual is a conversion. Retrieve the real entity name.
25451 if (In_Instance_Body or In_Inlined_Body)
25452 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25454 E_Id := Expression (E_Id);
25457 -- Entity name case
25459 if Is_Entity_Name (E_Id) then
25460 E := Entity (E_Id);
25467 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25470 -- Suppress elaboration warnings if the entity
25471 -- denotes an elaboration target.
25473 if Is_Elaboration_Target (E) then
25474 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25477 -- For OFF case, make entry in warnings off
25478 -- pragma table for later processing. But we do
25479 -- not do that within an instance, since these
25480 -- warnings are about what is needed in the
25481 -- template, not an instance of it.
25483 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25484 and then Warn_On_Warnings_Off
25485 and then not In_Instance
25487 Warnings_Off_Pragmas.Append ((N, E, Reason));
25490 if Is_Enumeration_Type (E) then
25494 Lit := First_Literal (E);
25495 while Present (Lit) loop
25496 Set_Warnings_Off (Lit);
25497 Next_Literal (Lit);
25502 exit when No (Homonym (E));
25507 -- Error if not entity or static string expression case
25509 elsif not Is_Static_String_Expression (Arg2) then
25511 ("second argument of pragma% must be entity name "
25512 & "or static string expression", Arg2);
25514 -- Static string expression case
25517 -- Note on configuration pragma case: If this is a
25518 -- configuration pragma, then for an OFF pragma, we
25519 -- just set Config True in the call, which is all
25520 -- that needs to be done. For the case of ON, this
25521 -- is normally an error, unless it is canceling the
25522 -- effect of a previous OFF pragma in the same file.
25523 -- In any other case, an error will be signalled (ON
25524 -- with no matching OFF).
25526 -- Note: We set Used if we are inside a generic to
25527 -- disable the test that the non-config case actually
25528 -- cancels a warning. That's because we can't be sure
25529 -- there isn't an instantiation in some other unit
25530 -- where a warning is suppressed.
25532 -- We could do a little better here by checking if the
25533 -- generic unit we are inside is public, but for now
25534 -- we don't bother with that refinement.
25537 Message : constant String :=
25538 Acquire_Warning_Match_String
25539 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25541 if Chars (Argx) = Name_Off then
25542 Set_Specific_Warning_Off
25543 (Loc, Message, Reason,
25544 Config => Is_Configuration_Pragma,
25545 Used => Inside_A_Generic or else In_Instance);
25547 elsif Chars (Argx) = Name_On then
25548 Set_Specific_Warning_On (Loc, Message, Err);
25552 ("??pragma Warnings On with no matching "
25553 & "Warnings Off", Loc);
25563 -------------------
25564 -- Weak_External --
25565 -------------------
25567 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25569 when Pragma_Weak_External => Weak_External : declare
25574 Check_Arg_Count (1);
25575 Check_Optional_Identifier (Arg1, Name_Entity);
25576 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25577 Ent := Entity (Get_Pragma_Arg (Arg1));
25579 if Rep_Item_Too_Early (Ent, N) then
25582 Ent := Underlying_Type (Ent);
25585 -- The pragma applies to entities with addresses
25587 if Is_Type (Ent) then
25588 Error_Pragma ("pragma applies to objects and subprograms");
25591 -- The only processing required is to link this item on to the
25592 -- list of rep items for the given entity. This is accomplished
25593 -- by the call to Rep_Item_Too_Late (when no error is detected
25594 -- and False is returned).
25596 if Rep_Item_Too_Late (Ent, N) then
25599 Set_Has_Gigi_Rep_Item (Ent);
25603 -----------------------------
25604 -- Wide_Character_Encoding --
25605 -----------------------------
25607 -- pragma Wide_Character_Encoding (IDENTIFIER);
25609 when Pragma_Wide_Character_Encoding =>
25612 -- Nothing to do, handled in parser. Note that we do not enforce
25613 -- configuration pragma placement, this pragma can appear at any
25614 -- place in the source, allowing mixed encodings within a single
25619 --------------------
25620 -- Unknown_Pragma --
25621 --------------------
25623 -- Should be impossible, since the case of an unknown pragma is
25624 -- separately processed before the case statement is entered.
25626 when Unknown_Pragma =>
25627 raise Program_Error;
25630 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25631 -- until AI is formally approved.
25633 -- Check_Order_Dependence;
25636 when Pragma_Exit => null;
25637 end Analyze_Pragma;
25639 ---------------------------------------------
25640 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25641 ---------------------------------------------
25643 -- WARNING: This routine manages Ghost regions. Return statements must be
25644 -- replaced by gotos which jump to the end of the routine and restore the
25647 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25649 Freeze_Id : Entity_Id := Empty)
25651 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25652 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25654 Disp_Typ : Entity_Id;
25655 -- The dispatching type of the subprogram subject to the pre- or
25658 function Check_References (Nod : Node_Id) return Traverse_Result;
25659 -- Check that expression Nod does not mention non-primitives of the
25660 -- type, global objects of the type, or other illegalities described
25661 -- and implied by AI12-0113.
25663 ----------------------
25664 -- Check_References --
25665 ----------------------
25667 function Check_References (Nod : Node_Id) return Traverse_Result is
25669 if Nkind (Nod) = N_Function_Call
25670 and then Is_Entity_Name (Name (Nod))
25673 Func : constant Entity_Id := Entity (Name (Nod));
25677 -- An operation of the type must be a primitive
25679 if No (Find_Dispatching_Type (Func)) then
25680 Form := First_Formal (Func);
25681 while Present (Form) loop
25682 if Etype (Form) = Disp_Typ then
25684 ("operation in class-wide condition must be "
25685 & "primitive of &", Nod, Disp_Typ);
25688 Next_Formal (Form);
25691 -- A return object of the type is illegal as well
25693 if Etype (Func) = Disp_Typ
25694 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25697 ("operation in class-wide condition must be primitive "
25698 & "of &", Nod, Disp_Typ);
25701 -- Otherwise we have a call to an overridden primitive, and we
25702 -- will create a common class-wide clone for the body of
25703 -- original operation and its eventual inherited versions. If
25704 -- the original operation dispatches on result it is never
25705 -- inherited and there is no need for a clone. There is not
25706 -- need for a clone either in GNATprove mode, as cases that
25707 -- would require it are rejected (when an inherited primitive
25708 -- calls an overridden operation in a class-wide contract), and
25709 -- the clone would make proof impossible in some cases.
25711 elsif not Is_Abstract_Subprogram (Spec_Id)
25712 and then No (Class_Wide_Clone (Spec_Id))
25713 and then not Has_Controlling_Result (Spec_Id)
25714 and then not GNATprove_Mode
25716 Build_Class_Wide_Clone_Decl (Spec_Id);
25720 elsif Is_Entity_Name (Nod)
25722 (Etype (Nod) = Disp_Typ
25723 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25724 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
25727 ("object in class-wide condition must be formal of type &",
25730 elsif Nkind (Nod) = N_Explicit_Dereference
25731 and then (Etype (Nod) = Disp_Typ
25732 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25733 and then (not Is_Entity_Name (Prefix (Nod))
25734 or else not Is_Formal (Entity (Prefix (Nod))))
25737 ("operation in class-wide condition must be primitive of &",
25742 end Check_References;
25744 procedure Check_Class_Wide_Condition is
25745 new Traverse_Proc (Check_References);
25749 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25751 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25752 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25753 -- Save the Ghost-related attributes to restore on exit
25756 Restore_Scope : Boolean := False;
25758 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25761 -- Do not analyze the pragma multiple times
25763 if Is_Analyzed_Pragma (N) then
25767 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25768 -- analysis of the pragma, the Ghost mode at point of declaration and
25769 -- point of analysis may not necessarily be the same. Use the mode in
25770 -- effect at the point of declaration.
25772 Set_Ghost_Mode (N);
25774 -- Ensure that the subprogram and its formals are visible when analyzing
25775 -- the expression of the pragma.
25777 if not In_Open_Scopes (Spec_Id) then
25778 Restore_Scope := True;
25779 Push_Scope (Spec_Id);
25781 if Is_Generic_Subprogram (Spec_Id) then
25782 Install_Generic_Formals (Spec_Id);
25784 Install_Formals (Spec_Id);
25788 Errors := Serious_Errors_Detected;
25789 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25791 -- Emit a clarification message when the expression contains at least
25792 -- one undefined reference, possibly due to contract freezing.
25794 if Errors /= Serious_Errors_Detected
25795 and then Present (Freeze_Id)
25796 and then Has_Undefined_Reference (Expr)
25798 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25801 if Class_Present (N) then
25803 -- Verify that a class-wide condition is legal, i.e. the operation is
25804 -- a primitive of a tagged type. Note that a generic subprogram is
25805 -- not a primitive operation.
25807 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25809 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25810 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25812 if From_Aspect_Specification (N) then
25814 ("aspect % can only be specified for a primitive operation "
25815 & "of a tagged type", Corresponding_Aspect (N));
25817 -- The pragma is a source construct
25821 ("pragma % can only be specified for a primitive operation "
25822 & "of a tagged type", N);
25825 -- Remaining semantic checks require a full tree traversal
25828 Check_Class_Wide_Condition (Expr);
25833 if Restore_Scope then
25837 -- If analysis of the condition indicates that a class-wide clone
25838 -- has been created, build and analyze its declaration.
25840 if Is_Subprogram (Spec_Id)
25841 and then Present (Class_Wide_Clone (Spec_Id))
25843 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25846 -- Currently it is not possible to inline pre/postconditions on a
25847 -- subprogram subject to pragma Inline_Always.
25849 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25850 Set_Is_Analyzed_Pragma (N);
25852 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25853 end Analyze_Pre_Post_Condition_In_Decl_Part;
25855 ------------------------------------------
25856 -- Analyze_Refined_Depends_In_Decl_Part --
25857 ------------------------------------------
25859 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25860 procedure Check_Dependency_Clause
25861 (Spec_Id : Entity_Id;
25862 Dep_Clause : Node_Id;
25863 Dep_States : Elist_Id;
25864 Refinements : List_Id;
25865 Matched_Items : in out Elist_Id);
25866 -- Try to match a single dependency clause Dep_Clause against one or
25867 -- more refinement clauses found in list Refinements. Each successful
25868 -- match eliminates at least one refinement clause from Refinements.
25869 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25870 -- denotes the entities of all abstract states which appear in pragma
25871 -- Depends. Matched_Items contains the entities of all successfully
25872 -- matched items found in pragma Depends.
25874 procedure Check_Output_States
25875 (Spec_Inputs : Elist_Id;
25876 Spec_Outputs : Elist_Id;
25877 Body_Inputs : Elist_Id;
25878 Body_Outputs : Elist_Id);
25879 -- Determine whether pragma Depends contains an output state with a
25880 -- visible refinement and if so, ensure that pragma Refined_Depends
25881 -- mentions all its constituents as outputs. Spec_Inputs and
25882 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
25883 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
25884 -- the inputs and outputs of the subprogram body synthesized from pragma
25885 -- Refined_Depends.
25887 function Collect_States (Clauses : List_Id) return Elist_Id;
25888 -- Given a normalized list of dependencies obtained from calling
25889 -- Normalize_Clauses, return a list containing the entities of all
25890 -- states appearing in dependencies. It helps in checking refinements
25891 -- involving a state and a corresponding constituent which is not a
25892 -- direct constituent of the state.
25894 procedure Normalize_Clauses (Clauses : List_Id);
25895 -- Given a list of dependence or refinement clauses Clauses, normalize
25896 -- each clause by creating multiple dependencies with exactly one input
25899 procedure Remove_Extra_Clauses
25900 (Clauses : List_Id;
25901 Matched_Items : Elist_Id);
25902 -- Given a list of refinement clauses Clauses, remove all clauses whose
25903 -- inputs and/or outputs have been previously matched. See the body for
25904 -- all special cases. Matched_Items contains the entities of all matched
25905 -- items found in pragma Depends.
25907 procedure Report_Extra_Clauses (Clauses : List_Id);
25908 -- Emit an error for each extra clause found in list Clauses
25910 -----------------------------
25911 -- Check_Dependency_Clause --
25912 -----------------------------
25914 procedure Check_Dependency_Clause
25915 (Spec_Id : Entity_Id;
25916 Dep_Clause : Node_Id;
25917 Dep_States : Elist_Id;
25918 Refinements : List_Id;
25919 Matched_Items : in out Elist_Id)
25921 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25922 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25924 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25925 -- Determine whether dependency item Dep_Item has been matched in a
25926 -- previous clause.
25928 function Is_In_Out_State_Clause return Boolean;
25929 -- Determine whether dependence clause Dep_Clause denotes an abstract
25930 -- state that depends on itself (State => State).
25932 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25933 -- Determine whether item Item denotes an abstract state with visible
25934 -- null refinement.
25936 procedure Match_Items
25937 (Dep_Item : Node_Id;
25938 Ref_Item : Node_Id;
25939 Matched : out Boolean);
25940 -- Try to match dependence item Dep_Item against refinement item
25941 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25942 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25943 -- the following conformance scenarios is in effect:
25944 -- 1) Both items denote null
25945 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25946 -- 3) Both items denote attribute 'Result
25947 -- 4) Both items denote the same object
25948 -- 5) Both items denote the same formal parameter
25949 -- 6) Both items denote the same current instance of a type
25950 -- 7) Both items denote the same discriminant
25951 -- 8) Dep_Item is an abstract state with visible null refinement
25952 -- and Ref_Item denotes null.
25953 -- 9) Dep_Item is an abstract state with visible null refinement
25954 -- and Ref_Item is Empty (special case).
25955 -- 10) Dep_Item is an abstract state with full or partial visible
25956 -- non-null refinement and Ref_Item denotes one of its
25958 -- 11) Dep_Item is an abstract state without a full visible
25959 -- refinement and Ref_Item denotes the same state.
25960 -- When scenario 10 is in effect, the entity of the abstract state
25961 -- denoted by Dep_Item is added to list Refined_States.
25963 procedure Record_Item (Item_Id : Entity_Id);
25964 -- Store the entity of an item denoted by Item_Id in Matched_Items
25966 ------------------------
25967 -- Is_Already_Matched --
25968 ------------------------
25970 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
25971 Item_Id : Entity_Id := Empty;
25974 -- When the dependency item denotes attribute 'Result, check for
25975 -- the entity of the related subprogram.
25977 if Is_Attribute_Result (Dep_Item) then
25978 Item_Id := Spec_Id;
25980 elsif Is_Entity_Name (Dep_Item) then
25981 Item_Id := Available_View (Entity_Of (Dep_Item));
25985 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
25986 end Is_Already_Matched;
25988 ----------------------------
25989 -- Is_In_Out_State_Clause --
25990 ----------------------------
25992 function Is_In_Out_State_Clause return Boolean is
25993 Dep_Input_Id : Entity_Id;
25994 Dep_Output_Id : Entity_Id;
25997 -- Detect the following clause:
26000 if Is_Entity_Name (Dep_Input)
26001 and then Is_Entity_Name (Dep_Output)
26003 -- Handle abstract views generated for limited with clauses
26005 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26006 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26009 Ekind (Dep_Input_Id) = E_Abstract_State
26010 and then Dep_Input_Id = Dep_Output_Id;
26014 end Is_In_Out_State_Clause;
26016 ---------------------------
26017 -- Is_Null_Refined_State --
26018 ---------------------------
26020 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26021 Item_Id : Entity_Id;
26024 if Is_Entity_Name (Item) then
26026 -- Handle abstract views generated for limited with clauses
26028 Item_Id := Available_View (Entity_Of (Item));
26031 Ekind (Item_Id) = E_Abstract_State
26032 and then Has_Null_Visible_Refinement (Item_Id);
26036 end Is_Null_Refined_State;
26042 procedure Match_Items
26043 (Dep_Item : Node_Id;
26044 Ref_Item : Node_Id;
26045 Matched : out Boolean)
26047 Dep_Item_Id : Entity_Id;
26048 Ref_Item_Id : Entity_Id;
26051 -- Assume that the two items do not match
26055 -- A null matches null or Empty (special case)
26057 if Nkind (Dep_Item) = N_Null
26058 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26062 -- Attribute 'Result matches attribute 'Result
26064 elsif Is_Attribute_Result (Dep_Item)
26065 and then Is_Attribute_Result (Ref_Item)
26067 -- Put the entity of the related function on the list of
26068 -- matched items because attribute 'Result does not carry
26069 -- an entity similar to states and constituents.
26071 Record_Item (Spec_Id);
26074 -- Abstract states, current instances of concurrent types,
26075 -- discriminants, formal parameters and objects.
26077 elsif Is_Entity_Name (Dep_Item) then
26079 -- Handle abstract views generated for limited with clauses
26081 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26083 if Ekind (Dep_Item_Id) = E_Abstract_State then
26085 -- An abstract state with visible null refinement matches
26086 -- null or Empty (special case).
26088 if Has_Null_Visible_Refinement (Dep_Item_Id)
26089 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26091 Record_Item (Dep_Item_Id);
26094 -- An abstract state with visible non-null refinement
26095 -- matches one of its constituents, or itself for an
26096 -- abstract state with partial visible refinement.
26098 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26099 if Is_Entity_Name (Ref_Item) then
26100 Ref_Item_Id := Entity_Of (Ref_Item);
26102 if Ekind (Ref_Item_Id) in
26103 E_Abstract_State | E_Constant | E_Variable
26104 and then Present (Encapsulating_State (Ref_Item_Id))
26105 and then Find_Encapsulating_State
26106 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26108 Record_Item (Dep_Item_Id);
26111 elsif not Has_Visible_Refinement (Dep_Item_Id)
26112 and then Ref_Item_Id = Dep_Item_Id
26114 Record_Item (Dep_Item_Id);
26119 -- An abstract state without a visible refinement matches
26122 elsif Is_Entity_Name (Ref_Item)
26123 and then Entity_Of (Ref_Item) = Dep_Item_Id
26125 Record_Item (Dep_Item_Id);
26129 -- A current instance of a concurrent type, discriminant,
26130 -- formal parameter or an object matches itself.
26132 elsif Is_Entity_Name (Ref_Item)
26133 and then Entity_Of (Ref_Item) = Dep_Item_Id
26135 Record_Item (Dep_Item_Id);
26145 procedure Record_Item (Item_Id : Entity_Id) is
26147 if No (Matched_Items) then
26148 Matched_Items := New_Elmt_List;
26151 Append_Unique_Elmt (Item_Id, Matched_Items);
26156 Clause_Matched : Boolean := False;
26157 Dummy : Boolean := False;
26158 Inputs_Match : Boolean;
26159 Next_Ref_Clause : Node_Id;
26160 Outputs_Match : Boolean;
26161 Ref_Clause : Node_Id;
26162 Ref_Input : Node_Id;
26163 Ref_Output : Node_Id;
26165 -- Start of processing for Check_Dependency_Clause
26168 -- Do not perform this check in an instance because it was already
26169 -- performed successfully in the generic template.
26171 if In_Instance then
26175 -- Examine all refinement clauses and compare them against the
26176 -- dependence clause.
26178 Ref_Clause := First (Refinements);
26179 while Present (Ref_Clause) loop
26180 Next_Ref_Clause := Next (Ref_Clause);
26182 -- Obtain the attributes of the current refinement clause
26184 Ref_Input := Expression (Ref_Clause);
26185 Ref_Output := First (Choices (Ref_Clause));
26187 -- The current refinement clause matches the dependence clause
26188 -- when both outputs match and both inputs match. See routine
26189 -- Match_Items for all possible conformance scenarios.
26191 -- Depends Dep_Output => Dep_Input
26195 -- Refined_Depends Ref_Output => Ref_Input
26198 (Dep_Item => Dep_Input,
26199 Ref_Item => Ref_Input,
26200 Matched => Inputs_Match);
26203 (Dep_Item => Dep_Output,
26204 Ref_Item => Ref_Output,
26205 Matched => Outputs_Match);
26207 -- An In_Out state clause may be matched against a refinement with
26208 -- a null input or null output as long as the non-null side of the
26209 -- relation contains a valid constituent of the In_Out_State.
26211 if Is_In_Out_State_Clause then
26213 -- Depends => (State => State)
26214 -- Refined_Depends => (null => Constit) -- OK
26217 and then not Outputs_Match
26218 and then Nkind (Ref_Output) = N_Null
26220 Outputs_Match := True;
26223 -- Depends => (State => State)
26224 -- Refined_Depends => (Constit => null) -- OK
26226 if not Inputs_Match
26227 and then Outputs_Match
26228 and then Nkind (Ref_Input) = N_Null
26230 Inputs_Match := True;
26234 -- The current refinement clause is legally constructed following
26235 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26236 -- the pool of candidates. The seach continues because a single
26237 -- dependence clause may have multiple matching refinements.
26239 if Inputs_Match and Outputs_Match then
26240 Clause_Matched := True;
26241 Remove (Ref_Clause);
26244 Ref_Clause := Next_Ref_Clause;
26247 -- Depending on the order or composition of refinement clauses, an
26248 -- In_Out state clause may not be directly refinable.
26250 -- Refined_State => (State => (Constit_1, Constit_2))
26251 -- Depends => ((Output, State) => (Input, State))
26252 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26254 -- Matching normalized clause (State => State) fails because there is
26255 -- no direct refinement capable of satisfying this relation. Another
26256 -- similar case arises when clauses (Constit_1 => Input) and (Output
26257 -- => Constit_2) are matched first, leaving no candidates for clause
26258 -- (State => State). Both scenarios are legal as long as one of the
26259 -- previous clauses mentioned a valid constituent of State.
26261 if not Clause_Matched
26262 and then Is_In_Out_State_Clause
26263 and then Is_Already_Matched (Dep_Input)
26265 Clause_Matched := True;
26268 -- A clause where the input is an abstract state with visible null
26269 -- refinement or a 'Result attribute is implicitly matched when the
26270 -- output has already been matched in a previous clause.
26272 -- Refined_State => (State => null)
26273 -- Depends => (Output => State) -- implicitly OK
26274 -- Refined_Depends => (Output => ...)
26275 -- Depends => (...'Result => State) -- implicitly OK
26276 -- Refined_Depends => (...'Result => ...)
26278 if not Clause_Matched
26279 and then Is_Null_Refined_State (Dep_Input)
26280 and then Is_Already_Matched (Dep_Output)
26282 Clause_Matched := True;
26285 -- A clause where the output is an abstract state with visible null
26286 -- refinement is implicitly matched when the input has already been
26287 -- matched in a previous clause.
26289 -- Refined_State => (State => null)
26290 -- Depends => (State => Input) -- implicitly OK
26291 -- Refined_Depends => (... => Input)
26293 if not Clause_Matched
26294 and then Is_Null_Refined_State (Dep_Output)
26295 and then Is_Already_Matched (Dep_Input)
26297 Clause_Matched := True;
26300 -- At this point either all refinement clauses have been examined or
26301 -- pragma Refined_Depends contains a solitary null. Only an abstract
26302 -- state with null refinement can possibly match these cases.
26304 -- Refined_State => (State => null)
26305 -- Depends => (State => null)
26306 -- Refined_Depends => null -- OK
26308 if not Clause_Matched then
26310 (Dep_Item => Dep_Input,
26312 Matched => Inputs_Match);
26315 (Dep_Item => Dep_Output,
26317 Matched => Outputs_Match);
26319 Clause_Matched := Inputs_Match and Outputs_Match;
26322 -- If the contents of Refined_Depends are legal, then the current
26323 -- dependence clause should be satisfied either by an explicit match
26324 -- or by one of the special cases.
26326 if not Clause_Matched then
26328 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26329 & "matching refinement in body"), Dep_Clause, Spec_Id);
26331 end Check_Dependency_Clause;
26333 -------------------------
26334 -- Check_Output_States --
26335 -------------------------
26337 procedure Check_Output_States
26338 (Spec_Inputs : Elist_Id;
26339 Spec_Outputs : Elist_Id;
26340 Body_Inputs : Elist_Id;
26341 Body_Outputs : Elist_Id)
26343 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26344 -- Determine whether all constituents of state State_Id with full
26345 -- visible refinement are used as outputs in pragma Refined_Depends.
26346 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26348 -----------------------------
26349 -- Check_Constituent_Usage --
26350 -----------------------------
26352 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26353 Constits : constant Elist_Id :=
26354 Partial_Refinement_Constituents (State_Id);
26355 Constit_Elmt : Elmt_Id;
26356 Constit_Id : Entity_Id;
26357 Only_Partial : constant Boolean :=
26358 not Has_Visible_Refinement (State_Id);
26359 Posted : Boolean := False;
26362 if Present (Constits) then
26363 Constit_Elmt := First_Elmt (Constits);
26364 while Present (Constit_Elmt) loop
26365 Constit_Id := Node (Constit_Elmt);
26367 -- Issue an error when a constituent of State_Id is used,
26368 -- and State_Id has only partial visible refinement
26369 -- (SPARK RM 7.2.4(3d)).
26371 if Only_Partial then
26372 if (Present (Body_Inputs)
26373 and then Appears_In (Body_Inputs, Constit_Id))
26375 (Present (Body_Outputs)
26376 and then Appears_In (Body_Outputs, Constit_Id))
26378 Error_Msg_Name_1 := Chars (State_Id);
26380 ("constituent & of state % cannot be used in "
26381 & "dependence refinement", N, Constit_Id);
26382 Error_Msg_Name_1 := Chars (State_Id);
26383 SPARK_Msg_N ("\use state % instead", N);
26386 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26388 elsif Present (Body_Inputs)
26389 and then Appears_In (Body_Inputs, Constit_Id)
26391 Error_Msg_Name_1 := Chars (State_Id);
26393 ("constituent & of state % must act as output in "
26394 & "dependence refinement", N, Constit_Id);
26396 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26398 elsif No (Body_Outputs)
26399 or else not Appears_In (Body_Outputs, Constit_Id)
26404 ("output state & must be replaced by all its "
26405 & "constituents in dependence refinement",
26410 ("\constituent & is missing in output list",
26414 Next_Elmt (Constit_Elmt);
26417 end Check_Constituent_Usage;
26422 Item_Elmt : Elmt_Id;
26423 Item_Id : Entity_Id;
26425 -- Start of processing for Check_Output_States
26428 -- Do not perform this check in an instance because it was already
26429 -- performed successfully in the generic template.
26431 if In_Instance then
26434 -- Inspect the outputs of pragma Depends looking for a state with a
26435 -- visible refinement.
26437 elsif Present (Spec_Outputs) then
26438 Item_Elmt := First_Elmt (Spec_Outputs);
26439 while Present (Item_Elmt) loop
26440 Item := Node (Item_Elmt);
26442 -- Deal with the mixed nature of the input and output lists
26444 if Nkind (Item) = N_Defining_Identifier then
26447 Item_Id := Available_View (Entity_Of (Item));
26450 if Ekind (Item_Id) = E_Abstract_State then
26452 -- The state acts as an input-output, skip it
26454 if Present (Spec_Inputs)
26455 and then Appears_In (Spec_Inputs, Item_Id)
26459 -- Ensure that all of the constituents are utilized as
26460 -- outputs in pragma Refined_Depends.
26462 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26463 Check_Constituent_Usage (Item_Id);
26467 Next_Elmt (Item_Elmt);
26470 end Check_Output_States;
26472 --------------------
26473 -- Collect_States --
26474 --------------------
26476 function Collect_States (Clauses : List_Id) return Elist_Id is
26477 procedure Collect_State
26479 States : in out Elist_Id);
26480 -- Add the entity of Item to list States when it denotes to a state
26482 -------------------
26483 -- Collect_State --
26484 -------------------
26486 procedure Collect_State
26488 States : in out Elist_Id)
26493 if Is_Entity_Name (Item) then
26494 Id := Entity_Of (Item);
26496 if Ekind (Id) = E_Abstract_State then
26497 if No (States) then
26498 States := New_Elmt_List;
26501 Append_Unique_Elmt (Id, States);
26511 States : Elist_Id := No_Elist;
26513 -- Start of processing for Collect_States
26516 Clause := First (Clauses);
26517 while Present (Clause) loop
26518 Input := Expression (Clause);
26519 Output := First (Choices (Clause));
26521 Collect_State (Input, States);
26522 Collect_State (Output, States);
26528 end Collect_States;
26530 -----------------------
26531 -- Normalize_Clauses --
26532 -----------------------
26534 procedure Normalize_Clauses (Clauses : List_Id) is
26535 procedure Normalize_Inputs (Clause : Node_Id);
26536 -- Normalize clause Clause by creating multiple clauses for each
26537 -- input item of Clause. It is assumed that Clause has exactly one
26538 -- output. The transformation is as follows:
26540 -- Output => (Input_1, Input_2) -- original
26542 -- Output => Input_1 -- normalizations
26543 -- Output => Input_2
26545 procedure Normalize_Outputs (Clause : Node_Id);
26546 -- Normalize clause Clause by creating multiple clause for each
26547 -- output item of Clause. The transformation is as follows:
26549 -- (Output_1, Output_2) => Input -- original
26551 -- Output_1 => Input -- normalization
26552 -- Output_2 => Input
26554 ----------------------
26555 -- Normalize_Inputs --
26556 ----------------------
26558 procedure Normalize_Inputs (Clause : Node_Id) is
26559 Inputs : constant Node_Id := Expression (Clause);
26560 Loc : constant Source_Ptr := Sloc (Clause);
26561 Output : constant List_Id := Choices (Clause);
26562 Last_Input : Node_Id;
26564 New_Clause : Node_Id;
26565 Next_Input : Node_Id;
26568 -- Normalization is performed only when the original clause has
26569 -- more than one input. Multiple inputs appear as an aggregate.
26571 if Nkind (Inputs) = N_Aggregate then
26572 Last_Input := Last (Expressions (Inputs));
26574 -- Create a new clause for each input
26576 Input := First (Expressions (Inputs));
26577 while Present (Input) loop
26578 Next_Input := Next (Input);
26580 -- Unhook the current input from the original input list
26581 -- because it will be relocated to a new clause.
26585 -- Special processing for the last input. At this point the
26586 -- original aggregate has been stripped down to one element.
26587 -- Replace the aggregate by the element itself.
26589 if Input = Last_Input then
26590 Rewrite (Inputs, Input);
26592 -- Generate a clause of the form:
26597 Make_Component_Association (Loc,
26598 Choices => New_Copy_List_Tree (Output),
26599 Expression => Input);
26601 -- The new clause contains replicated content that has
26602 -- already been analyzed, mark the clause as analyzed.
26604 Set_Analyzed (New_Clause);
26605 Insert_After (Clause, New_Clause);
26608 Input := Next_Input;
26611 end Normalize_Inputs;
26613 -----------------------
26614 -- Normalize_Outputs --
26615 -----------------------
26617 procedure Normalize_Outputs (Clause : Node_Id) is
26618 Inputs : constant Node_Id := Expression (Clause);
26619 Loc : constant Source_Ptr := Sloc (Clause);
26620 Outputs : constant Node_Id := First (Choices (Clause));
26621 Last_Output : Node_Id;
26622 New_Clause : Node_Id;
26623 Next_Output : Node_Id;
26627 -- Multiple outputs appear as an aggregate. Nothing to do when
26628 -- the clause has exactly one output.
26630 if Nkind (Outputs) = N_Aggregate then
26631 Last_Output := Last (Expressions (Outputs));
26633 -- Create a clause for each output. Note that each time a new
26634 -- clause is created, the original output list slowly shrinks
26635 -- until there is one item left.
26637 Output := First (Expressions (Outputs));
26638 while Present (Output) loop
26639 Next_Output := Next (Output);
26641 -- Unhook the output from the original output list as it
26642 -- will be relocated to a new clause.
26646 -- Special processing for the last output. At this point
26647 -- the original aggregate has been stripped down to one
26648 -- element. Replace the aggregate by the element itself.
26650 if Output = Last_Output then
26651 Rewrite (Outputs, Output);
26654 -- Generate a clause of the form:
26655 -- (Output => Inputs)
26658 Make_Component_Association (Loc,
26659 Choices => New_List (Output),
26660 Expression => New_Copy_Tree (Inputs));
26662 -- The new clause contains replicated content that has
26663 -- already been analyzed. There is not need to reanalyze
26666 Set_Analyzed (New_Clause);
26667 Insert_After (Clause, New_Clause);
26670 Output := Next_Output;
26673 end Normalize_Outputs;
26679 -- Start of processing for Normalize_Clauses
26682 Clause := First (Clauses);
26683 while Present (Clause) loop
26684 Normalize_Outputs (Clause);
26688 Clause := First (Clauses);
26689 while Present (Clause) loop
26690 Normalize_Inputs (Clause);
26693 end Normalize_Clauses;
26695 --------------------------
26696 -- Remove_Extra_Clauses --
26697 --------------------------
26699 procedure Remove_Extra_Clauses
26700 (Clauses : List_Id;
26701 Matched_Items : Elist_Id)
26705 Input_Id : Entity_Id;
26706 Next_Clause : Node_Id;
26708 State_Id : Entity_Id;
26711 Clause := First (Clauses);
26712 while Present (Clause) loop
26713 Next_Clause := Next (Clause);
26715 Input := Expression (Clause);
26716 Output := First (Choices (Clause));
26718 -- Recognize a clause of the form
26722 -- where Input is a constituent of a state which was already
26723 -- successfully matched. This clause must be removed because it
26724 -- simply indicates that some of the constituents of the state
26727 -- Refined_State => (State => (Constit_1, Constit_2))
26728 -- Depends => (Output => State)
26729 -- Refined_Depends => ((Output => Constit_1), -- State matched
26730 -- (null => Constit_2)) -- OK
26732 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26734 -- Handle abstract views generated for limited with clauses
26736 Input_Id := Available_View (Entity_Of (Input));
26738 -- The input must be a constituent of a state
26740 if Ekind (Input_Id) in
26741 E_Abstract_State | E_Constant | E_Variable
26742 and then Present (Encapsulating_State (Input_Id))
26744 State_Id := Encapsulating_State (Input_Id);
26746 -- The state must have a non-null visible refinement and be
26747 -- matched in a previous clause.
26749 if Has_Non_Null_Visible_Refinement (State_Id)
26750 and then Contains (Matched_Items, State_Id)
26756 -- Recognize a clause of the form
26760 -- where Output is an arbitrary item. This clause must be removed
26761 -- because a null input legitimately matches anything.
26763 elsif Nkind (Input) = N_Null then
26767 Clause := Next_Clause;
26769 end Remove_Extra_Clauses;
26771 --------------------------
26772 -- Report_Extra_Clauses --
26773 --------------------------
26775 procedure Report_Extra_Clauses (Clauses : List_Id) is
26779 -- Do not perform this check in an instance because it was already
26780 -- performed successfully in the generic template.
26782 if In_Instance then
26785 elsif Present (Clauses) then
26786 Clause := First (Clauses);
26787 while Present (Clause) loop
26789 ("unmatched or extra clause in dependence refinement",
26795 end Report_Extra_Clauses;
26799 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26800 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26801 Errors : constant Nat := Serious_Errors_Detected;
26808 Body_Inputs : Elist_Id := No_Elist;
26809 Body_Outputs : Elist_Id := No_Elist;
26810 -- The inputs and outputs of the subprogram body synthesized from pragma
26811 -- Refined_Depends.
26813 Dependencies : List_Id := No_List;
26815 -- The corresponding Depends pragma along with its clauses
26817 Matched_Items : Elist_Id := No_Elist;
26818 -- A list containing the entities of all successfully matched items
26819 -- found in pragma Depends.
26821 Refinements : List_Id := No_List;
26822 -- The clauses of pragma Refined_Depends
26824 Spec_Id : Entity_Id;
26825 -- The entity of the subprogram subject to pragma Refined_Depends
26827 Spec_Inputs : Elist_Id := No_Elist;
26828 Spec_Outputs : Elist_Id := No_Elist;
26829 -- The inputs and outputs of the subprogram spec synthesized from pragma
26832 States : Elist_Id := No_Elist;
26833 -- A list containing the entities of all states whose constituents
26834 -- appear in pragma Depends.
26836 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26839 -- Do not analyze the pragma multiple times
26841 if Is_Analyzed_Pragma (N) then
26845 Spec_Id := Unique_Defining_Entity (Body_Decl);
26847 -- Use the anonymous object as the proper spec when Refined_Depends
26848 -- applies to the body of a single task type. The object carries the
26849 -- proper Chars as well as all non-refined versions of pragmas.
26851 if Is_Single_Concurrent_Type (Spec_Id) then
26852 Spec_Id := Anonymous_Object (Spec_Id);
26855 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26857 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26858 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26860 if No (Depends) then
26862 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26863 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26867 Deps := Expression (Get_Argument (Depends, Spec_Id));
26869 -- A null dependency relation renders the refinement useless because it
26870 -- cannot possibly mention abstract states with visible refinement. Note
26871 -- that the inverse is not true as states may be refined to null
26872 -- (SPARK RM 7.2.5(2)).
26874 if Nkind (Deps) = N_Null then
26876 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
26877 & "depend on abstract state with visible refinement"), N, Spec_Id);
26881 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26882 -- This ensures that the categorization of all refined dependency items
26883 -- is consistent with their role.
26885 Analyze_Depends_In_Decl_Part (N);
26887 -- Do not match dependencies against refinements if Refined_Depends is
26888 -- illegal to avoid emitting misleading error.
26890 if Serious_Errors_Detected = Errors then
26892 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26893 -- the inputs and outputs of the subprogram spec and body to verify
26894 -- the use of states with visible refinement and their constituents.
26896 if No (Get_Pragma (Spec_Id, Pragma_Global))
26897 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
26899 Collect_Subprogram_Inputs_Outputs
26900 (Subp_Id => Spec_Id,
26901 Synthesize => True,
26902 Subp_Inputs => Spec_Inputs,
26903 Subp_Outputs => Spec_Outputs,
26904 Global_Seen => Dummy);
26906 Collect_Subprogram_Inputs_Outputs
26907 (Subp_Id => Body_Id,
26908 Synthesize => True,
26909 Subp_Inputs => Body_Inputs,
26910 Subp_Outputs => Body_Outputs,
26911 Global_Seen => Dummy);
26913 -- For an output state with a visible refinement, ensure that all
26914 -- constituents appear as outputs in the dependency refinement.
26916 Check_Output_States
26917 (Spec_Inputs => Spec_Inputs,
26918 Spec_Outputs => Spec_Outputs,
26919 Body_Inputs => Body_Inputs,
26920 Body_Outputs => Body_Outputs);
26923 -- Multiple dependency clauses appear as component associations of an
26924 -- aggregate. Note that the clauses are copied because the algorithm
26925 -- modifies them and this should not be visible in Depends.
26927 pragma Assert (Nkind (Deps) = N_Aggregate);
26928 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
26929 Normalize_Clauses (Dependencies);
26931 -- Gather all states which appear in Depends
26933 States := Collect_States (Dependencies);
26935 Refs := Expression (Get_Argument (N, Spec_Id));
26937 if Nkind (Refs) = N_Null then
26938 Refinements := No_List;
26940 -- Multiple dependency clauses appear as component associations of an
26941 -- aggregate. Note that the clauses are copied because the algorithm
26942 -- modifies them and this should not be visible in Refined_Depends.
26944 else pragma Assert (Nkind (Refs) = N_Aggregate);
26945 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
26946 Normalize_Clauses (Refinements);
26949 -- At this point the clauses of pragmas Depends and Refined_Depends
26950 -- have been normalized into simple dependencies between one output
26951 -- and one input. Examine all clauses of pragma Depends looking for
26952 -- matching clauses in pragma Refined_Depends.
26954 Clause := First (Dependencies);
26955 while Present (Clause) loop
26956 Check_Dependency_Clause
26957 (Spec_Id => Spec_Id,
26958 Dep_Clause => Clause,
26959 Dep_States => States,
26960 Refinements => Refinements,
26961 Matched_Items => Matched_Items);
26966 -- Pragma Refined_Depends may contain multiple clarification clauses
26967 -- which indicate that certain constituents do not influence the data
26968 -- flow in any way. Such clauses must be removed as long as the state
26969 -- has been matched, otherwise they will be incorrectly flagged as
26972 -- Refined_State => (State => (Constit_1, Constit_2))
26973 -- Depends => (Output => State)
26974 -- Refined_Depends => ((Output => Constit_1), -- State matched
26975 -- (null => Constit_2)) -- must be removed
26977 Remove_Extra_Clauses (Refinements, Matched_Items);
26979 if Serious_Errors_Detected = Errors then
26980 Report_Extra_Clauses (Refinements);
26985 Set_Is_Analyzed_Pragma (N);
26986 end Analyze_Refined_Depends_In_Decl_Part;
26988 -----------------------------------------
26989 -- Analyze_Refined_Global_In_Decl_Part --
26990 -----------------------------------------
26992 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
26994 -- The corresponding Global pragma
26996 Has_In_State : Boolean := False;
26997 Has_In_Out_State : Boolean := False;
26998 Has_Out_State : Boolean := False;
26999 Has_Proof_In_State : Boolean := False;
27000 -- These flags are set when the corresponding Global pragma has a state
27001 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27004 Has_Null_State : Boolean := False;
27005 -- This flag is set when the corresponding Global pragma has at least
27006 -- one state with a null refinement.
27008 In_Constits : Elist_Id := No_Elist;
27009 In_Out_Constits : Elist_Id := No_Elist;
27010 Out_Constits : Elist_Id := No_Elist;
27011 Proof_In_Constits : Elist_Id := No_Elist;
27012 -- These lists contain the entities of all Input, In_Out, Output and
27013 -- Proof_In constituents that appear in Refined_Global and participate
27014 -- in state refinement.
27016 In_Items : Elist_Id := No_Elist;
27017 In_Out_Items : Elist_Id := No_Elist;
27018 Out_Items : Elist_Id := No_Elist;
27019 Proof_In_Items : Elist_Id := No_Elist;
27020 -- These lists contain the entities of all Input, In_Out, Output and
27021 -- Proof_In items defined in the corresponding Global pragma.
27023 Repeat_Items : Elist_Id := No_Elist;
27024 -- A list of all global items without full visible refinement found
27025 -- in pragma Global. These states should be repeated in the global
27026 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27027 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27029 Spec_Id : Entity_Id;
27030 -- The entity of the subprogram subject to pragma Refined_Global
27032 States : Elist_Id := No_Elist;
27033 -- A list of all states with full or partial visible refinement found in
27036 procedure Check_In_Out_States;
27037 -- Determine whether the corresponding Global pragma mentions In_Out
27038 -- states with visible refinement and if so, ensure that one of the
27039 -- following completions apply to the constituents of the state:
27040 -- 1) there is at least one constituent of mode In_Out
27041 -- 2) there is at least one Input and one Output constituent
27042 -- 3) not all constituents are present and one of them is of mode
27044 -- This routine may remove elements from In_Constits, In_Out_Constits,
27045 -- Out_Constits and Proof_In_Constits.
27047 procedure Check_Input_States;
27048 -- Determine whether the corresponding Global pragma mentions Input
27049 -- states with visible refinement and if so, ensure that at least one of
27050 -- its constituents appears as an Input item in Refined_Global.
27051 -- This routine may remove elements from In_Constits, In_Out_Constits,
27052 -- Out_Constits and Proof_In_Constits.
27054 procedure Check_Output_States;
27055 -- Determine whether the corresponding Global pragma mentions Output
27056 -- states with visible refinement and if so, ensure that all of its
27057 -- constituents appear as Output items in Refined_Global.
27058 -- This routine may remove elements from In_Constits, In_Out_Constits,
27059 -- Out_Constits and Proof_In_Constits.
27061 procedure Check_Proof_In_States;
27062 -- Determine whether the corresponding Global pragma mentions Proof_In
27063 -- states with visible refinement and if so, ensure that at least one of
27064 -- its constituents appears as a Proof_In item in Refined_Global.
27065 -- This routine may remove elements from In_Constits, In_Out_Constits,
27066 -- Out_Constits and Proof_In_Constits.
27068 procedure Check_Refined_Global_List
27070 Global_Mode : Name_Id := Name_Input);
27071 -- Verify the legality of a single global list declaration. Global_Mode
27072 -- denotes the current mode in effect.
27074 procedure Collect_Global_Items
27076 Mode : Name_Id := Name_Input);
27077 -- Gather all Input, In_Out, Output and Proof_In items from node List
27078 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27079 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27080 -- and Has_Proof_In_State are set when there is at least one abstract
27081 -- state with full or partial visible refinement available in the
27082 -- corresponding mode. Flag Has_Null_State is set when at least state
27083 -- has a null refinement. Mode denotes the current global mode in
27086 function Present_Then_Remove
27088 Item : Entity_Id) return Boolean;
27089 -- Search List for a particular entity Item. If Item has been found,
27090 -- remove it from List. This routine is used to strip lists In_Constits,
27091 -- In_Out_Constits and Out_Constits of valid constituents.
27093 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27094 -- Same as function Present_Then_Remove, but do not report the presence
27095 -- of Item in List.
27097 procedure Report_Extra_Constituents;
27098 -- Emit an error for each constituent found in lists In_Constits,
27099 -- In_Out_Constits and Out_Constits.
27101 procedure Report_Missing_Items;
27102 -- Emit an error for each global item not repeated found in list
27105 -------------------------
27106 -- Check_In_Out_States --
27107 -------------------------
27109 procedure Check_In_Out_States is
27110 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27111 -- Determine whether one of the following coverage scenarios is in
27113 -- 1) there is at least one constituent of mode In_Out or Output
27114 -- 2) there is at least one pair of constituents with modes Input
27115 -- and Output, or Proof_In and Output.
27116 -- 3) there is at least one constituent of mode Output and not all
27117 -- constituents are present.
27118 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27120 -----------------------------
27121 -- Check_Constituent_Usage --
27122 -----------------------------
27124 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27125 Constits : constant Elist_Id :=
27126 Partial_Refinement_Constituents (State_Id);
27127 Constit_Elmt : Elmt_Id;
27128 Constit_Id : Entity_Id;
27129 Has_Missing : Boolean := False;
27130 In_Out_Seen : Boolean := False;
27131 Input_Seen : Boolean := False;
27132 Output_Seen : Boolean := False;
27133 Proof_In_Seen : Boolean := False;
27136 -- Process all the constituents of the state and note their modes
27137 -- within the global refinement.
27139 if Present (Constits) then
27140 Constit_Elmt := First_Elmt (Constits);
27141 while Present (Constit_Elmt) loop
27142 Constit_Id := Node (Constit_Elmt);
27144 if Present_Then_Remove (In_Constits, Constit_Id) then
27145 Input_Seen := True;
27147 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27148 In_Out_Seen := True;
27150 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27151 Output_Seen := True;
27153 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27155 Proof_In_Seen := True;
27158 Has_Missing := True;
27161 Next_Elmt (Constit_Elmt);
27165 -- An In_Out constituent is a valid completion
27167 if In_Out_Seen then
27170 -- A pair of one Input/Proof_In and one Output constituent is a
27171 -- valid completion.
27173 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27176 elsif Output_Seen then
27178 -- A single Output constituent is a valid completion only when
27179 -- some of the other constituents are missing.
27181 if Has_Missing then
27184 -- Otherwise all constituents are of mode Output
27188 ("global refinement of state & must include at least one "
27189 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27193 -- The state lacks a completion. When full refinement is visible,
27194 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27195 -- refinement is visible, emit an error if the abstract state
27196 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27197 -- both are utilized, Check_State_And_Constituent_Use. will issue
27200 elsif not Input_Seen
27201 and then not In_Out_Seen
27202 and then not Output_Seen
27203 and then not Proof_In_Seen
27205 if Has_Visible_Refinement (State_Id)
27206 or else Contains (Repeat_Items, State_Id)
27209 ("missing global refinement of state &", N, State_Id);
27212 -- Otherwise the state has a malformed completion where at least
27213 -- one of the constituents has a different mode.
27217 ("global refinement of state & redefines the mode of its "
27218 & "constituents", N, State_Id);
27220 end Check_Constituent_Usage;
27224 Item_Elmt : Elmt_Id;
27225 Item_Id : Entity_Id;
27227 -- Start of processing for Check_In_Out_States
27230 -- Do not perform this check in an instance because it was already
27231 -- performed successfully in the generic template.
27233 if In_Instance then
27236 -- Inspect the In_Out items of the corresponding Global pragma
27237 -- looking for a state with a visible refinement.
27239 elsif Has_In_Out_State and then Present (In_Out_Items) then
27240 Item_Elmt := First_Elmt (In_Out_Items);
27241 while Present (Item_Elmt) loop
27242 Item_Id := Node (Item_Elmt);
27244 -- Ensure that one of the three coverage variants is satisfied
27246 if Ekind (Item_Id) = E_Abstract_State
27247 and then Has_Non_Null_Visible_Refinement (Item_Id)
27249 Check_Constituent_Usage (Item_Id);
27252 Next_Elmt (Item_Elmt);
27255 end Check_In_Out_States;
27257 ------------------------
27258 -- Check_Input_States --
27259 ------------------------
27261 procedure Check_Input_States is
27262 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27263 -- Determine whether at least one constituent of state State_Id with
27264 -- full or partial visible refinement is used and has mode Input.
27265 -- Ensure that the remaining constituents do not have In_Out or
27266 -- Output modes. Emit an error if this is not the case
27267 -- (SPARK RM 7.2.4(5)).
27269 -----------------------------
27270 -- Check_Constituent_Usage --
27271 -----------------------------
27273 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27274 Constits : constant Elist_Id :=
27275 Partial_Refinement_Constituents (State_Id);
27276 Constit_Elmt : Elmt_Id;
27277 Constit_Id : Entity_Id;
27278 In_Seen : Boolean := False;
27281 if Present (Constits) then
27282 Constit_Elmt := First_Elmt (Constits);
27283 while Present (Constit_Elmt) loop
27284 Constit_Id := Node (Constit_Elmt);
27286 -- At least one of the constituents appears as an Input
27288 if Present_Then_Remove (In_Constits, Constit_Id) then
27291 -- A Proof_In constituent can refine an Input state as long
27292 -- as there is at least one Input constituent present.
27294 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27298 -- The constituent appears in the global refinement, but has
27299 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27301 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27302 or else Present_Then_Remove (Out_Constits, Constit_Id)
27304 Error_Msg_Name_1 := Chars (State_Id);
27306 ("constituent & of state % must have mode `Input` in "
27307 & "global refinement", N, Constit_Id);
27310 Next_Elmt (Constit_Elmt);
27314 -- Not one of the constituents appeared as Input. Always emit an
27315 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27316 -- When only partial refinement is visible, emit an error if the
27317 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27318 -- the case where both are utilized, an error will be issued in
27319 -- Check_State_And_Constituent_Use.
27322 and then (Has_Visible_Refinement (State_Id)
27323 or else Contains (Repeat_Items, State_Id))
27326 ("global refinement of state & must include at least one "
27327 & "constituent of mode `Input`", N, State_Id);
27329 end Check_Constituent_Usage;
27333 Item_Elmt : Elmt_Id;
27334 Item_Id : Entity_Id;
27336 -- Start of processing for Check_Input_States
27339 -- Do not perform this check in an instance because it was already
27340 -- performed successfully in the generic template.
27342 if In_Instance then
27345 -- Inspect the Input items of the corresponding Global pragma looking
27346 -- for a state with a visible refinement.
27348 elsif Has_In_State and then Present (In_Items) then
27349 Item_Elmt := First_Elmt (In_Items);
27350 while Present (Item_Elmt) loop
27351 Item_Id := Node (Item_Elmt);
27353 -- When full refinement is visible, ensure that at least one of
27354 -- the constituents is utilized and is of mode Input. When only
27355 -- partial refinement is visible, ensure that either one of
27356 -- the constituents is utilized and is of mode Input, or the
27357 -- abstract state is repeated and no constituent is utilized.
27359 if Ekind (Item_Id) = E_Abstract_State
27360 and then Has_Non_Null_Visible_Refinement (Item_Id)
27362 Check_Constituent_Usage (Item_Id);
27365 Next_Elmt (Item_Elmt);
27368 end Check_Input_States;
27370 -------------------------
27371 -- Check_Output_States --
27372 -------------------------
27374 procedure Check_Output_States is
27375 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27376 -- Determine whether all constituents of state State_Id with full
27377 -- visible refinement are used and have mode Output. Emit an error
27378 -- if this is not the case (SPARK RM 7.2.4(5)).
27380 -----------------------------
27381 -- Check_Constituent_Usage --
27382 -----------------------------
27384 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27385 Constits : constant Elist_Id :=
27386 Partial_Refinement_Constituents (State_Id);
27387 Only_Partial : constant Boolean :=
27388 not Has_Visible_Refinement (State_Id);
27389 Constit_Elmt : Elmt_Id;
27390 Constit_Id : Entity_Id;
27391 Posted : Boolean := False;
27394 if Present (Constits) then
27395 Constit_Elmt := First_Elmt (Constits);
27396 while Present (Constit_Elmt) loop
27397 Constit_Id := Node (Constit_Elmt);
27399 -- Issue an error when a constituent of State_Id is utilized
27400 -- and State_Id has only partial visible refinement
27401 -- (SPARK RM 7.2.4(3d)).
27403 if Only_Partial then
27404 if Present_Then_Remove (Out_Constits, Constit_Id)
27405 or else Present_Then_Remove (In_Constits, Constit_Id)
27407 Present_Then_Remove (In_Out_Constits, Constit_Id)
27409 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27411 Error_Msg_Name_1 := Chars (State_Id);
27413 ("constituent & of state % cannot be used in global "
27414 & "refinement", N, Constit_Id);
27415 Error_Msg_Name_1 := Chars (State_Id);
27416 SPARK_Msg_N ("\use state % instead", N);
27419 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27422 -- The constituent appears in the global refinement, but has
27423 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27425 elsif Present_Then_Remove (In_Constits, Constit_Id)
27426 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27427 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27429 Error_Msg_Name_1 := Chars (State_Id);
27431 ("constituent & of state % must have mode `Output` in "
27432 & "global refinement", N, Constit_Id);
27434 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27440 ("`Output` state & must be replaced by all its "
27441 & "constituents in global refinement", N, State_Id);
27445 ("\constituent & is missing in output list",
27449 Next_Elmt (Constit_Elmt);
27452 end Check_Constituent_Usage;
27456 Item_Elmt : Elmt_Id;
27457 Item_Id : Entity_Id;
27459 -- Start of processing for Check_Output_States
27462 -- Do not perform this check in an instance because it was already
27463 -- performed successfully in the generic template.
27465 if In_Instance then
27468 -- Inspect the Output items of the corresponding Global pragma
27469 -- looking for a state with a visible refinement.
27471 elsif Has_Out_State and then Present (Out_Items) then
27472 Item_Elmt := First_Elmt (Out_Items);
27473 while Present (Item_Elmt) loop
27474 Item_Id := Node (Item_Elmt);
27476 -- When full refinement is visible, ensure that all of the
27477 -- constituents are utilized and they have mode Output. When
27478 -- only partial refinement is visible, ensure that no
27479 -- constituent is utilized.
27481 if Ekind (Item_Id) = E_Abstract_State
27482 and then Has_Non_Null_Visible_Refinement (Item_Id)
27484 Check_Constituent_Usage (Item_Id);
27487 Next_Elmt (Item_Elmt);
27490 end Check_Output_States;
27492 ---------------------------
27493 -- Check_Proof_In_States --
27494 ---------------------------
27496 procedure Check_Proof_In_States is
27497 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27498 -- Determine whether at least one constituent of state State_Id with
27499 -- full or partial visible refinement is used and has mode Proof_In.
27500 -- Ensure that the remaining constituents do not have Input, In_Out,
27501 -- or Output modes. Emit an error if this is not the case
27502 -- (SPARK RM 7.2.4(5)).
27504 -----------------------------
27505 -- Check_Constituent_Usage --
27506 -----------------------------
27508 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27509 Constits : constant Elist_Id :=
27510 Partial_Refinement_Constituents (State_Id);
27511 Constit_Elmt : Elmt_Id;
27512 Constit_Id : Entity_Id;
27513 Proof_In_Seen : Boolean := False;
27516 if Present (Constits) then
27517 Constit_Elmt := First_Elmt (Constits);
27518 while Present (Constit_Elmt) loop
27519 Constit_Id := Node (Constit_Elmt);
27521 -- At least one of the constituents appears as Proof_In
27523 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27524 Proof_In_Seen := True;
27526 -- The constituent appears in the global refinement, but has
27527 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27529 elsif Present_Then_Remove (In_Constits, Constit_Id)
27530 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27531 or else Present_Then_Remove (Out_Constits, Constit_Id)
27533 Error_Msg_Name_1 := Chars (State_Id);
27535 ("constituent & of state % must have mode `Proof_In` "
27536 & "in global refinement", N, Constit_Id);
27539 Next_Elmt (Constit_Elmt);
27543 -- Not one of the constituents appeared as Proof_In. Always emit
27544 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27545 -- When only partial refinement is visible, emit an error if the
27546 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27547 -- the case where both are utilized, an error will be issued by
27548 -- Check_State_And_Constituent_Use.
27550 if not Proof_In_Seen
27551 and then (Has_Visible_Refinement (State_Id)
27552 or else Contains (Repeat_Items, State_Id))
27555 ("global refinement of state & must include at least one "
27556 & "constituent of mode `Proof_In`", N, State_Id);
27558 end Check_Constituent_Usage;
27562 Item_Elmt : Elmt_Id;
27563 Item_Id : Entity_Id;
27565 -- Start of processing for Check_Proof_In_States
27568 -- Do not perform this check in an instance because it was already
27569 -- performed successfully in the generic template.
27571 if In_Instance then
27574 -- Inspect the Proof_In items of the corresponding Global pragma
27575 -- looking for a state with a visible refinement.
27577 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27578 Item_Elmt := First_Elmt (Proof_In_Items);
27579 while Present (Item_Elmt) loop
27580 Item_Id := Node (Item_Elmt);
27582 -- Ensure that at least one of the constituents is utilized
27583 -- and is of mode Proof_In. When only partial refinement is
27584 -- visible, ensure that either one of the constituents is
27585 -- utilized and is of mode Proof_In, or the abstract state
27586 -- is repeated and no constituent is utilized.
27588 if Ekind (Item_Id) = E_Abstract_State
27589 and then Has_Non_Null_Visible_Refinement (Item_Id)
27591 Check_Constituent_Usage (Item_Id);
27594 Next_Elmt (Item_Elmt);
27597 end Check_Proof_In_States;
27599 -------------------------------
27600 -- Check_Refined_Global_List --
27601 -------------------------------
27603 procedure Check_Refined_Global_List
27605 Global_Mode : Name_Id := Name_Input)
27607 procedure Check_Refined_Global_Item
27609 Global_Mode : Name_Id);
27610 -- Verify the legality of a single global item declaration. Parameter
27611 -- Global_Mode denotes the current mode in effect.
27613 -------------------------------
27614 -- Check_Refined_Global_Item --
27615 -------------------------------
27617 procedure Check_Refined_Global_Item
27619 Global_Mode : Name_Id)
27621 Item_Id : constant Entity_Id := Entity_Of (Item);
27623 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27624 -- Issue a common error message for all mode mismatches. Expect
27625 -- denotes the expected mode.
27627 -----------------------------
27628 -- Inconsistent_Mode_Error --
27629 -----------------------------
27631 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27634 ("global item & has inconsistent modes", Item, Item_Id);
27636 Error_Msg_Name_1 := Global_Mode;
27637 Error_Msg_Name_2 := Expect;
27638 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27639 end Inconsistent_Mode_Error;
27643 Enc_State : Entity_Id := Empty;
27644 -- Encapsulating state for constituent, Empty otherwise
27646 -- Start of processing for Check_Refined_Global_Item
27649 if Ekind (Item_Id) in E_Abstract_State | E_Constant | E_Variable
27651 Enc_State := Find_Encapsulating_State (States, Item_Id);
27654 -- When the state or object acts as a constituent of another
27655 -- state with a visible refinement, collect it for the state
27656 -- completeness checks performed later on. Note that the item
27657 -- acts as a constituent only when the encapsulating state is
27658 -- present in pragma Global.
27660 if Present (Enc_State)
27661 and then (Has_Visible_Refinement (Enc_State)
27662 or else Has_Partial_Visible_Refinement (Enc_State))
27663 and then Contains (States, Enc_State)
27665 -- If the state has only partial visible refinement, remove it
27666 -- from the list of items that should be repeated from pragma
27669 if not Has_Visible_Refinement (Enc_State) then
27670 Present_Then_Remove (Repeat_Items, Enc_State);
27673 if Global_Mode = Name_Input then
27674 Append_New_Elmt (Item_Id, In_Constits);
27676 elsif Global_Mode = Name_In_Out then
27677 Append_New_Elmt (Item_Id, In_Out_Constits);
27679 elsif Global_Mode = Name_Output then
27680 Append_New_Elmt (Item_Id, Out_Constits);
27682 elsif Global_Mode = Name_Proof_In then
27683 Append_New_Elmt (Item_Id, Proof_In_Constits);
27686 -- When not a constituent, ensure that both occurrences of the
27687 -- item in pragmas Global and Refined_Global match. Also remove
27688 -- it when present from the list of items that should be repeated
27689 -- from pragma Global.
27692 Present_Then_Remove (Repeat_Items, Item_Id);
27694 if Contains (In_Items, Item_Id) then
27695 if Global_Mode /= Name_Input then
27696 Inconsistent_Mode_Error (Name_Input);
27699 elsif Contains (In_Out_Items, Item_Id) then
27700 if Global_Mode /= Name_In_Out then
27701 Inconsistent_Mode_Error (Name_In_Out);
27704 elsif Contains (Out_Items, Item_Id) then
27705 if Global_Mode /= Name_Output then
27706 Inconsistent_Mode_Error (Name_Output);
27709 elsif Contains (Proof_In_Items, Item_Id) then
27712 -- The item does not appear in the corresponding Global pragma,
27713 -- it must be an extra (SPARK RM 7.2.4(3)).
27716 pragma Assert (Present (Global));
27717 Error_Msg_Sloc := Sloc (Global);
27719 ("extra global item & does not refine or repeat any "
27720 & "global item #", Item, Item_Id);
27723 end Check_Refined_Global_Item;
27729 -- Start of processing for Check_Refined_Global_List
27732 -- Do not perform this check in an instance because it was already
27733 -- performed successfully in the generic template.
27735 if In_Instance then
27738 elsif Nkind (List) = N_Null then
27741 -- Single global item declaration
27743 elsif Nkind (List) in N_Expanded_Name
27745 | N_Selected_Component
27747 Check_Refined_Global_Item (List, Global_Mode);
27749 -- Simple global list or moded global list declaration
27751 elsif Nkind (List) = N_Aggregate then
27753 -- The declaration of a simple global list appear as a collection
27756 if Present (Expressions (List)) then
27757 Item := First (Expressions (List));
27758 while Present (Item) loop
27759 Check_Refined_Global_Item (Item, Global_Mode);
27763 -- The declaration of a moded global list appears as a collection
27764 -- of component associations where individual choices denote
27767 elsif Present (Component_Associations (List)) then
27768 Item := First (Component_Associations (List));
27769 while Present (Item) loop
27770 Check_Refined_Global_List
27771 (List => Expression (Item),
27772 Global_Mode => Chars (First (Choices (Item))));
27780 raise Program_Error;
27786 raise Program_Error;
27788 end Check_Refined_Global_List;
27790 --------------------------
27791 -- Collect_Global_Items --
27792 --------------------------
27794 procedure Collect_Global_Items
27796 Mode : Name_Id := Name_Input)
27798 procedure Collect_Global_Item
27800 Item_Mode : Name_Id);
27801 -- Add a single item to the appropriate list. Item_Mode denotes the
27802 -- current mode in effect.
27804 -------------------------
27805 -- Collect_Global_Item --
27806 -------------------------
27808 procedure Collect_Global_Item
27810 Item_Mode : Name_Id)
27812 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27813 -- The above handles abstract views of variables and states built
27814 -- for limited with clauses.
27817 -- Signal that the global list contains at least one abstract
27818 -- state with a visible refinement. Note that the refinement may
27819 -- be null in which case there are no constituents.
27821 if Ekind (Item_Id) = E_Abstract_State then
27822 if Has_Null_Visible_Refinement (Item_Id) then
27823 Has_Null_State := True;
27825 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27826 Append_New_Elmt (Item_Id, States);
27828 if Item_Mode = Name_Input then
27829 Has_In_State := True;
27830 elsif Item_Mode = Name_In_Out then
27831 Has_In_Out_State := True;
27832 elsif Item_Mode = Name_Output then
27833 Has_Out_State := True;
27834 elsif Item_Mode = Name_Proof_In then
27835 Has_Proof_In_State := True;
27840 -- Record global items without full visible refinement found in
27841 -- pragma Global which should be repeated in the global refinement
27842 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27844 if Ekind (Item_Id) /= E_Abstract_State
27845 or else not Has_Visible_Refinement (Item_Id)
27847 Append_New_Elmt (Item_Id, Repeat_Items);
27850 -- Add the item to the proper list
27852 if Item_Mode = Name_Input then
27853 Append_New_Elmt (Item_Id, In_Items);
27854 elsif Item_Mode = Name_In_Out then
27855 Append_New_Elmt (Item_Id, In_Out_Items);
27856 elsif Item_Mode = Name_Output then
27857 Append_New_Elmt (Item_Id, Out_Items);
27858 elsif Item_Mode = Name_Proof_In then
27859 Append_New_Elmt (Item_Id, Proof_In_Items);
27861 end Collect_Global_Item;
27867 -- Start of processing for Collect_Global_Items
27870 if Nkind (List) = N_Null then
27873 -- Single global item declaration
27875 elsif Nkind (List) in N_Expanded_Name
27877 | N_Selected_Component
27879 Collect_Global_Item (List, Mode);
27881 -- Single global list or moded global list declaration
27883 elsif Nkind (List) = N_Aggregate then
27885 -- The declaration of a simple global list appear as a collection
27888 if Present (Expressions (List)) then
27889 Item := First (Expressions (List));
27890 while Present (Item) loop
27891 Collect_Global_Item (Item, Mode);
27895 -- The declaration of a moded global list appears as a collection
27896 -- of component associations where individual choices denote mode.
27898 elsif Present (Component_Associations (List)) then
27899 Item := First (Component_Associations (List));
27900 while Present (Item) loop
27901 Collect_Global_Items
27902 (List => Expression (Item),
27903 Mode => Chars (First (Choices (Item))));
27911 raise Program_Error;
27914 -- To accommodate partial decoration of disabled SPARK features, this
27915 -- routine may be called with illegal input. If this is the case, do
27916 -- not raise Program_Error.
27921 end Collect_Global_Items;
27923 -------------------------
27924 -- Present_Then_Remove --
27925 -------------------------
27927 function Present_Then_Remove
27929 Item : Entity_Id) return Boolean
27934 if Present (List) then
27935 Elmt := First_Elmt (List);
27936 while Present (Elmt) loop
27937 if Node (Elmt) = Item then
27938 Remove_Elmt (List, Elmt);
27947 end Present_Then_Remove;
27949 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
27952 Ignore := Present_Then_Remove (List, Item);
27953 end Present_Then_Remove;
27955 -------------------------------
27956 -- Report_Extra_Constituents --
27957 -------------------------------
27959 procedure Report_Extra_Constituents is
27960 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
27961 -- Emit an error for every element of List
27963 ---------------------------------------
27964 -- Report_Extra_Constituents_In_List --
27965 ---------------------------------------
27967 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
27968 Constit_Elmt : Elmt_Id;
27971 if Present (List) then
27972 Constit_Elmt := First_Elmt (List);
27973 while Present (Constit_Elmt) loop
27974 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
27975 Next_Elmt (Constit_Elmt);
27978 end Report_Extra_Constituents_In_List;
27980 -- Start of processing for Report_Extra_Constituents
27983 -- Do not perform this check in an instance because it was already
27984 -- performed successfully in the generic template.
27986 if In_Instance then
27990 Report_Extra_Constituents_In_List (In_Constits);
27991 Report_Extra_Constituents_In_List (In_Out_Constits);
27992 Report_Extra_Constituents_In_List (Out_Constits);
27993 Report_Extra_Constituents_In_List (Proof_In_Constits);
27995 end Report_Extra_Constituents;
27997 --------------------------
27998 -- Report_Missing_Items --
27999 --------------------------
28001 procedure Report_Missing_Items is
28002 Item_Elmt : Elmt_Id;
28003 Item_Id : Entity_Id;
28006 -- Do not perform this check in an instance because it was already
28007 -- performed successfully in the generic template.
28009 if In_Instance then
28013 if Present (Repeat_Items) then
28014 Item_Elmt := First_Elmt (Repeat_Items);
28015 while Present (Item_Elmt) loop
28016 Item_Id := Node (Item_Elmt);
28017 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28018 Next_Elmt (Item_Elmt);
28022 end Report_Missing_Items;
28026 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28027 Errors : constant Nat := Serious_Errors_Detected;
28029 No_Constit : Boolean;
28031 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28034 -- Do not analyze the pragma multiple times
28036 if Is_Analyzed_Pragma (N) then
28040 Spec_Id := Unique_Defining_Entity (Body_Decl);
28042 -- Use the anonymous object as the proper spec when Refined_Global
28043 -- applies to the body of a single task type. The object carries the
28044 -- proper Chars as well as all non-refined versions of pragmas.
28046 if Is_Single_Concurrent_Type (Spec_Id) then
28047 Spec_Id := Anonymous_Object (Spec_Id);
28050 Global := Get_Pragma (Spec_Id, Pragma_Global);
28051 Items := Expression (Get_Argument (N, Spec_Id));
28053 -- The subprogram declaration lacks pragma Global. This renders
28054 -- Refined_Global useless as there is nothing to refine.
28056 if No (Global) then
28058 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28059 & "& lacks aspect or pragma Global"), N, Spec_Id);
28063 -- Extract all relevant items from the corresponding Global pragma
28065 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28067 -- Package and subprogram bodies are instantiated individually in
28068 -- a separate compiler pass. Due to this mode of instantiation, the
28069 -- refinement of a state may no longer be visible when a subprogram
28070 -- body contract is instantiated. Since the generic template is legal,
28071 -- do not perform this check in the instance to circumvent this oddity.
28073 if In_Instance then
28076 -- Non-instance case
28079 -- The corresponding Global pragma must mention at least one
28080 -- state with a visible refinement at the point Refined_Global
28081 -- is processed. States with null refinements need Refined_Global
28082 -- pragma (SPARK RM 7.2.4(2)).
28084 if not Has_In_State
28085 and then not Has_In_Out_State
28086 and then not Has_Out_State
28087 and then not Has_Proof_In_State
28088 and then not Has_Null_State
28091 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28092 & "depend on abstract state with visible refinement"),
28096 -- The global refinement of inputs and outputs cannot be null when
28097 -- the corresponding Global pragma contains at least one item except
28098 -- in the case where we have states with null refinements.
28100 elsif Nkind (Items) = N_Null
28102 (Present (In_Items)
28103 or else Present (In_Out_Items)
28104 or else Present (Out_Items)
28105 or else Present (Proof_In_Items))
28106 and then not Has_Null_State
28109 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28110 & "global items"), N, Spec_Id);
28115 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28116 -- This ensures that the categorization of all refined global items is
28117 -- consistent with their role.
28119 Analyze_Global_In_Decl_Part (N);
28121 -- Perform all refinement checks with respect to completeness and mode
28124 if Serious_Errors_Detected = Errors then
28125 Check_Refined_Global_List (Items);
28128 -- Store the information that no constituent is used in the global
28129 -- refinement, prior to calling checking procedures which remove items
28130 -- from the list of constituents.
28134 and then No (In_Out_Constits)
28135 and then No (Out_Constits)
28136 and then No (Proof_In_Constits);
28138 -- For Input states with visible refinement, at least one constituent
28139 -- must be used as an Input in the global refinement.
28141 if Serious_Errors_Detected = Errors then
28142 Check_Input_States;
28145 -- Verify all possible completion variants for In_Out states with
28146 -- visible refinement.
28148 if Serious_Errors_Detected = Errors then
28149 Check_In_Out_States;
28152 -- For Output states with visible refinement, all constituents must be
28153 -- used as Outputs in the global refinement.
28155 if Serious_Errors_Detected = Errors then
28156 Check_Output_States;
28159 -- For Proof_In states with visible refinement, at least one constituent
28160 -- must be used as Proof_In in the global refinement.
28162 if Serious_Errors_Detected = Errors then
28163 Check_Proof_In_States;
28166 -- Emit errors for all constituents that belong to other states with
28167 -- visible refinement that do not appear in Global.
28169 if Serious_Errors_Detected = Errors then
28170 Report_Extra_Constituents;
28173 -- Emit errors for all items in Global that are not repeated in the
28174 -- global refinement and for which there is no full visible refinement
28175 -- and, in the case of states with partial visible refinement, no
28176 -- constituent is mentioned in the global refinement.
28178 if Serious_Errors_Detected = Errors then
28179 Report_Missing_Items;
28182 -- Emit an error if no constituent is used in the global refinement
28183 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28184 -- one may be issued by the checking procedures. Do not perform this
28185 -- check in an instance because it was already performed successfully
28186 -- in the generic template.
28188 if Serious_Errors_Detected = Errors
28189 and then not In_Instance
28190 and then not Has_Null_State
28191 and then No_Constit
28193 SPARK_Msg_N ("missing refinement", N);
28197 Set_Is_Analyzed_Pragma (N);
28198 end Analyze_Refined_Global_In_Decl_Part;
28200 ----------------------------------------
28201 -- Analyze_Refined_State_In_Decl_Part --
28202 ----------------------------------------
28204 procedure Analyze_Refined_State_In_Decl_Part
28206 Freeze_Id : Entity_Id := Empty)
28208 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28209 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28210 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28212 Available_States : Elist_Id := No_Elist;
28213 -- A list of all abstract states defined in the package declaration that
28214 -- are available for refinement. The list is used to report unrefined
28217 Body_States : Elist_Id := No_Elist;
28218 -- A list of all hidden states that appear in the body of the related
28219 -- package. The list is used to report unused hidden states.
28221 Constituents_Seen : Elist_Id := No_Elist;
28222 -- A list that contains all constituents processed so far. The list is
28223 -- used to detect multiple uses of the same constituent.
28225 Freeze_Posted : Boolean := False;
28226 -- A flag that controls the output of a freezing-related error (see use
28229 Refined_States_Seen : Elist_Id := No_Elist;
28230 -- A list that contains all refined states processed so far. The list is
28231 -- used to detect duplicate refinements.
28233 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28234 -- Perform full analysis of a single refinement clause
28236 procedure Report_Unrefined_States (States : Elist_Id);
28237 -- Emit errors for all unrefined abstract states found in list States
28239 -------------------------------
28240 -- Analyze_Refinement_Clause --
28241 -------------------------------
28243 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28244 AR_Constit : Entity_Id := Empty;
28245 AW_Constit : Entity_Id := Empty;
28246 ER_Constit : Entity_Id := Empty;
28247 EW_Constit : Entity_Id := Empty;
28248 -- The entities of external constituents that contain one of the
28249 -- following enabled properties: Async_Readers, Async_Writers,
28250 -- Effective_Reads and Effective_Writes.
28252 External_Constit_Seen : Boolean := False;
28253 -- Flag used to mark when at least one external constituent is part
28254 -- of the state refinement.
28256 Non_Null_Seen : Boolean := False;
28257 Null_Seen : Boolean := False;
28258 -- Flags used to detect multiple uses of null in a single clause or a
28259 -- mixture of null and non-null constituents.
28261 Part_Of_Constits : Elist_Id := No_Elist;
28262 -- A list of all candidate constituents subject to indicator Part_Of
28263 -- where the encapsulating state is the current state.
28266 State_Id : Entity_Id;
28267 -- The current state being refined
28269 procedure Analyze_Constituent (Constit : Node_Id);
28270 -- Perform full analysis of a single constituent
28272 procedure Check_External_Property
28273 (Prop_Nam : Name_Id;
28275 Constit : Entity_Id);
28276 -- Determine whether a property denoted by name Prop_Nam is present
28277 -- in the refined state. Emit an error if this is not the case. Flag
28278 -- Enabled should be set when the property applies to the refined
28279 -- state. Constit denotes the constituent (if any) which introduces
28280 -- the property in the refinement.
28282 procedure Match_State;
28283 -- Determine whether the state being refined appears in list
28284 -- Available_States. Emit an error when attempting to re-refine the
28285 -- state or when the state is not defined in the package declaration,
28286 -- otherwise remove the state from Available_States.
28288 procedure Report_Unused_Constituents (Constits : Elist_Id);
28289 -- Emit errors for all unused Part_Of constituents in list Constits
28291 -------------------------
28292 -- Analyze_Constituent --
28293 -------------------------
28295 procedure Analyze_Constituent (Constit : Node_Id) is
28296 procedure Match_Constituent (Constit_Id : Entity_Id);
28297 -- Determine whether constituent Constit denoted by its entity
28298 -- Constit_Id appears in Body_States. Emit an error when the
28299 -- constituent is not a valid hidden state of the related package
28300 -- or when it is used more than once. Otherwise remove the
28301 -- constituent from Body_States.
28303 -----------------------
28304 -- Match_Constituent --
28305 -----------------------
28307 procedure Match_Constituent (Constit_Id : Entity_Id) is
28308 procedure Collect_Constituent;
28309 -- Verify the legality of constituent Constit_Id and add it to
28310 -- the refinements of State_Id.
28312 -------------------------
28313 -- Collect_Constituent --
28314 -------------------------
28316 procedure Collect_Constituent is
28317 Constits : Elist_Id;
28320 -- The Ghost policy in effect at the point of abstract state
28321 -- declaration and constituent must match (SPARK RM 6.9(15))
28323 Check_Ghost_Refinement
28324 (State, State_Id, Constit, Constit_Id);
28326 -- A synchronized state must be refined by a synchronized
28327 -- object or another synchronized state (SPARK RM 9.6).
28329 if Is_Synchronized_State (State_Id)
28330 and then not Is_Synchronized_Object (Constit_Id)
28331 and then not Is_Synchronized_State (Constit_Id)
28334 ("constituent of synchronized state & must be "
28335 & "synchronized", Constit, State_Id);
28338 -- Add the constituent to the list of processed items to aid
28339 -- with the detection of duplicates.
28341 Append_New_Elmt (Constit_Id, Constituents_Seen);
28343 -- Collect the constituent in the list of refinement items
28344 -- and establish a relation between the refined state and
28347 Constits := Refinement_Constituents (State_Id);
28349 if No (Constits) then
28350 Constits := New_Elmt_List;
28351 Set_Refinement_Constituents (State_Id, Constits);
28354 Append_Elmt (Constit_Id, Constits);
28355 Set_Encapsulating_State (Constit_Id, State_Id);
28357 -- The state has at least one legal constituent, mark the
28358 -- start of the refinement region. The region ends when the
28359 -- body declarations end (see routine Analyze_Declarations).
28361 Set_Has_Visible_Refinement (State_Id);
28363 -- When the constituent is external, save its relevant
28364 -- property for further checks.
28366 if Async_Readers_Enabled (Constit_Id) then
28367 AR_Constit := Constit_Id;
28368 External_Constit_Seen := True;
28371 if Async_Writers_Enabled (Constit_Id) then
28372 AW_Constit := Constit_Id;
28373 External_Constit_Seen := True;
28376 if Effective_Reads_Enabled (Constit_Id) then
28377 ER_Constit := Constit_Id;
28378 External_Constit_Seen := True;
28381 if Effective_Writes_Enabled (Constit_Id) then
28382 EW_Constit := Constit_Id;
28383 External_Constit_Seen := True;
28385 end Collect_Constituent;
28389 State_Elmt : Elmt_Id;
28391 -- Start of processing for Match_Constituent
28394 -- Detect a duplicate use of a constituent
28396 if Contains (Constituents_Seen, Constit_Id) then
28398 ("duplicate use of constituent &", Constit, Constit_Id);
28402 -- The constituent is subject to a Part_Of indicator
28404 if Present (Encapsulating_State (Constit_Id)) then
28405 if Encapsulating_State (Constit_Id) = State_Id then
28406 Remove (Part_Of_Constits, Constit_Id);
28407 Collect_Constituent;
28409 -- The constituent is part of another state and is used
28410 -- incorrectly in the refinement of the current state.
28413 Error_Msg_Name_1 := Chars (State_Id);
28415 ("& cannot act as constituent of state %",
28416 Constit, Constit_Id);
28418 ("\Part_Of indicator specifies encapsulator &",
28419 Constit, Encapsulating_State (Constit_Id));
28422 -- The only other source of legal constituents is the body
28423 -- state space of the related package.
28426 if Present (Body_States) then
28427 State_Elmt := First_Elmt (Body_States);
28428 while Present (State_Elmt) loop
28430 -- Consume a valid constituent to signal that it has
28431 -- been encountered.
28433 if Node (State_Elmt) = Constit_Id then
28434 Remove_Elmt (Body_States, State_Elmt);
28435 Collect_Constituent;
28439 Next_Elmt (State_Elmt);
28443 -- At this point it is known that the constituent is not
28444 -- part of the package hidden state and cannot be used in
28445 -- a refinement (SPARK RM 7.2.2(9)).
28447 Error_Msg_Name_1 := Chars (Spec_Id);
28449 ("cannot use & in refinement, constituent is not a hidden "
28450 & "state of package %", Constit, Constit_Id);
28452 end Match_Constituent;
28456 Constit_Id : Entity_Id;
28457 Constits : Elist_Id;
28459 -- Start of processing for Analyze_Constituent
28462 -- Detect multiple uses of null in a single refinement clause or a
28463 -- mixture of null and non-null constituents.
28465 if Nkind (Constit) = N_Null then
28468 ("multiple null constituents not allowed", Constit);
28470 elsif Non_Null_Seen then
28472 ("cannot mix null and non-null constituents", Constit);
28477 -- Collect the constituent in the list of refinement items
28479 Constits := Refinement_Constituents (State_Id);
28481 if No (Constits) then
28482 Constits := New_Elmt_List;
28483 Set_Refinement_Constituents (State_Id, Constits);
28486 Append_Elmt (Constit, Constits);
28488 -- The state has at least one legal constituent, mark the
28489 -- start of the refinement region. The region ends when the
28490 -- body declarations end (see Analyze_Declarations).
28492 Set_Has_Visible_Refinement (State_Id);
28495 -- Non-null constituents
28498 Non_Null_Seen := True;
28502 ("cannot mix null and non-null constituents", Constit);
28506 Resolve_State (Constit);
28508 -- Ensure that the constituent denotes a valid state or a
28509 -- whole object (SPARK RM 7.2.2(5)).
28511 if Is_Entity_Name (Constit) then
28512 Constit_Id := Entity_Of (Constit);
28514 -- When a constituent is declared after a subprogram body
28515 -- that caused freezing of the related contract where
28516 -- pragma Refined_State resides, the constituent appears
28517 -- undefined and carries Any_Id as its entity.
28519 -- package body Pack
28520 -- with Refined_State => (State => Constit)
28523 -- with Refined_Global => (Input => Constit)
28531 if Constit_Id = Any_Id then
28532 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28534 -- Emit a specialized info message when the contract of
28535 -- the related package body was "frozen" by another body.
28536 -- Note that it is not possible to precisely identify why
28537 -- the constituent is undefined because it is not visible
28538 -- when pragma Refined_State is analyzed. This message is
28539 -- a reasonable approximation.
28541 if Present (Freeze_Id) and then not Freeze_Posted then
28542 Freeze_Posted := True;
28544 Error_Msg_Name_1 := Chars (Body_Id);
28545 Error_Msg_Sloc := Sloc (Freeze_Id);
28547 ("body & declared # freezes the contract of %",
28550 ("\all constituents must be declared before body #",
28553 -- A misplaced constituent is a critical error because
28554 -- pragma Refined_Depends or Refined_Global depends on
28555 -- the proper link between a state and a constituent.
28556 -- Stop the compilation, as this leads to a multitude
28557 -- of misleading cascaded errors.
28559 raise Unrecoverable_Error;
28562 -- The constituent is a valid state or object
28564 elsif Ekind (Constit_Id) in
28565 E_Abstract_State | E_Constant | E_Variable
28567 Match_Constituent (Constit_Id);
28569 -- The variable may eventually become a constituent of a
28570 -- single protected/task type. Record the reference now
28571 -- and verify its legality when analyzing the contract of
28572 -- the variable (SPARK RM 9.3).
28574 if Ekind (Constit_Id) = E_Variable then
28575 Record_Possible_Part_Of_Reference
28576 (Var_Id => Constit_Id,
28580 -- Otherwise the constituent is illegal
28584 ("constituent & must denote object or state",
28585 Constit, Constit_Id);
28588 -- The constituent is illegal
28591 SPARK_Msg_N ("malformed constituent", Constit);
28594 end Analyze_Constituent;
28596 -----------------------------
28597 -- Check_External_Property --
28598 -----------------------------
28600 procedure Check_External_Property
28601 (Prop_Nam : Name_Id;
28603 Constit : Entity_Id)
28606 -- The property is missing in the declaration of the state, but
28607 -- a constituent is introducing it in the state refinement
28608 -- (SPARK RM 7.2.8(2)).
28610 if not Enabled and then Present (Constit) then
28611 Error_Msg_Name_1 := Prop_Nam;
28612 Error_Msg_Name_2 := Chars (State_Id);
28614 ("constituent & introduces external property % in refinement "
28615 & "of state %", State, Constit);
28617 Error_Msg_Sloc := Sloc (State_Id);
28619 ("\property is missing in abstract state declaration #",
28622 end Check_External_Property;
28628 procedure Match_State is
28629 State_Elmt : Elmt_Id;
28632 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28634 if Contains (Refined_States_Seen, State_Id) then
28636 ("duplicate refinement of state &", State, State_Id);
28640 -- Inspect the abstract states defined in the package declaration
28641 -- looking for a match.
28643 State_Elmt := First_Elmt (Available_States);
28644 while Present (State_Elmt) loop
28646 -- A valid abstract state is being refined in the body. Add
28647 -- the state to the list of processed refined states to aid
28648 -- with the detection of duplicate refinements. Remove the
28649 -- state from Available_States to signal that it has already
28652 if Node (State_Elmt) = State_Id then
28653 Append_New_Elmt (State_Id, Refined_States_Seen);
28654 Remove_Elmt (Available_States, State_Elmt);
28658 Next_Elmt (State_Elmt);
28661 -- If we get here, we are refining a state that is not defined in
28662 -- the package declaration.
28664 Error_Msg_Name_1 := Chars (Spec_Id);
28666 ("cannot refine state, & is not defined in package %",
28670 --------------------------------
28671 -- Report_Unused_Constituents --
28672 --------------------------------
28674 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28675 Constit_Elmt : Elmt_Id;
28676 Constit_Id : Entity_Id;
28677 Posted : Boolean := False;
28680 if Present (Constits) then
28681 Constit_Elmt := First_Elmt (Constits);
28682 while Present (Constit_Elmt) loop
28683 Constit_Id := Node (Constit_Elmt);
28685 -- Generate an error message of the form:
28687 -- state ... has unused Part_Of constituents
28688 -- abstract state ... defined at ...
28689 -- constant ... defined at ...
28690 -- variable ... defined at ...
28695 ("state & has unused Part_Of constituents",
28699 Error_Msg_Sloc := Sloc (Constit_Id);
28701 if Ekind (Constit_Id) = E_Abstract_State then
28703 ("\abstract state & defined #", State, Constit_Id);
28705 elsif Ekind (Constit_Id) = E_Constant then
28707 ("\constant & defined #", State, Constit_Id);
28710 pragma Assert (Ekind (Constit_Id) = E_Variable);
28711 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28714 Next_Elmt (Constit_Elmt);
28717 end Report_Unused_Constituents;
28719 -- Local declarations
28721 Body_Ref : Node_Id;
28722 Body_Ref_Elmt : Elmt_Id;
28724 Extra_State : Node_Id;
28726 -- Start of processing for Analyze_Refinement_Clause
28729 -- A refinement clause appears as a component association where the
28730 -- sole choice is the state and the expressions are the constituents.
28731 -- This is a syntax error, always report.
28733 if Nkind (Clause) /= N_Component_Association then
28734 Error_Msg_N ("malformed state refinement clause", Clause);
28738 -- Analyze the state name of a refinement clause
28740 State := First (Choices (Clause));
28743 Resolve_State (State);
28745 -- Ensure that the state name denotes a valid abstract state that is
28746 -- defined in the spec of the related package.
28748 if Is_Entity_Name (State) then
28749 State_Id := Entity_Of (State);
28751 -- When the abstract state is undefined, it appears as Any_Id. Do
28752 -- not continue with the analysis of the clause.
28754 if State_Id = Any_Id then
28757 -- Catch any attempts to re-refine a state or refine a state that
28758 -- is not defined in the package declaration.
28760 elsif Ekind (State_Id) = E_Abstract_State then
28764 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28768 -- References to a state with visible refinement are illegal.
28769 -- When nested packages are involved, detecting such references is
28770 -- tricky because pragma Refined_State is analyzed later than the
28771 -- offending pragma Depends or Global. References that occur in
28772 -- such nested context are stored in a list. Emit errors for all
28773 -- references found in Body_References (SPARK RM 6.1.4(8)).
28775 if Present (Body_References (State_Id)) then
28776 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28777 while Present (Body_Ref_Elmt) loop
28778 Body_Ref := Node (Body_Ref_Elmt);
28780 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28781 Error_Msg_Sloc := Sloc (State);
28782 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28784 Next_Elmt (Body_Ref_Elmt);
28788 -- The state name is illegal. This is a syntax error, always report.
28791 Error_Msg_N ("malformed state name in refinement clause", State);
28795 -- A refinement clause may only refine one state at a time
28797 Extra_State := Next (State);
28799 if Present (Extra_State) then
28801 ("refinement clause cannot cover multiple states", Extra_State);
28804 -- Replicate the Part_Of constituents of the refined state because
28805 -- the algorithm will consume items.
28807 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28809 -- Analyze all constituents of the refinement. Multiple constituents
28810 -- appear as an aggregate.
28812 Constit := Expression (Clause);
28814 if Nkind (Constit) = N_Aggregate then
28815 if Present (Component_Associations (Constit)) then
28817 ("constituents of refinement clause must appear in "
28818 & "positional form", Constit);
28820 else pragma Assert (Present (Expressions (Constit)));
28821 Constit := First (Expressions (Constit));
28822 while Present (Constit) loop
28823 Analyze_Constituent (Constit);
28828 -- Various forms of a single constituent. Note that these may include
28829 -- malformed constituents.
28832 Analyze_Constituent (Constit);
28835 -- Verify that external constituents do not introduce new external
28836 -- property in the state refinement (SPARK RM 7.2.8(2)).
28838 if Is_External_State (State_Id) then
28839 Check_External_Property
28840 (Prop_Nam => Name_Async_Readers,
28841 Enabled => Async_Readers_Enabled (State_Id),
28842 Constit => AR_Constit);
28844 Check_External_Property
28845 (Prop_Nam => Name_Async_Writers,
28846 Enabled => Async_Writers_Enabled (State_Id),
28847 Constit => AW_Constit);
28849 Check_External_Property
28850 (Prop_Nam => Name_Effective_Reads,
28851 Enabled => Effective_Reads_Enabled (State_Id),
28852 Constit => ER_Constit);
28854 Check_External_Property
28855 (Prop_Nam => Name_Effective_Writes,
28856 Enabled => Effective_Writes_Enabled (State_Id),
28857 Constit => EW_Constit);
28859 -- When a refined state is not external, it should not have external
28860 -- constituents (SPARK RM 7.2.8(1)).
28862 elsif External_Constit_Seen then
28864 ("non-external state & cannot contain external constituents in "
28865 & "refinement", State, State_Id);
28868 -- Ensure that all Part_Of candidate constituents have been mentioned
28869 -- in the refinement clause.
28871 Report_Unused_Constituents (Part_Of_Constits);
28872 end Analyze_Refinement_Clause;
28874 -----------------------------
28875 -- Report_Unrefined_States --
28876 -----------------------------
28878 procedure Report_Unrefined_States (States : Elist_Id) is
28879 State_Elmt : Elmt_Id;
28882 if Present (States) then
28883 State_Elmt := First_Elmt (States);
28884 while Present (State_Elmt) loop
28886 ("abstract state & must be refined", Node (State_Elmt));
28888 Next_Elmt (State_Elmt);
28891 end Report_Unrefined_States;
28893 -- Local declarations
28895 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
28898 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28901 -- Do not analyze the pragma multiple times
28903 if Is_Analyzed_Pragma (N) then
28907 -- Save the scenario for examination by the ABE Processing phase
28909 Record_Elaboration_Scenario (N);
28911 -- Replicate the abstract states declared by the package because the
28912 -- matching algorithm will consume states.
28914 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
28916 -- Gather all abstract states and objects declared in the visible
28917 -- state space of the package body. These items must be utilized as
28918 -- constituents in a state refinement.
28920 Body_States := Collect_Body_States (Body_Id);
28922 -- Multiple non-null state refinements appear as an aggregate
28924 if Nkind (Clauses) = N_Aggregate then
28925 if Present (Expressions (Clauses)) then
28927 ("state refinements must appear as component associations",
28930 else pragma Assert (Present (Component_Associations (Clauses)));
28931 Clause := First (Component_Associations (Clauses));
28932 while Present (Clause) loop
28933 Analyze_Refinement_Clause (Clause);
28938 -- Various forms of a single state refinement. Note that these may
28939 -- include malformed refinements.
28942 Analyze_Refinement_Clause (Clauses);
28945 -- List all abstract states that were left unrefined
28947 Report_Unrefined_States (Available_States);
28949 Set_Is_Analyzed_Pragma (N);
28950 end Analyze_Refined_State_In_Decl_Part;
28952 ---------------------------------------------
28953 -- Analyze_Subprogram_Variant_In_Decl_Part --
28954 ---------------------------------------------
28956 -- WARNING: This routine manages Ghost regions. Return statements must be
28957 -- replaced by gotos which jump to the end of the routine and restore the
28960 procedure Analyze_Subprogram_Variant_In_Decl_Part
28962 Freeze_Id : Entity_Id := Empty)
28964 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28965 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
28967 procedure Analyze_Variant (Variant : Node_Id);
28968 -- Verify the legality of a single contract case
28970 ---------------------
28971 -- Analyze_Variant --
28972 ---------------------
28974 procedure Analyze_Variant (Variant : Node_Id) is
28975 Direction : Node_Id;
28978 Extra_Direction : Node_Id;
28981 if Nkind (Variant) /= N_Component_Association then
28982 Error_Msg_N ("wrong syntax in subprogram variant", Variant);
28986 Direction := First (Choices (Variant));
28987 Expr := Expression (Variant);
28989 -- Each variant must have exactly one direction
28991 Extra_Direction := Next (Direction);
28993 if Present (Extra_Direction) then
28995 ("subprogram variant case must have exactly one direction",
28999 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
29001 if Nkind (Direction) = N_Identifier then
29002 if Chars (Direction) /= Name_Decreases
29004 Chars (Direction) /= Name_Increases
29006 Error_Msg_N ("wrong direction", Direction);
29009 Error_Msg_N ("wrong syntax", Direction);
29012 Errors := Serious_Errors_Detected;
29013 Preanalyze_Assert_Expression (Expr, Any_Discrete);
29015 -- Emit a clarification message when the variant expression
29016 -- contains at least one undefined reference, possibly due
29017 -- to contract freezing.
29019 if Errors /= Serious_Errors_Detected
29020 and then Present (Freeze_Id)
29021 and then Has_Undefined_Reference (Expr)
29023 Contract_Freeze_Error (Spec_Id, Freeze_Id);
29025 end Analyze_Variant;
29029 Variants : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29031 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
29032 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
29033 -- Save the Ghost-related attributes to restore on exit
29036 Restore_Scope : Boolean := False;
29038 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
29041 -- Do not analyze the pragma multiple times
29043 if Is_Analyzed_Pragma (N) then
29047 -- Set the Ghost mode in effect from the pragma. Due to the delayed
29048 -- analysis of the pragma, the Ghost mode at point of declaration and
29049 -- point of analysis may not necessarily be the same. Use the mode in
29050 -- effect at the point of declaration.
29052 Set_Ghost_Mode (N);
29054 -- Single and multiple contract cases must appear in aggregate form. If
29055 -- this is not the case, then either the parser of the analysis of the
29056 -- pragma failed to produce an aggregate.
29058 pragma Assert (Nkind (Variants) = N_Aggregate);
29060 -- Only "change_direction => discrete_expression" clauses are allowed
29062 if Present (Component_Associations (Variants))
29063 and then No (Expressions (Variants))
29066 -- Ensure that the formal parameters are visible when analyzing all
29067 -- clauses. This falls out of the general rule of aspects pertaining
29068 -- to subprogram declarations.
29070 if not In_Open_Scopes (Spec_Id) then
29071 Restore_Scope := True;
29072 Push_Scope (Spec_Id);
29074 if Is_Generic_Subprogram (Spec_Id) then
29075 Install_Generic_Formals (Spec_Id);
29077 Install_Formals (Spec_Id);
29081 Variant := First (Component_Associations (Variants));
29082 while Present (Variant) loop
29083 Analyze_Variant (Variant);
29087 if Restore_Scope then
29091 -- Otherwise the pragma is illegal
29094 Error_Msg_N ("wrong syntax for subprogram variant", N);
29097 Set_Is_Analyzed_Pragma (N);
29099 Restore_Ghost_Region (Saved_GM, Saved_IGR);
29100 end Analyze_Subprogram_Variant_In_Decl_Part;
29102 ------------------------------------
29103 -- Analyze_Test_Case_In_Decl_Part --
29104 ------------------------------------
29106 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29107 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29108 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29110 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29111 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29112 -- denoted by Arg_Nam.
29114 ------------------------------
29115 -- Preanalyze_Test_Case_Arg --
29116 ------------------------------
29118 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29122 -- Preanalyze the original aspect argument for a generic subprogram
29123 -- to properly capture global references.
29125 if Is_Generic_Subprogram (Spec_Id) then
29129 Arg_Nam => Arg_Nam,
29130 From_Aspect => True);
29132 if Present (Arg) then
29133 Preanalyze_Assert_Expression
29134 (Expression (Arg), Standard_Boolean);
29138 Arg := Test_Case_Arg (N, Arg_Nam);
29140 if Present (Arg) then
29141 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29143 end Preanalyze_Test_Case_Arg;
29147 Restore_Scope : Boolean := False;
29149 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29152 -- Do not analyze the pragma multiple times
29154 if Is_Analyzed_Pragma (N) then
29158 -- Ensure that the formal parameters are visible when analyzing all
29159 -- clauses. This falls out of the general rule of aspects pertaining
29160 -- to subprogram declarations.
29162 if not In_Open_Scopes (Spec_Id) then
29163 Restore_Scope := True;
29164 Push_Scope (Spec_Id);
29166 if Is_Generic_Subprogram (Spec_Id) then
29167 Install_Generic_Formals (Spec_Id);
29169 Install_Formals (Spec_Id);
29173 Preanalyze_Test_Case_Arg (Name_Requires);
29174 Preanalyze_Test_Case_Arg (Name_Ensures);
29176 if Restore_Scope then
29180 -- Currently it is not possible to inline pre/postconditions on a
29181 -- subprogram subject to pragma Inline_Always.
29183 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29185 Set_Is_Analyzed_Pragma (N);
29186 end Analyze_Test_Case_In_Decl_Part;
29192 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29197 if Present (List) then
29198 Elmt := First_Elmt (List);
29199 while Present (Elmt) loop
29200 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29203 Id := Entity_Of (Node (Elmt));
29206 if Id = Item_Id then
29217 -----------------------------------
29218 -- Build_Pragma_Check_Equivalent --
29219 -----------------------------------
29221 function Build_Pragma_Check_Equivalent
29223 Subp_Id : Entity_Id := Empty;
29224 Inher_Id : Entity_Id := Empty;
29225 Keep_Pragma_Id : Boolean := False) return Node_Id
29227 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29228 -- Detect whether node N references a formal parameter subject to
29229 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29230 -- to False to suppress the generation of a reference when analyzing
29233 ------------------------
29234 -- Suppress_Reference --
29235 ------------------------
29237 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29238 Formal : Entity_Id;
29241 if Is_Entity_Name (N) and then Present (Entity (N)) then
29242 Formal := Entity (N);
29244 -- The formal parameter is subject to pragma Unreferenced. Prevent
29245 -- the generation of references by resetting the Comes_From_Source
29248 if Is_Formal (Formal)
29249 and then Has_Pragma_Unreferenced (Formal)
29251 Set_Comes_From_Source (N, False);
29256 end Suppress_Reference;
29258 procedure Suppress_References is
29259 new Traverse_Proc (Suppress_Reference);
29263 Loc : constant Source_Ptr := Sloc (Prag);
29264 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29265 Check_Prag : Node_Id;
29269 Needs_Wrapper : Boolean;
29270 pragma Unreferenced (Needs_Wrapper);
29272 -- Start of processing for Build_Pragma_Check_Equivalent
29275 -- When the pre- or postcondition is inherited, map the formals of the
29276 -- inherited subprogram to those of the current subprogram. In addition,
29277 -- map primitive operations of the parent type into the corresponding
29278 -- primitive operations of the descendant.
29280 if Present (Inher_Id) then
29281 pragma Assert (Present (Subp_Id));
29283 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29285 -- Use generic machinery to copy inherited pragma, as if it were an
29286 -- instantiation, resetting source locations appropriately, so that
29287 -- expressions inside the inherited pragma use chained locations.
29288 -- This is used in particular in GNATprove to locate precisely
29289 -- messages on a given inherited pragma.
29291 Set_Copied_Sloc_For_Inherited_Pragma
29292 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29293 Check_Prag := New_Copy_Tree (Source => Prag);
29295 -- Build the inherited class-wide condition
29297 Build_Class_Wide_Expression
29298 (Prag => Check_Prag,
29300 Par_Subp => Inher_Id,
29301 Adjust_Sloc => True,
29302 Needs_Wrapper => Needs_Wrapper);
29304 -- If not an inherited condition simply copy the original pragma
29307 Check_Prag := New_Copy_Tree (Source => Prag);
29310 -- Mark the pragma as being internally generated and reset the Analyzed
29313 Set_Analyzed (Check_Prag, False);
29314 Set_Comes_From_Source (Check_Prag, False);
29316 -- The tree of the original pragma may contain references to the
29317 -- formal parameters of the related subprogram. At the same time
29318 -- the corresponding body may mark the formals as unreferenced:
29320 -- procedure Proc (Formal : ...)
29321 -- with Pre => Formal ...;
29323 -- procedure Proc (Formal : ...) is
29324 -- pragma Unreferenced (Formal);
29327 -- This creates problems because all pragma Check equivalents are
29328 -- analyzed at the end of the body declarations. Since all source
29329 -- references have already been accounted for, reset any references
29330 -- to such formals in the generated pragma Check equivalent.
29332 Suppress_References (Check_Prag);
29334 if Present (Corresponding_Aspect (Prag)) then
29335 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29340 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29341 -- the copied pragma in the newly created pragma, convert the copy into
29342 -- pragma Check by correcting the name and adding a check_kind argument.
29344 if not Keep_Pragma_Id then
29345 Set_Class_Present (Check_Prag, False);
29347 Set_Pragma_Identifier
29348 (Check_Prag, Make_Identifier (Loc, Name_Check));
29350 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29351 Make_Pragma_Argument_Association (Loc,
29352 Expression => Make_Identifier (Loc, Nam)));
29355 -- Update the error message when the pragma is inherited
29357 if Present (Inher_Id) then
29358 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29360 if Chars (Msg_Arg) = Name_Message then
29361 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29363 -- Insert "inherited" to improve the error message
29365 if Name_Buffer (1 .. 8) = "failed p" then
29366 Insert_Str_In_Name_Buffer ("inherited ", 8);
29367 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29373 end Build_Pragma_Check_Equivalent;
29375 -----------------------------
29376 -- Check_Applicable_Policy --
29377 -----------------------------
29379 procedure Check_Applicable_Policy (N : Node_Id) is
29383 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29386 -- No effect if not valid assertion kind name
29388 if not Is_Valid_Assertion_Kind (Ename) then
29392 -- Loop through entries in check policy list
29394 PP := Opt.Check_Policy_List;
29395 while Present (PP) loop
29397 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29398 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29402 or else Pnm = Name_Assertion
29403 or else (Pnm = Name_Statement_Assertions
29404 and then Ename in Name_Assert
29405 | Name_Assert_And_Cut
29407 | Name_Loop_Invariant
29408 | Name_Loop_Variant)
29410 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29416 -- In CodePeer mode and GNATprove mode, we need to
29417 -- consider all assertions, unless they are disabled.
29418 -- Force Is_Checked on ignored assertions, in particular
29419 -- because transformations of the AST may depend on
29420 -- assertions being checked (e.g. the translation of
29421 -- attribute 'Loop_Entry).
29423 if CodePeer_Mode or GNATprove_Mode then
29424 Set_Is_Checked (N, True);
29425 Set_Is_Ignored (N, False);
29427 Set_Is_Checked (N, False);
29428 Set_Is_Ignored (N, True);
29434 Set_Is_Checked (N, True);
29435 Set_Is_Ignored (N, False);
29437 when Name_Disable =>
29438 Set_Is_Ignored (N, True);
29439 Set_Is_Checked (N, False);
29440 Set_Is_Disabled (N, True);
29442 -- That should be exhaustive, the null here is a defence
29443 -- against a malformed tree from previous errors.
29452 PP := Next_Pragma (PP);
29456 -- If there are no specific entries that matched, then we let the
29457 -- setting of assertions govern. Note that this provides the needed
29458 -- compatibility with the RM for the cases of assertion, invariant,
29459 -- precondition, predicate, and postcondition. Note also that
29460 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29462 if Assertions_Enabled then
29463 Set_Is_Checked (N, True);
29464 Set_Is_Ignored (N, False);
29466 Set_Is_Checked (N, False);
29467 Set_Is_Ignored (N, True);
29469 end Check_Applicable_Policy;
29471 -------------------------------
29472 -- Check_External_Properties --
29473 -------------------------------
29475 procedure Check_External_Properties
29482 type Properties is array (Positive range 1 .. 4) of Boolean;
29483 type Combinations is array (Positive range <>) of Properties;
29484 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
29485 -- Effective_Reads properties and their combinations, respectively.
29487 Specified : constant Properties := (AR, AW, EW, ER);
29488 -- External properties, as given by the Item pragma
29490 Allowed : constant Combinations :=
29491 (1 => (True, False, True, False),
29492 2 => (False, True, False, True),
29493 3 => (True, False, False, False),
29494 4 => (False, True, False, False),
29495 5 => (True, True, True, False),
29496 6 => (True, True, False, True),
29497 7 => (True, True, False, False),
29498 8 => (True, True, True, True));
29499 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
29502 -- Check if the specified properties match any of the allowed
29503 -- combination; if not, then emit an error.
29505 for J in Allowed'Range loop
29506 if Specified = Allowed (J) then
29512 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29514 end Check_External_Properties;
29520 function Check_Kind (Nam : Name_Id) return Name_Id is
29524 -- Loop through entries in check policy list
29526 PP := Opt.Check_Policy_List;
29527 while Present (PP) loop
29529 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29530 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29534 or else (Pnm = Name_Assertion
29535 and then Is_Valid_Assertion_Kind (Nam))
29536 or else (Pnm = Name_Statement_Assertions
29537 and then Nam in Name_Assert
29538 | Name_Assert_And_Cut
29540 | Name_Loop_Invariant
29541 | Name_Loop_Variant)
29543 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29552 return Name_Ignore;
29554 when Name_Disable =>
29555 return Name_Disable;
29558 raise Program_Error;
29562 PP := Next_Pragma (PP);
29567 -- If there are no specific entries that matched, then we let the
29568 -- setting of assertions govern. Note that this provides the needed
29569 -- compatibility with the RM for the cases of assertion, invariant,
29570 -- precondition, predicate, and postcondition.
29572 if Assertions_Enabled then
29575 return Name_Ignore;
29579 ---------------------------
29580 -- Check_Missing_Part_Of --
29581 ---------------------------
29583 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29584 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29585 -- Determine whether a package denoted by Pack_Id declares at least one
29588 -----------------------
29589 -- Has_Visible_State --
29590 -----------------------
29592 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29593 Item_Id : Entity_Id;
29596 -- Traverse the entity chain of the package trying to find at least
29597 -- one visible abstract state, variable or a package [instantiation]
29598 -- that declares a visible state.
29600 Item_Id := First_Entity (Pack_Id);
29601 while Present (Item_Id)
29602 and then not In_Private_Part (Item_Id)
29604 -- Do not consider internally generated items
29606 if not Comes_From_Source (Item_Id) then
29609 -- Do not consider generic formals or their corresponding actuals
29610 -- because they are not part of a visible state. Note that both
29611 -- entities are marked as hidden.
29613 elsif Is_Hidden (Item_Id) then
29616 -- A visible state has been found. Note that constants are not
29617 -- considered here because it is not possible to determine whether
29618 -- they depend on variable input. This check is left to the SPARK
29621 elsif Ekind (Item_Id) in E_Abstract_State | E_Variable then
29624 -- Recursively peek into nested packages and instantiations
29626 elsif Ekind (Item_Id) = E_Package
29627 and then Has_Visible_State (Item_Id)
29632 Next_Entity (Item_Id);
29636 end Has_Visible_State;
29640 Pack_Id : Entity_Id;
29641 Placement : State_Space_Kind;
29643 -- Start of processing for Check_Missing_Part_Of
29646 -- Do not consider abstract states, variables or package instantiations
29647 -- coming from an instance as those always inherit the Part_Of indicator
29648 -- of the instance itself.
29650 if In_Instance then
29653 -- Do not consider internally generated entities as these can never
29654 -- have a Part_Of indicator.
29656 elsif not Comes_From_Source (Item_Id) then
29659 -- Perform these checks only when SPARK_Mode is enabled as they will
29660 -- interfere with standard Ada rules and produce false positives.
29662 elsif SPARK_Mode /= On then
29665 -- Do not consider constants, because the compiler cannot accurately
29666 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29667 -- act as a hidden state of a package.
29669 elsif Ekind (Item_Id) = E_Constant then
29673 -- Find where the abstract state, variable or package instantiation
29674 -- lives with respect to the state space.
29676 Find_Placement_In_State_Space
29677 (Item_Id => Item_Id,
29678 Placement => Placement,
29679 Pack_Id => Pack_Id);
29681 -- Items that appear in a non-package construct (subprogram, block, etc)
29682 -- do not require a Part_Of indicator because they can never act as a
29685 if Placement = Not_In_Package then
29688 -- An item declared in the body state space of a package always act as a
29689 -- constituent and does not need explicit Part_Of indicator.
29691 elsif Placement = Body_State_Space then
29694 -- In general an item declared in the visible state space of a package
29695 -- does not require a Part_Of indicator. The only exception is when the
29696 -- related package is a nongeneric private child unit, in which case
29697 -- Part_Of must denote a state in the parent unit or in one of its
29700 elsif Placement = Visible_State_Space then
29701 if Is_Child_Unit (Pack_Id)
29702 and then not Is_Generic_Unit (Pack_Id)
29703 and then Is_Private_Descendant (Pack_Id)
29705 -- A package instantiation does not need a Part_Of indicator when
29706 -- the related generic template has no visible state.
29708 if Ekind (Item_Id) = E_Package
29709 and then Is_Generic_Instance (Item_Id)
29710 and then not Has_Visible_State (Item_Id)
29714 -- All other cases require Part_Of
29718 ("indicator Part_Of is required in this context "
29719 & "(SPARK RM 7.2.6(3))", Item_Id);
29720 Error_Msg_Name_1 := Chars (Pack_Id);
29722 ("\& is declared in the visible part of private child "
29723 & "unit %", Item_Id);
29727 -- When the item appears in the private state space of a package, it
29728 -- must be a part of some state declared by the said package.
29730 else pragma Assert (Placement = Private_State_Space);
29732 -- The related package does not declare a state, the item cannot act
29733 -- as a Part_Of constituent.
29735 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29738 -- A package instantiation does not need a Part_Of indicator when the
29739 -- related generic template has no visible state.
29741 elsif Ekind (Item_Id) = E_Package
29742 and then Is_Generic_Instance (Item_Id)
29743 and then not Has_Visible_State (Item_Id)
29747 -- All other cases require Part_Of
29751 ("indicator Part_Of is required in this context "
29752 & "(SPARK RM 7.2.6(2))", Item_Id);
29753 Error_Msg_Name_1 := Chars (Pack_Id);
29755 ("\& is declared in the private part of package %", Item_Id);
29758 end Check_Missing_Part_Of;
29760 ---------------------------------------------------
29761 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29762 ---------------------------------------------------
29764 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29766 Spec_Id : Entity_Id)
29769 if Warn_On_Redundant_Constructs
29770 and then Has_Pragma_Inline_Always (Spec_Id)
29771 and then Assertions_Enabled
29773 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29775 if From_Aspect_Specification (Prag) then
29777 ("aspect % not enforced on inlined subprogram &?r?",
29778 Corresponding_Aspect (Prag), Spec_Id);
29781 ("pragma % not enforced on inlined subprogram &?r?",
29785 end Check_Postcondition_Use_In_Inlined_Subprogram;
29787 -------------------------------------
29788 -- Check_State_And_Constituent_Use --
29789 -------------------------------------
29791 procedure Check_State_And_Constituent_Use
29792 (States : Elist_Id;
29793 Constits : Elist_Id;
29796 Constit_Elmt : Elmt_Id;
29797 Constit_Id : Entity_Id;
29798 State_Id : Entity_Id;
29801 -- Nothing to do if there are no states or constituents
29803 if No (States) or else No (Constits) then
29807 -- Inspect the list of constituents and try to determine whether its
29808 -- encapsulating state is in list States.
29810 Constit_Elmt := First_Elmt (Constits);
29811 while Present (Constit_Elmt) loop
29812 Constit_Id := Node (Constit_Elmt);
29814 -- Determine whether the constituent is part of an encapsulating
29815 -- state that appears in the same context and if this is the case,
29816 -- emit an error (SPARK RM 7.2.6(7)).
29818 State_Id := Find_Encapsulating_State (States, Constit_Id);
29820 if Present (State_Id) then
29821 Error_Msg_Name_1 := Chars (Constit_Id);
29823 ("cannot mention state & and its constituent % in the same "
29824 & "context", Context, State_Id);
29828 Next_Elmt (Constit_Elmt);
29830 end Check_State_And_Constituent_Use;
29832 ---------------------------------------------
29833 -- Collect_Inherited_Class_Wide_Conditions --
29834 ---------------------------------------------
29836 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29837 Parent_Subp : constant Entity_Id :=
29838 Ultimate_Alias (Overridden_Operation (Subp));
29839 -- The Overridden_Operation may itself be inherited and as such have no
29840 -- explicit contract.
29842 Prags : constant Node_Id := Contract (Parent_Subp);
29843 In_Spec_Expr : Boolean := In_Spec_Expression;
29844 Installed : Boolean;
29846 New_Prag : Node_Id;
29849 Installed := False;
29851 -- Iterate over the contract of the overridden subprogram to find all
29852 -- inherited class-wide pre- and postconditions.
29854 if Present (Prags) then
29855 Prag := Pre_Post_Conditions (Prags);
29857 while Present (Prag) loop
29858 if Pragma_Name_Unmapped (Prag)
29859 in Name_Precondition | Name_Postcondition
29860 and then Class_Present (Prag)
29862 -- The generated pragma must be analyzed in the context of
29863 -- the subprogram, to make its formals visible. In addition,
29864 -- we must inhibit freezing and full analysis because the
29865 -- controlling type of the subprogram is not frozen yet, and
29866 -- may have further primitives.
29868 if not Installed then
29871 Install_Formals (Subp);
29872 In_Spec_Expr := In_Spec_Expression;
29873 In_Spec_Expression := True;
29877 Build_Pragma_Check_Equivalent
29878 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29880 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29881 Preanalyze (New_Prag);
29883 -- Prevent further analysis in subsequent processing of the
29884 -- current list of declarations
29886 Set_Analyzed (New_Prag);
29889 Prag := Next_Pragma (Prag);
29893 In_Spec_Expression := In_Spec_Expr;
29897 end Collect_Inherited_Class_Wide_Conditions;
29899 ---------------------------------------
29900 -- Collect_Subprogram_Inputs_Outputs --
29901 ---------------------------------------
29903 procedure Collect_Subprogram_Inputs_Outputs
29904 (Subp_Id : Entity_Id;
29905 Synthesize : Boolean := False;
29906 Subp_Inputs : in out Elist_Id;
29907 Subp_Outputs : in out Elist_Id;
29908 Global_Seen : out Boolean)
29910 procedure Collect_Dependency_Clause (Clause : Node_Id);
29911 -- Collect all relevant items from a dependency clause
29913 procedure Collect_Global_List
29915 Mode : Name_Id := Name_Input);
29916 -- Collect all relevant items from a global list
29918 -------------------------------
29919 -- Collect_Dependency_Clause --
29920 -------------------------------
29922 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29923 procedure Collect_Dependency_Item
29925 Is_Input : Boolean);
29926 -- Add an item to the proper subprogram input or output collection
29928 -----------------------------
29929 -- Collect_Dependency_Item --
29930 -----------------------------
29932 procedure Collect_Dependency_Item
29934 Is_Input : Boolean)
29939 -- Nothing to collect when the item is null
29941 if Nkind (Item) = N_Null then
29944 -- Ditto for attribute 'Result
29946 elsif Is_Attribute_Result (Item) then
29949 -- Multiple items appear as an aggregate
29951 elsif Nkind (Item) = N_Aggregate then
29952 Extra := First (Expressions (Item));
29953 while Present (Extra) loop
29954 Collect_Dependency_Item (Extra, Is_Input);
29958 -- Otherwise this is a solitary item
29962 Append_New_Elmt (Item, Subp_Inputs);
29964 Append_New_Elmt (Item, Subp_Outputs);
29967 end Collect_Dependency_Item;
29969 -- Start of processing for Collect_Dependency_Clause
29972 if Nkind (Clause) = N_Null then
29975 -- A dependency clause appears as component association
29977 elsif Nkind (Clause) = N_Component_Association then
29978 Collect_Dependency_Item
29979 (Item => Expression (Clause),
29982 Collect_Dependency_Item
29983 (Item => First (Choices (Clause)),
29984 Is_Input => False);
29986 -- To accommodate partial decoration of disabled SPARK features, this
29987 -- routine may be called with illegal input. If this is the case, do
29988 -- not raise Program_Error.
29993 end Collect_Dependency_Clause;
29995 -------------------------
29996 -- Collect_Global_List --
29997 -------------------------
29999 procedure Collect_Global_List
30001 Mode : Name_Id := Name_Input)
30003 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
30004 -- Add an item to the proper subprogram input or output collection
30006 -------------------------
30007 -- Collect_Global_Item --
30008 -------------------------
30010 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
30012 if Mode in Name_In_Out | Name_Input then
30013 Append_New_Elmt (Item, Subp_Inputs);
30016 if Mode in Name_In_Out | Name_Output then
30017 Append_New_Elmt (Item, Subp_Outputs);
30019 end Collect_Global_Item;
30026 -- Start of processing for Collect_Global_List
30029 if Nkind (List) = N_Null then
30032 -- Single global item declaration
30034 elsif Nkind (List) in N_Expanded_Name
30036 | N_Selected_Component
30038 Collect_Global_Item (List, Mode);
30040 -- Simple global list or moded global list declaration
30042 elsif Nkind (List) = N_Aggregate then
30043 if Present (Expressions (List)) then
30044 Item := First (Expressions (List));
30045 while Present (Item) loop
30046 Collect_Global_Item (Item, Mode);
30051 Assoc := First (Component_Associations (List));
30052 while Present (Assoc) loop
30053 Collect_Global_List
30054 (List => Expression (Assoc),
30055 Mode => Chars (First (Choices (Assoc))));
30060 -- To accommodate partial decoration of disabled SPARK features, this
30061 -- routine may be called with illegal input. If this is the case, do
30062 -- not raise Program_Error.
30067 end Collect_Global_List;
30074 Formal : Entity_Id;
30076 Spec_Id : Entity_Id := Empty;
30077 Subp_Decl : Node_Id;
30080 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30083 Global_Seen := False;
30085 -- Process all formal parameters of entries, [generic] subprograms, and
30088 if Ekind (Subp_Id) in E_Entry
30091 | E_Generic_Function
30092 | E_Generic_Procedure
30094 | E_Subprogram_Body
30096 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30097 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30099 -- Process all formal parameters
30101 Formal := First_Entity (Spec_Id);
30102 while Present (Formal) loop
30103 if Ekind (Formal) in E_In_Out_Parameter | E_In_Parameter then
30104 Append_New_Elmt (Formal, Subp_Inputs);
30107 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
30108 Append_New_Elmt (Formal, Subp_Outputs);
30110 -- Out parameters can act as inputs when the related type is
30111 -- tagged, unconstrained array, unconstrained record, or record
30112 -- with unconstrained components.
30114 if Ekind (Formal) = E_Out_Parameter
30115 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30117 Append_New_Elmt (Formal, Subp_Inputs);
30121 Next_Entity (Formal);
30124 -- Otherwise the input denotes a task type, a task body, or the
30125 -- anonymous object created for a single task type.
30127 elsif Ekind (Subp_Id) in E_Task_Type | E_Task_Body
30128 or else Is_Single_Task_Object (Subp_Id)
30130 Subp_Decl := Declaration_Node (Subp_Id);
30131 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30134 -- When processing an entry, subprogram or task body, look for pragmas
30135 -- Refined_Depends and Refined_Global as they specify the inputs and
30138 if Is_Entry_Body (Subp_Id)
30139 or else Ekind (Subp_Id) in E_Subprogram_Body | E_Task_Body
30141 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30142 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30144 -- Subprogram declaration or stand-alone body case, look for pragmas
30145 -- Depends and Global
30148 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30149 Global := Get_Pragma (Spec_Id, Pragma_Global);
30152 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30153 -- because it provides finer granularity of inputs and outputs.
30155 if Present (Global) then
30156 Global_Seen := True;
30157 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30159 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30160 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30161 -- the inputs and outputs from [Refined_]Depends.
30163 elsif Synthesize and then Present (Depends) then
30164 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30166 -- Multiple dependency clauses appear as an aggregate
30168 if Nkind (Clauses) = N_Aggregate then
30169 Clause := First (Component_Associations (Clauses));
30170 while Present (Clause) loop
30171 Collect_Dependency_Clause (Clause);
30175 -- Otherwise this is a single dependency clause
30178 Collect_Dependency_Clause (Clauses);
30182 -- The current instance of a protected type acts as a formal parameter
30183 -- of mode IN for functions and IN OUT for entries and procedures
30184 -- (SPARK RM 6.1.4).
30186 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30187 Typ := Scope (Spec_Id);
30189 -- Use the anonymous object when the type is single protected
30191 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30192 Typ := Anonymous_Object (Typ);
30195 Append_New_Elmt (Typ, Subp_Inputs);
30197 if Ekind (Spec_Id) in E_Entry | E_Entry_Family | E_Procedure then
30198 Append_New_Elmt (Typ, Subp_Outputs);
30201 -- The current instance of a task type acts as a formal parameter of
30202 -- mode IN OUT (SPARK RM 6.1.4).
30204 elsif Ekind (Spec_Id) = E_Task_Type then
30207 -- Use the anonymous object when the type is single task
30209 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30210 Typ := Anonymous_Object (Typ);
30213 Append_New_Elmt (Typ, Subp_Inputs);
30214 Append_New_Elmt (Typ, Subp_Outputs);
30216 elsif Is_Single_Task_Object (Spec_Id) then
30217 Append_New_Elmt (Spec_Id, Subp_Inputs);
30218 Append_New_Elmt (Spec_Id, Subp_Outputs);
30220 end Collect_Subprogram_Inputs_Outputs;
30222 ---------------------------
30223 -- Contract_Freeze_Error --
30224 ---------------------------
30226 procedure Contract_Freeze_Error
30227 (Contract_Id : Entity_Id;
30228 Freeze_Id : Entity_Id)
30231 Error_Msg_Name_1 := Chars (Contract_Id);
30232 Error_Msg_Sloc := Sloc (Freeze_Id);
30235 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30237 ("\all contractual items must be declared before body #", Contract_Id);
30238 end Contract_Freeze_Error;
30240 ---------------------------------
30241 -- Delay_Config_Pragma_Analyze --
30242 ---------------------------------
30244 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30246 return Pragma_Name_Unmapped (N)
30247 in Name_Interrupt_State | Name_Priority_Specific_Dispatching;
30248 end Delay_Config_Pragma_Analyze;
30250 -----------------------
30251 -- Duplication_Error --
30252 -----------------------
30254 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30255 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30256 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30259 Error_Msg_Sloc := Sloc (Prev);
30260 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30262 -- Emit a precise message to distinguish between source pragmas and
30263 -- pragmas generated from aspects. The ordering of the two pragmas is
30267 -- Prag -- duplicate
30269 -- No error is emitted when both pragmas come from aspects because this
30270 -- is already detected by the general aspect analysis mechanism.
30272 if Prag_From_Asp and Prev_From_Asp then
30274 elsif Prag_From_Asp then
30275 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30276 elsif Prev_From_Asp then
30277 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30279 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30281 end Duplication_Error;
30283 ------------------------------
30284 -- Find_Encapsulating_State --
30285 ------------------------------
30287 function Find_Encapsulating_State
30288 (States : Elist_Id;
30289 Constit_Id : Entity_Id) return Entity_Id
30291 State_Id : Entity_Id;
30294 -- Since a constituent may be part of a larger constituent set, climb
30295 -- the encapsulating state chain looking for a state that appears in
30298 State_Id := Encapsulating_State (Constit_Id);
30299 while Present (State_Id) loop
30300 if Contains (States, State_Id) then
30304 State_Id := Encapsulating_State (State_Id);
30308 end Find_Encapsulating_State;
30310 --------------------------
30311 -- Find_Related_Context --
30312 --------------------------
30314 function Find_Related_Context
30316 Do_Checks : Boolean := False) return Node_Id
30321 Stmt := Prev (Prag);
30322 while Present (Stmt) loop
30324 -- Skip prior pragmas, but check for duplicates
30326 if Nkind (Stmt) = N_Pragma then
30328 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30335 -- Skip internally generated code
30337 elsif not Comes_From_Source (Stmt)
30338 and then not Comes_From_Source (Original_Node (Stmt))
30341 -- The anonymous object created for a single concurrent type is a
30342 -- suitable context.
30344 if Nkind (Stmt) = N_Object_Declaration
30345 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30350 -- Return the current source construct
30360 end Find_Related_Context;
30362 --------------------------------------
30363 -- Find_Related_Declaration_Or_Body --
30364 --------------------------------------
30366 function Find_Related_Declaration_Or_Body
30368 Do_Checks : Boolean := False) return Node_Id
30370 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30372 procedure Expression_Function_Error;
30373 -- Emit an error concerning pragma Prag that illegaly applies to an
30374 -- expression function.
30376 -------------------------------
30377 -- Expression_Function_Error --
30378 -------------------------------
30380 procedure Expression_Function_Error is
30382 Error_Msg_Name_1 := Prag_Nam;
30384 -- Emit a precise message to distinguish between source pragmas and
30385 -- pragmas generated from aspects.
30387 if From_Aspect_Specification (Prag) then
30389 ("aspect % cannot apply to a stand alone expression function",
30393 ("pragma % cannot apply to a stand alone expression function",
30396 end Expression_Function_Error;
30400 Context : constant Node_Id := Parent (Prag);
30403 Look_For_Body : constant Boolean :=
30404 Prag_Nam in Name_Refined_Depends
30405 | Name_Refined_Global
30406 | Name_Refined_Post
30407 | Name_Refined_State;
30408 -- Refinement pragmas must be associated with a subprogram body [stub]
30410 -- Start of processing for Find_Related_Declaration_Or_Body
30413 Stmt := Prev (Prag);
30414 while Present (Stmt) loop
30416 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30417 -- by splitting a complex pre/postcondition are not considered to
30420 if Nkind (Stmt) = N_Pragma then
30422 and then not Split_PPC (Stmt)
30423 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30430 -- Emit an error when a refinement pragma appears on an expression
30431 -- function without a completion.
30434 and then Look_For_Body
30435 and then Nkind (Stmt) = N_Subprogram_Declaration
30436 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30437 and then not Has_Completion (Defining_Entity (Stmt))
30439 Expression_Function_Error;
30442 -- The refinement pragma applies to a subprogram body stub
30444 elsif Look_For_Body
30445 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30449 -- Skip internally generated code
30451 elsif not Comes_From_Source (Stmt) then
30453 -- The anonymous object created for a single concurrent type is a
30454 -- suitable context.
30456 if Nkind (Stmt) = N_Object_Declaration
30457 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30461 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30463 -- The subprogram declaration is an internally generated spec
30464 -- for an expression function.
30466 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30469 -- The subprogram declaration is an internally generated spec
30470 -- for a stand-alone subrogram body declared inside a protected
30473 elsif Present (Corresponding_Body (Stmt))
30474 and then Comes_From_Source (Corresponding_Body (Stmt))
30475 and then Is_Protected_Type (Current_Scope)
30479 -- The subprogram is actually an instance housed within an
30480 -- anonymous wrapper package.
30482 elsif Present (Generic_Parent (Specification (Stmt))) then
30485 -- Ada 2020: contract on formal subprogram or on generated
30486 -- Access_Subprogram_Wrapper, which appears after the related
30487 -- Access_Subprogram declaration.
30489 elsif Is_Generic_Actual_Subprogram (Defining_Entity (Stmt))
30490 and then Ada_Version >= Ada_2020
30494 elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
30495 and then Ada_Version >= Ada_2020
30501 -- Return the current construct which is either a subprogram body,
30502 -- a subprogram declaration or is illegal.
30511 -- If we fall through, then the pragma was either the first declaration
30512 -- or it was preceded by other pragmas and no source constructs.
30514 -- The pragma is associated with a library-level subprogram
30516 if Nkind (Context) = N_Compilation_Unit_Aux then
30517 return Unit (Parent (Context));
30519 -- The pragma appears inside the declarations of an entry body
30521 elsif Nkind (Context) = N_Entry_Body then
30524 -- The pragma appears inside the statements of a subprogram body. This
30525 -- placement is the result of subprogram contract expansion.
30527 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30528 return Parent (Context);
30530 -- The pragma appears inside the declarative part of a package body
30532 elsif Nkind (Context) = N_Package_Body then
30535 -- The pragma appears inside the declarative part of a subprogram body
30537 elsif Nkind (Context) = N_Subprogram_Body then
30540 -- The pragma appears inside the declarative part of a task body
30542 elsif Nkind (Context) = N_Task_Body then
30545 -- The pragma appears inside the visible part of a package specification
30547 elsif Nkind (Context) = N_Package_Specification then
30548 return Parent (Context);
30550 -- The pragma is a byproduct of aspect expansion, return the related
30551 -- context of the original aspect. This case has a lower priority as
30552 -- the above circuitry pinpoints precisely the related context.
30554 elsif Present (Corresponding_Aspect (Prag)) then
30555 return Parent (Corresponding_Aspect (Prag));
30557 -- No candidate subprogram [body] found
30562 end Find_Related_Declaration_Or_Body;
30564 ----------------------------------
30565 -- Find_Related_Package_Or_Body --
30566 ----------------------------------
30568 function Find_Related_Package_Or_Body
30570 Do_Checks : Boolean := False) return Node_Id
30572 Context : constant Node_Id := Parent (Prag);
30573 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30577 Stmt := Prev (Prag);
30578 while Present (Stmt) loop
30580 -- Skip prior pragmas, but check for duplicates
30582 if Nkind (Stmt) = N_Pragma then
30583 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30589 -- Skip internally generated code
30591 elsif not Comes_From_Source (Stmt) then
30592 if Nkind (Stmt) = N_Subprogram_Declaration then
30594 -- The subprogram declaration is an internally generated spec
30595 -- for an expression function.
30597 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30600 -- The subprogram is actually an instance housed within an
30601 -- anonymous wrapper package.
30603 elsif Present (Generic_Parent (Specification (Stmt))) then
30608 -- Return the current source construct which is illegal
30617 -- If we fall through, then the pragma was either the first declaration
30618 -- or it was preceded by other pragmas and no source constructs.
30620 -- The pragma is associated with a package. The immediate context in
30621 -- this case is the specification of the package.
30623 if Nkind (Context) = N_Package_Specification then
30624 return Parent (Context);
30626 -- The pragma appears in the declarations of a package body
30628 elsif Nkind (Context) = N_Package_Body then
30631 -- The pragma appears in the statements of a package body
30633 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30634 and then Nkind (Parent (Context)) = N_Package_Body
30636 return Parent (Context);
30638 -- The pragma is a byproduct of aspect expansion, return the related
30639 -- context of the original aspect. This case has a lower priority as
30640 -- the above circuitry pinpoints precisely the related context.
30642 elsif Present (Corresponding_Aspect (Prag)) then
30643 return Parent (Corresponding_Aspect (Prag));
30645 -- No candidate package [body] found
30650 end Find_Related_Package_Or_Body;
30656 function Get_Argument
30658 Context_Id : Entity_Id := Empty) return Node_Id
30660 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30663 -- Use the expression of the original aspect when analyzing the template
30664 -- of a generic unit. In both cases the aspect's tree must be decorated
30665 -- to save the global references in the generic context.
30667 if From_Aspect_Specification (Prag)
30668 and then (Present (Context_Id) and then Is_Generic_Unit (Context_Id))
30670 return Corresponding_Aspect (Prag);
30672 -- Otherwise use the expression of the pragma
30674 elsif Present (Args) then
30675 return First (Args);
30682 -------------------------
30683 -- Get_Base_Subprogram --
30684 -------------------------
30686 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30688 -- Follow subprogram renaming chain
30690 if Is_Subprogram (Def_Id)
30691 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30692 N_Subprogram_Renaming_Declaration
30693 and then Present (Alias (Def_Id))
30695 return Alias (Def_Id);
30699 end Get_Base_Subprogram;
30701 -----------------------
30702 -- Get_SPARK_Mode_Type --
30703 -----------------------
30705 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30707 if N = Name_On then
30709 elsif N = Name_Off then
30712 -- Any other argument is illegal. Assume that no SPARK mode applies to
30713 -- avoid potential cascaded errors.
30718 end Get_SPARK_Mode_Type;
30720 ------------------------------------
30721 -- Get_SPARK_Mode_From_Annotation --
30722 ------------------------------------
30724 function Get_SPARK_Mode_From_Annotation
30725 (N : Node_Id) return SPARK_Mode_Type
30730 if Nkind (N) = N_Aspect_Specification then
30731 Mode := Expression (N);
30733 else pragma Assert (Nkind (N) = N_Pragma);
30734 Mode := First (Pragma_Argument_Associations (N));
30736 if Present (Mode) then
30737 Mode := Get_Pragma_Arg (Mode);
30741 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30743 if Present (Mode) then
30744 if Nkind (Mode) = N_Identifier then
30745 return Get_SPARK_Mode_Type (Chars (Mode));
30747 -- In case of a malformed aspect or pragma, return the default None
30753 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30758 end Get_SPARK_Mode_From_Annotation;
30760 ---------------------------
30761 -- Has_Extra_Parentheses --
30762 ---------------------------
30764 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30768 -- The aggregate should not have an expression list because a clause
30769 -- is always interpreted as a component association. The only way an
30770 -- expression list can sneak in is by adding extra parentheses around
30771 -- the individual clauses:
30773 -- Depends (Output => Input) -- proper form
30774 -- Depends ((Output => Input)) -- extra parentheses
30776 -- Since the extra parentheses are not allowed by the syntax of the
30777 -- pragma, flag them now to avoid emitting misleading errors down the
30780 if Nkind (Clause) = N_Aggregate
30781 and then Present (Expressions (Clause))
30783 Expr := First (Expressions (Clause));
30784 while Present (Expr) loop
30786 -- A dependency clause surrounded by extra parentheses appears
30787 -- as an aggregate of component associations with an optional
30788 -- Paren_Count set.
30790 if Nkind (Expr) = N_Aggregate
30791 and then Present (Component_Associations (Expr))
30794 ("dependency clause contains extra parentheses", Expr);
30796 -- Otherwise the expression is a malformed construct
30799 SPARK_Msg_N ("malformed dependency clause", Expr);
30809 end Has_Extra_Parentheses;
30815 procedure Initialize is
30818 Compile_Time_Warnings_Errors.Init;
30827 Dummy := Dummy + 1;
30830 -----------------------------
30831 -- Is_Config_Static_String --
30832 -----------------------------
30834 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30836 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30837 -- This is an internal recursive function that is just like the outer
30838 -- function except that it adds the string to the name buffer rather
30839 -- than placing the string in the name buffer.
30841 ------------------------------
30842 -- Add_Config_Static_String --
30843 ------------------------------
30845 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30852 if Nkind (N) = N_Op_Concat then
30853 if Add_Config_Static_String (Left_Opnd (N)) then
30854 N := Right_Opnd (N);
30860 if Nkind (N) /= N_String_Literal then
30861 Error_Msg_N ("string literal expected for pragma argument", N);
30865 for J in 1 .. String_Length (Strval (N)) loop
30866 C := Get_String_Char (Strval (N), J);
30868 if not In_Character_Range (C) then
30870 ("string literal contains invalid wide character",
30871 Sloc (N) + 1 + Source_Ptr (J));
30875 Add_Char_To_Name_Buffer (Get_Character (C));
30880 end Add_Config_Static_String;
30882 -- Start of processing for Is_Config_Static_String
30887 return Add_Config_Static_String (Arg);
30888 end Is_Config_Static_String;
30890 -------------------------------
30891 -- Is_Elaboration_SPARK_Mode --
30892 -------------------------------
30894 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30897 (Nkind (N) = N_Pragma
30898 and then Pragma_Name (N) = Name_SPARK_Mode
30899 and then Is_List_Member (N));
30901 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30902 -- appears in the statement part of the body.
30905 Present (Parent (N))
30906 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30907 and then List_Containing (N) = Statements (Parent (N))
30908 and then Present (Parent (Parent (N)))
30909 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30910 end Is_Elaboration_SPARK_Mode;
30912 -----------------------
30913 -- Is_Enabled_Pragma --
30914 -----------------------
30916 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30920 if Present (Prag) then
30921 Arg := First (Pragma_Argument_Associations (Prag));
30923 if Present (Arg) then
30924 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30926 -- The lack of a Boolean argument automatically enables the pragma
30932 -- The pragma is missing, therefore it is not enabled
30937 end Is_Enabled_Pragma;
30939 -----------------------------------------
30940 -- Is_Non_Significant_Pragma_Reference --
30941 -----------------------------------------
30943 -- This function makes use of the following static table which indicates
30944 -- whether appearance of some name in a given pragma is to be considered
30945 -- as a reference for the purposes of warnings about unreferenced objects.
30947 -- -1 indicates that appearence in any argument is significant
30948 -- 0 indicates that appearance in any argument is not significant
30949 -- +n indicates that appearance as argument n is significant, but all
30950 -- other arguments are not significant
30951 -- 9n arguments from n on are significant, before n insignificant
30953 Sig_Flags : constant array (Pragma_Id) of Int :=
30954 (Pragma_Abort_Defer => -1,
30955 Pragma_Abstract_State => -1,
30956 Pragma_Ada_83 => -1,
30957 Pragma_Ada_95 => -1,
30958 Pragma_Ada_05 => -1,
30959 Pragma_Ada_2005 => -1,
30960 Pragma_Ada_12 => -1,
30961 Pragma_Ada_2012 => -1,
30962 Pragma_Ada_2020 => -1,
30963 Pragma_Aggregate_Individually_Assign => 0,
30964 Pragma_All_Calls_Remote => -1,
30965 Pragma_Allow_Integer_Address => -1,
30966 Pragma_Annotate => 93,
30967 Pragma_Assert => -1,
30968 Pragma_Assert_And_Cut => -1,
30969 Pragma_Assertion_Policy => 0,
30970 Pragma_Assume => -1,
30971 Pragma_Assume_No_Invalid_Values => 0,
30972 Pragma_Async_Readers => 0,
30973 Pragma_Async_Writers => 0,
30974 Pragma_Asynchronous => 0,
30975 Pragma_Atomic => 0,
30976 Pragma_Atomic_Components => 0,
30977 Pragma_Attach_Handler => -1,
30978 Pragma_Attribute_Definition => 92,
30979 Pragma_Check => -1,
30980 Pragma_Check_Float_Overflow => 0,
30981 Pragma_Check_Name => 0,
30982 Pragma_Check_Policy => 0,
30983 Pragma_CPP_Class => 0,
30984 Pragma_CPP_Constructor => 0,
30985 Pragma_CPP_Virtual => 0,
30986 Pragma_CPP_Vtable => 0,
30988 Pragma_C_Pass_By_Copy => 0,
30989 Pragma_Comment => -1,
30990 Pragma_Common_Object => 0,
30991 Pragma_CUDA_Execute => -1,
30992 Pragma_CUDA_Global => -1,
30993 Pragma_Compile_Time_Error => -1,
30994 Pragma_Compile_Time_Warning => -1,
30995 Pragma_Compiler_Unit => -1,
30996 Pragma_Compiler_Unit_Warning => -1,
30997 Pragma_Complete_Representation => 0,
30998 Pragma_Complex_Representation => 0,
30999 Pragma_Component_Alignment => 0,
31000 Pragma_Constant_After_Elaboration => 0,
31001 Pragma_Contract_Cases => -1,
31002 Pragma_Controlled => 0,
31003 Pragma_Convention => 0,
31004 Pragma_Convention_Identifier => 0,
31005 Pragma_Deadline_Floor => -1,
31006 Pragma_Debug => -1,
31007 Pragma_Debug_Policy => 0,
31008 Pragma_Default_Initial_Condition => -1,
31009 Pragma_Default_Scalar_Storage_Order => 0,
31010 Pragma_Default_Storage_Pool => 0,
31011 Pragma_Depends => -1,
31012 Pragma_Detect_Blocking => 0,
31013 Pragma_Disable_Atomic_Synchronization => 0,
31014 Pragma_Discard_Names => 0,
31015 Pragma_Dispatching_Domain => -1,
31016 Pragma_Effective_Reads => 0,
31017 Pragma_Effective_Writes => 0,
31018 Pragma_Elaborate => 0,
31019 Pragma_Elaborate_All => 0,
31020 Pragma_Elaborate_Body => 0,
31021 Pragma_Elaboration_Checks => 0,
31022 Pragma_Eliminate => 0,
31023 Pragma_Enable_Atomic_Synchronization => 0,
31024 Pragma_Export => -1,
31025 Pragma_Export_Function => -1,
31026 Pragma_Export_Object => -1,
31027 Pragma_Export_Procedure => -1,
31028 Pragma_Export_Value => -1,
31029 Pragma_Export_Valued_Procedure => -1,
31030 Pragma_Extend_System => -1,
31031 Pragma_Extensions_Allowed => 0,
31032 Pragma_Extensions_Visible => 0,
31033 Pragma_External => -1,
31034 Pragma_External_Name_Casing => 0,
31035 Pragma_Fast_Math => 0,
31036 Pragma_Favor_Top_Level => 0,
31037 Pragma_Finalize_Storage_Only => 0,
31039 Pragma_Global => -1,
31040 Pragma_Ident => -1,
31041 Pragma_Ignore_Pragma => 0,
31042 Pragma_Implementation_Defined => -1,
31043 Pragma_Implemented => -1,
31044 Pragma_Implicit_Packing => 0,
31045 Pragma_Import => 93,
31046 Pragma_Import_Function => 0,
31047 Pragma_Import_Object => 0,
31048 Pragma_Import_Procedure => 0,
31049 Pragma_Import_Valued_Procedure => 0,
31050 Pragma_Independent => 0,
31051 Pragma_Independent_Components => 0,
31052 Pragma_Initial_Condition => -1,
31053 Pragma_Initialize_Scalars => 0,
31054 Pragma_Initializes => -1,
31055 Pragma_Inline => 0,
31056 Pragma_Inline_Always => 0,
31057 Pragma_Inline_Generic => 0,
31058 Pragma_Inspection_Point => -1,
31059 Pragma_Interface => 92,
31060 Pragma_Interface_Name => 0,
31061 Pragma_Interrupt_Handler => -1,
31062 Pragma_Interrupt_Priority => -1,
31063 Pragma_Interrupt_State => -1,
31064 Pragma_Invariant => -1,
31065 Pragma_Keep_Names => 0,
31066 Pragma_License => 0,
31067 Pragma_Link_With => -1,
31068 Pragma_Linker_Alias => -1,
31069 Pragma_Linker_Constructor => -1,
31070 Pragma_Linker_Destructor => -1,
31071 Pragma_Linker_Options => -1,
31072 Pragma_Linker_Section => -1,
31074 Pragma_Lock_Free => 0,
31075 Pragma_Locking_Policy => 0,
31076 Pragma_Loop_Invariant => -1,
31077 Pragma_Loop_Optimize => 0,
31078 Pragma_Loop_Variant => -1,
31079 Pragma_Machine_Attribute => -1,
31081 Pragma_Main_Storage => -1,
31082 Pragma_Max_Entry_Queue_Depth => 0,
31083 Pragma_Max_Entry_Queue_Length => 0,
31084 Pragma_Max_Queue_Length => 0,
31085 Pragma_Memory_Size => 0,
31086 Pragma_No_Body => 0,
31087 Pragma_No_Caching => 0,
31088 Pragma_No_Component_Reordering => -1,
31089 Pragma_No_Elaboration_Code_All => 0,
31090 Pragma_No_Heap_Finalization => 0,
31091 Pragma_No_Inline => 0,
31092 Pragma_No_Return => 0,
31093 Pragma_No_Run_Time => -1,
31094 Pragma_No_Strict_Aliasing => -1,
31095 Pragma_No_Tagged_Streams => 0,
31096 Pragma_Normalize_Scalars => 0,
31097 Pragma_Obsolescent => 0,
31098 Pragma_Optimize => 0,
31099 Pragma_Optimize_Alignment => 0,
31100 Pragma_Ordered => 0,
31101 Pragma_Overflow_Mode => 0,
31102 Pragma_Overriding_Renamings => 0,
31105 Pragma_Part_Of => 0,
31106 Pragma_Partition_Elaboration_Policy => 0,
31107 Pragma_Passive => 0,
31108 Pragma_Persistent_BSS => 0,
31110 Pragma_Postcondition => -1,
31111 Pragma_Post_Class => -1,
31113 Pragma_Precondition => -1,
31114 Pragma_Predicate => -1,
31115 Pragma_Predicate_Failure => -1,
31116 Pragma_Preelaborable_Initialization => -1,
31117 Pragma_Preelaborate => 0,
31118 Pragma_Prefix_Exception_Messages => 0,
31119 Pragma_Pre_Class => -1,
31120 Pragma_Priority => -1,
31121 Pragma_Priority_Specific_Dispatching => 0,
31122 Pragma_Profile => 0,
31123 Pragma_Profile_Warnings => 0,
31124 Pragma_Propagate_Exceptions => 0,
31125 Pragma_Provide_Shift_Operators => 0,
31126 Pragma_Psect_Object => 0,
31128 Pragma_Pure_Function => 0,
31129 Pragma_Queuing_Policy => 0,
31130 Pragma_Rational => 0,
31131 Pragma_Ravenscar => 0,
31132 Pragma_Refined_Depends => -1,
31133 Pragma_Refined_Global => -1,
31134 Pragma_Refined_Post => -1,
31135 Pragma_Refined_State => -1,
31136 Pragma_Relative_Deadline => 0,
31137 Pragma_Remote_Access_Type => -1,
31138 Pragma_Remote_Call_Interface => -1,
31139 Pragma_Remote_Types => -1,
31140 Pragma_Rename_Pragma => 0,
31141 Pragma_Restricted_Run_Time => 0,
31142 Pragma_Restriction_Warnings => 0,
31143 Pragma_Restrictions => 0,
31144 Pragma_Reviewable => -1,
31145 Pragma_Secondary_Stack_Size => -1,
31146 Pragma_Share_Generic => 0,
31147 Pragma_Shared => 0,
31148 Pragma_Shared_Passive => 0,
31149 Pragma_Short_Circuit_And_Or => 0,
31150 Pragma_Short_Descriptors => 0,
31151 Pragma_Simple_Storage_Pool_Type => 0,
31152 Pragma_Source_File_Name => 0,
31153 Pragma_Source_File_Name_Project => 0,
31154 Pragma_Source_Reference => 0,
31155 Pragma_SPARK_Mode => 0,
31156 Pragma_Static_Elaboration_Desired => 0,
31157 Pragma_Storage_Size => -1,
31158 Pragma_Storage_Unit => 0,
31159 Pragma_Stream_Convert => 0,
31160 Pragma_Style_Checks => 0,
31161 Pragma_Subprogram_Variant => -1,
31162 Pragma_Subtitle => 0,
31163 Pragma_Suppress => 0,
31164 Pragma_Suppress_All => 0,
31165 Pragma_Suppress_Debug_Info => 0,
31166 Pragma_Suppress_Exception_Locations => 0,
31167 Pragma_Suppress_Initialization => 0,
31168 Pragma_System_Name => 0,
31169 Pragma_Task_Dispatching_Policy => 0,
31170 Pragma_Task_Info => -1,
31171 Pragma_Task_Name => -1,
31172 Pragma_Task_Storage => -1,
31173 Pragma_Test_Case => -1,
31174 Pragma_Thread_Local_Storage => -1,
31175 Pragma_Time_Slice => -1,
31177 Pragma_Type_Invariant => -1,
31178 Pragma_Type_Invariant_Class => -1,
31179 Pragma_Unchecked_Union => 0,
31180 Pragma_Unevaluated_Use_Of_Old => 0,
31181 Pragma_Unimplemented_Unit => 0,
31182 Pragma_Universal_Aliasing => 0,
31183 Pragma_Universal_Data => 0,
31184 Pragma_Unmodified => 0,
31185 Pragma_Unreferenced => 0,
31186 Pragma_Unreferenced_Objects => 0,
31187 Pragma_Unreserve_All_Interrupts => 0,
31188 Pragma_Unsuppress => 0,
31189 Pragma_Unused => 0,
31190 Pragma_Use_VADS_Size => 0,
31191 Pragma_Validity_Checks => 0,
31192 Pragma_Volatile => 0,
31193 Pragma_Volatile_Components => 0,
31194 Pragma_Volatile_Full_Access => 0,
31195 Pragma_Volatile_Function => 0,
31196 Pragma_Warning_As_Error => 0,
31197 Pragma_Warnings => 0,
31198 Pragma_Weak_External => 0,
31199 Pragma_Wide_Character_Encoding => 0,
31200 Unknown_Pragma => 0);
31202 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31208 function Arg_No return Nat;
31209 -- Returns an integer showing what argument we are in. A value of
31210 -- zero means we are not in any of the arguments.
31216 function Arg_No return Nat is
31221 A := First (Pragma_Argument_Associations (Parent (P)));
31235 -- Start of processing for Non_Significant_Pragma_Reference
31240 if Nkind (P) /= N_Pragma_Argument_Association then
31244 Id := Get_Pragma_Id (Parent (P));
31245 C := Sig_Flags (Id);
31260 return AN < (C - 90);
31266 end Is_Non_Significant_Pragma_Reference;
31268 ------------------------------
31269 -- Is_Pragma_String_Literal --
31270 ------------------------------
31272 -- This function returns true if the corresponding pragma argument is a
31273 -- static string expression. These are the only cases in which string
31274 -- literals can appear as pragma arguments. We also allow a string literal
31275 -- as the first argument to pragma Assert (although it will of course
31276 -- always generate a type error).
31278 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31279 Pragn : constant Node_Id := Parent (Par);
31280 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31281 Pname : constant Name_Id := Pragma_Name (Pragn);
31287 N := First (Assoc);
31294 if Pname = Name_Assert then
31297 elsif Pname = Name_Export then
31300 elsif Pname = Name_Ident then
31303 elsif Pname = Name_Import then
31306 elsif Pname = Name_Interface_Name then
31309 elsif Pname = Name_Linker_Alias then
31312 elsif Pname = Name_Linker_Section then
31315 elsif Pname = Name_Machine_Attribute then
31318 elsif Pname = Name_Source_File_Name then
31321 elsif Pname = Name_Source_Reference then
31324 elsif Pname = Name_Title then
31327 elsif Pname = Name_Subtitle then
31333 end Is_Pragma_String_Literal;
31335 ---------------------------
31336 -- Is_Private_SPARK_Mode --
31337 ---------------------------
31339 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31342 (Nkind (N) = N_Pragma
31343 and then Pragma_Name (N) = Name_SPARK_Mode
31344 and then Is_List_Member (N));
31346 -- For pragma SPARK_Mode to be private, it has to appear in the private
31347 -- declarations of a package.
31350 Present (Parent (N))
31351 and then Nkind (Parent (N)) = N_Package_Specification
31352 and then List_Containing (N) = Private_Declarations (Parent (N));
31353 end Is_Private_SPARK_Mode;
31355 -------------------------------------
31356 -- Is_Unconstrained_Or_Tagged_Item --
31357 -------------------------------------
31359 function Is_Unconstrained_Or_Tagged_Item
31360 (Item : Entity_Id) return Boolean
31362 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31363 -- Determine whether record type Typ has at least one unconstrained
31366 ---------------------------------
31367 -- Has_Unconstrained_Component --
31368 ---------------------------------
31370 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31374 Comp := First_Component (Typ);
31375 while Present (Comp) loop
31376 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31380 Next_Component (Comp);
31384 end Has_Unconstrained_Component;
31388 Typ : constant Entity_Id := Etype (Item);
31390 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31393 if Is_Tagged_Type (Typ) then
31396 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31399 elsif Is_Record_Type (Typ) then
31400 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31403 return Has_Unconstrained_Component (Typ);
31406 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31412 end Is_Unconstrained_Or_Tagged_Item;
31414 -----------------------------
31415 -- Is_Valid_Assertion_Kind --
31416 -----------------------------
31418 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31425 | Name_Assertion_Policy
31426 | Name_Static_Predicate
31427 | Name_Dynamic_Predicate
31432 | Name_Type_Invariant
31433 | Name_uType_Invariant
31437 | Name_Assert_And_Cut
31439 | Name_Contract_Cases
31441 | Name_Default_Initial_Condition
31443 | Name_Initial_Condition
31446 | Name_Loop_Invariant
31447 | Name_Loop_Variant
31448 | Name_Postcondition
31449 | Name_Precondition
31451 | Name_Refined_Post
31452 | Name_Statement_Assertions
31453 | Name_Subprogram_Variant
31460 end Is_Valid_Assertion_Kind;
31462 --------------------------------------
31463 -- Process_Compilation_Unit_Pragmas --
31464 --------------------------------------
31466 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31468 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31469 -- strange because it comes at the end of the unit. Rational has the
31470 -- same name for a pragma, but treats it as a program unit pragma, In
31471 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31472 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31473 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31474 -- the context clause to ensure the correct processing.
31476 if Has_Pragma_Suppress_All (N) then
31477 Prepend_To (Context_Items (N),
31478 Make_Pragma (Sloc (N),
31479 Chars => Name_Suppress,
31480 Pragma_Argument_Associations => New_List (
31481 Make_Pragma_Argument_Association (Sloc (N),
31482 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31485 -- Nothing else to do at the current time
31487 end Process_Compilation_Unit_Pragmas;
31489 --------------------------------------------
31490 -- Validate_Compile_Time_Warning_Or_Error --
31491 --------------------------------------------
31493 procedure Validate_Compile_Time_Warning_Or_Error
31497 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31498 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31499 Arg2 : constant Node_Id := Next (Arg1);
31501 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31502 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31505 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31507 if Compile_Time_Known_Value (Arg1x) then
31508 if Is_True (Expr_Value (Arg1x)) then
31510 -- We have already verified that the second argument is a static
31511 -- string expression. Its string value must be retrieved
31512 -- explicitly if it is a declared constant, otherwise it has
31513 -- been constant-folded previously.
31516 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31517 Str : constant String_Id :=
31518 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31519 Str_Len : constant Nat := String_Length (Str);
31521 Force : constant Boolean :=
31522 Prag_Id = Pragma_Compile_Time_Warning
31523 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31524 and then (Ekind (Cent) /= E_Package
31525 or else not In_Private_Part (Cent));
31526 -- Set True if this is the warning case, and we are in the
31527 -- visible part of a package spec, or in a subprogram spec,
31528 -- in which case we want to force the client to see the
31529 -- warning, even though it is not in the main unit.
31537 -- Loop through segments of message separated by line feeds.
31538 -- We output these segments as separate messages with
31539 -- continuation marks for all but the first.
31544 Error_Msg_Strlen := 0;
31546 -- Loop to copy characters from argument to error message
31550 exit when Ptr > Str_Len;
31551 CC := Get_String_Char (Str, Ptr);
31554 -- Ignore wide chars ??? else store character
31556 if In_Character_Range (CC) then
31557 C := Get_Character (CC);
31558 exit when C = ASCII.LF;
31559 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31560 Error_Msg_String (Error_Msg_Strlen) := C;
31564 -- Here with one line ready to go
31566 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31568 -- If this is a warning in a spec, then we want clients
31569 -- to see the warning, so mark the message with the
31570 -- special sequence !! to force the warning. In the case
31571 -- of a package spec, we do not force this if we are in
31572 -- the private part of the spec.
31575 if Cont = False then
31577 ("<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31581 ("\<<~!!", Eloc, Is_Compile_Time_Pragma => True);
31584 -- Error, rather than warning, or in a body, so we do not
31585 -- need to force visibility for client (error will be
31586 -- output in any case, and this is the situation in which
31587 -- we do not want a client to get a warning, since the
31588 -- warning is in the body or the spec private part).
31591 if Cont = False then
31593 ("<<~", Eloc, Is_Compile_Time_Pragma => True);
31597 ("\<<~", Eloc, Is_Compile_Time_Pragma => True);
31601 exit when Ptr > Str_Len;
31606 -- Arg1x is not known at compile time, so possibly issue an error
31607 -- or warning. This can happen only if the pragma's processing
31608 -- was deferred until after the back end is run (see
31609 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
31610 -- control switch applies to only the warning case.
31612 elsif Prag_Id = Pragma_Compile_Time_Error then
31613 Error_Msg_N ("condition is not known at compile time", Arg1x);
31615 elsif Warn_On_Unknown_Compile_Time_Warning then
31616 Error_Msg_N ("??condition is not known at compile time", Arg1x);
31618 end Validate_Compile_Time_Warning_Or_Error;
31620 ------------------------------------
31621 -- Record_Possible_Body_Reference --
31622 ------------------------------------
31624 procedure Record_Possible_Body_Reference
31625 (State_Id : Entity_Id;
31629 Spec_Id : Entity_Id;
31632 -- Ensure that we are dealing with a reference to a state
31634 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31636 -- Climb the tree starting from the reference looking for a package body
31637 -- whose spec declares the referenced state. This criteria automatically
31638 -- excludes references in package specs which are legal. Note that it is
31639 -- not wise to emit an error now as the package body may lack pragma
31640 -- Refined_State or the referenced state may not be mentioned in the
31641 -- refinement. This approach avoids the generation of misleading errors.
31644 while Present (Context) loop
31645 if Nkind (Context) = N_Package_Body then
31646 Spec_Id := Corresponding_Spec (Context);
31648 if Present (Abstract_States (Spec_Id))
31649 and then Contains (Abstract_States (Spec_Id), State_Id)
31651 if No (Body_References (State_Id)) then
31652 Set_Body_References (State_Id, New_Elmt_List);
31655 Append_Elmt (Ref, To => Body_References (State_Id));
31660 Context := Parent (Context);
31662 end Record_Possible_Body_Reference;
31664 ------------------------------------------
31665 -- Relocate_Pragmas_To_Anonymous_Object --
31666 ------------------------------------------
31668 procedure Relocate_Pragmas_To_Anonymous_Object
31669 (Typ_Decl : Node_Id;
31670 Obj_Decl : Node_Id)
31674 Next_Decl : Node_Id;
31677 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31678 Def := Protected_Definition (Typ_Decl);
31680 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31681 Def := Task_Definition (Typ_Decl);
31684 -- The concurrent definition has a visible declaration list. Inspect it
31685 -- and relocate all canidate pragmas.
31687 if Present (Def) and then Present (Visible_Declarations (Def)) then
31688 Decl := First (Visible_Declarations (Def));
31689 while Present (Decl) loop
31691 -- Preserve the following declaration for iteration purposes due
31692 -- to possible relocation of a pragma.
31694 Next_Decl := Next (Decl);
31696 if Nkind (Decl) = N_Pragma
31697 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31700 Insert_After (Obj_Decl, Decl);
31702 -- Skip internally generated code
31704 elsif not Comes_From_Source (Decl) then
31707 -- No candidate pragmas are available for relocation
31716 end Relocate_Pragmas_To_Anonymous_Object;
31718 ------------------------------
31719 -- Relocate_Pragmas_To_Body --
31720 ------------------------------
31722 procedure Relocate_Pragmas_To_Body
31723 (Subp_Body : Node_Id;
31724 Target_Body : Node_Id := Empty)
31726 procedure Relocate_Pragma (Prag : Node_Id);
31727 -- Remove a single pragma from its current list and add it to the
31728 -- declarations of the proper body (either Subp_Body or Target_Body).
31730 ---------------------
31731 -- Relocate_Pragma --
31732 ---------------------
31734 procedure Relocate_Pragma (Prag : Node_Id) is
31739 -- When subprogram stubs or expression functions are involves, the
31740 -- destination declaration list belongs to the proper body.
31742 if Present (Target_Body) then
31743 Target := Target_Body;
31745 Target := Subp_Body;
31748 Decls := Declarations (Target);
31752 Set_Declarations (Target, Decls);
31755 -- Unhook the pragma from its current list
31758 Prepend (Prag, Decls);
31759 end Relocate_Pragma;
31763 Body_Id : constant Entity_Id :=
31764 Defining_Unit_Name (Specification (Subp_Body));
31765 Next_Stmt : Node_Id;
31768 -- Start of processing for Relocate_Pragmas_To_Body
31771 -- Do not process a body that comes from a separate unit as no construct
31772 -- can possibly follow it.
31774 if not Is_List_Member (Subp_Body) then
31777 -- Do not relocate pragmas that follow a stub if the stub does not have
31780 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31781 and then No (Target_Body)
31785 -- Do not process internally generated routine _Postconditions
31787 elsif Ekind (Body_Id) = E_Procedure
31788 and then Chars (Body_Id) = Name_uPostconditions
31793 -- Look at what is following the body. We are interested in certain kind
31794 -- of pragmas (either from source or byproducts of expansion) that can
31795 -- apply to a body [stub].
31797 Stmt := Next (Subp_Body);
31798 while Present (Stmt) loop
31800 -- Preserve the following statement for iteration purposes due to a
31801 -- possible relocation of a pragma.
31803 Next_Stmt := Next (Stmt);
31805 -- Move a candidate pragma following the body to the declarations of
31808 if Nkind (Stmt) = N_Pragma
31809 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31812 -- If a source pragma Warnings follows the body, it applies to
31813 -- following statements and does not belong in the body.
31815 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31816 and then Comes_From_Source (Stmt)
31820 Relocate_Pragma (Stmt);
31823 -- Skip internally generated code
31825 elsif not Comes_From_Source (Stmt) then
31828 -- No candidate pragmas are available for relocation
31836 end Relocate_Pragmas_To_Body;
31838 -------------------
31839 -- Resolve_State --
31840 -------------------
31842 procedure Resolve_State (N : Node_Id) is
31847 if Is_Entity_Name (N) and then Present (Entity (N)) then
31848 Func := Entity (N);
31850 -- Handle overloading of state names by functions. Traverse the
31851 -- homonym chain looking for an abstract state.
31853 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31854 pragma Assert (Is_Overloaded (N));
31856 State := Homonym (Func);
31857 while Present (State) loop
31858 if Ekind (State) = E_Abstract_State then
31860 -- Resolve the overloading by setting the proper entity of
31861 -- the reference to that of the state.
31863 Set_Etype (N, Standard_Void_Type);
31864 Set_Entity (N, State);
31865 Set_Is_Overloaded (N, False);
31867 Generate_Reference (State, N);
31871 State := Homonym (State);
31874 -- A function can never act as a state. If the homonym chain does
31875 -- not contain a corresponding state, then something went wrong in
31876 -- the overloading mechanism.
31878 raise Program_Error;
31883 ----------------------------
31884 -- Rewrite_Assertion_Kind --
31885 ----------------------------
31887 procedure Rewrite_Assertion_Kind
31889 From_Policy : Boolean := False)
31895 if Nkind (N) = N_Attribute_Reference
31896 and then Attribute_Name (N) = Name_Class
31897 and then Nkind (Prefix (N)) = N_Identifier
31899 case Chars (Prefix (N)) is
31906 when Name_Type_Invariant =>
31907 Nam := Name_uType_Invariant;
31909 when Name_Invariant =>
31910 Nam := Name_uInvariant;
31916 -- Recommend standard use of aspect names Pre/Post
31918 elsif Nkind (N) = N_Identifier
31919 and then From_Policy
31920 and then Serious_Errors_Detected = 0
31922 if Chars (N) = Name_Precondition
31923 or else Chars (N) = Name_Postcondition
31925 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31927 ("\use Assertion_Policy and aspect names Pre/Post for "
31928 & "Ada2012 conformance?", N);
31934 if Nam /= No_Name then
31935 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31937 end Rewrite_Assertion_Kind;
31945 Dummy := Dummy + 1;
31948 --------------------------------
31949 -- Set_Encoded_Interface_Name --
31950 --------------------------------
31952 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31953 Str : constant String_Id := Strval (S);
31954 Len : constant Nat := String_Length (Str);
31959 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31962 -- Stores encoded value of character code CC. The encoding we use an
31963 -- underscore followed by four lower case hex digits.
31969 procedure Encode is
31971 Store_String_Char (Get_Char_Code ('_'));
31973 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31975 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31977 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31979 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31982 -- Start of processing for Set_Encoded_Interface_Name
31985 -- If first character is asterisk, this is a link name, and we leave it
31986 -- completely unmodified. We also ignore null strings (the latter case
31987 -- happens only in error cases).
31990 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31992 Set_Interface_Name (E, S);
31997 CC := Get_String_Char (Str, J);
31999 exit when not In_Character_Range (CC);
32001 C := Get_Character (CC);
32003 exit when C /= '_' and then C /= '$'
32004 and then C not in '0' .. '9'
32005 and then C not in 'a' .. 'z'
32006 and then C not in 'A' .. 'Z';
32009 Set_Interface_Name (E, S);
32017 -- Here we need to encode. The encoding we use as follows:
32018 -- three underscores + four hex digits (lower case)
32022 for J in 1 .. String_Length (Str) loop
32023 CC := Get_String_Char (Str, J);
32025 if not In_Character_Range (CC) then
32028 C := Get_Character (CC);
32030 if C = '_' or else C = '$'
32031 or else C in '0' .. '9'
32032 or else C in 'a' .. 'z'
32033 or else C in 'A' .. 'Z'
32035 Store_String_Char (CC);
32042 Set_Interface_Name (E,
32043 Make_String_Literal (Sloc (S),
32044 Strval => End_String));
32046 end Set_Encoded_Interface_Name;
32048 ------------------------
32049 -- Set_Elab_Unit_Name --
32050 ------------------------
32052 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32057 if Nkind (N) = N_Identifier
32058 and then Nkind (With_Item) = N_Identifier
32060 Set_Entity (N, Entity (With_Item));
32062 elsif Nkind (N) = N_Selected_Component then
32063 Change_Selected_Component_To_Expanded_Name (N);
32064 Set_Entity (N, Entity (With_Item));
32065 Set_Entity (Selector_Name (N), Entity (N));
32067 Pref := Prefix (N);
32068 Scop := Scope (Entity (N));
32069 while Nkind (Pref) = N_Selected_Component loop
32070 Change_Selected_Component_To_Expanded_Name (Pref);
32071 Set_Entity (Selector_Name (Pref), Scop);
32072 Set_Entity (Pref, Scop);
32073 Pref := Prefix (Pref);
32074 Scop := Scope (Scop);
32077 Set_Entity (Pref, Scop);
32080 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32081 end Set_Elab_Unit_Name;
32083 -----------------------
32084 -- Set_Overflow_Mode --
32085 -----------------------
32087 procedure Set_Overflow_Mode (N : Node_Id) is
32089 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type;
32090 -- Function to process one pragma argument, Arg
32092 -----------------------
32093 -- Get_Overflow_Mode --
32094 -----------------------
32096 function Get_Overflow_Mode (Arg : Node_Id) return Overflow_Mode_Type is
32097 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
32100 if Chars (Argx) = Name_Strict then
32103 elsif Chars (Argx) = Name_Minimized then
32106 elsif Chars (Argx) = Name_Eliminated then
32110 raise Program_Error;
32112 end Get_Overflow_Mode;
32116 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32117 Arg2 : constant Node_Id := Next (Arg1);
32119 -- Start of processing for Set_Overflow_Mode
32122 -- Process first argument
32124 Scope_Suppress.Overflow_Mode_General :=
32125 Get_Overflow_Mode (Arg1);
32127 -- Case of only one argument
32130 Scope_Suppress.Overflow_Mode_Assertions :=
32131 Scope_Suppress.Overflow_Mode_General;
32133 -- Case of two arguments present
32136 Scope_Suppress.Overflow_Mode_Assertions :=
32137 Get_Overflow_Mode (Arg2);
32139 end Set_Overflow_Mode;
32141 -------------------
32142 -- Test_Case_Arg --
32143 -------------------
32145 function Test_Case_Arg
32148 From_Aspect : Boolean := False) return Node_Id
32150 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32156 (Arg_Nam in Name_Ensures | Name_Mode | Name_Name | Name_Requires);
32158 -- The caller requests the aspect argument
32160 if From_Aspect then
32161 if Present (Aspect)
32162 and then Nkind (Expression (Aspect)) = N_Aggregate
32164 Args := Expression (Aspect);
32166 -- "Name" and "Mode" may appear without an identifier as a
32167 -- positional association.
32169 if Present (Expressions (Args)) then
32170 Arg := First (Expressions (Args));
32172 if Present (Arg) and then Arg_Nam = Name_Name then
32180 if Present (Arg) and then Arg_Nam = Name_Mode then
32185 -- Some or all arguments may appear as component associatons
32187 if Present (Component_Associations (Args)) then
32188 Arg := First (Component_Associations (Args));
32189 while Present (Arg) loop
32190 if Chars (First (Choices (Arg))) = Arg_Nam then
32199 -- Otherwise retrieve the argument directly from the pragma
32202 Arg := First (Pragma_Argument_Associations (Prag));
32204 if Present (Arg) and then Arg_Nam = Name_Name then
32208 -- Skip argument "Name"
32212 if Present (Arg) and then Arg_Nam = Name_Mode then
32216 -- Skip argument "Mode"
32220 -- Arguments "Requires" and "Ensures" are optional and may not be
32223 while Present (Arg) loop
32224 if Chars (Arg) = Arg_Nam then
32235 --------------------------------------------
32236 -- Defer_Compile_Time_Warning_Error_To_BE --
32237 --------------------------------------------
32239 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is
32240 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
32242 Compile_Time_Warnings_Errors.Append
32243 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
32244 Scope => Current_Scope,
32247 -- If the Boolean expression contains T'Size, and we're not in the main
32248 -- unit being compiled, then we need to copy the pragma into the main
32249 -- unit, because otherwise T'Size might never be computed, leaving it
32252 if not In_Extended_Main_Code_Unit (N) then
32253 Insert_Library_Level_Action (New_Copy_Tree (N));
32255 end Defer_Compile_Time_Warning_Error_To_BE;
32257 ------------------------------------------
32258 -- Validate_Compile_Time_Warning_Errors --
32259 ------------------------------------------
32261 procedure Validate_Compile_Time_Warning_Errors is
32262 procedure Set_Scope (S : Entity_Id);
32263 -- Install all enclosing scopes of S along with S itself
32265 procedure Unset_Scope (S : Entity_Id);
32266 -- Uninstall all enclosing scopes of S along with S itself
32272 procedure Set_Scope (S : Entity_Id) is
32274 if S /= Standard_Standard then
32275 Set_Scope (Scope (S));
32285 procedure Unset_Scope (S : Entity_Id) is
32287 if S /= Standard_Standard then
32288 Unset_Scope (Scope (S));
32294 -- Start of processing for Validate_Compile_Time_Warning_Errors
32297 Expander_Mode_Save_And_Set (False);
32298 In_Compile_Time_Warning_Or_Error := True;
32300 for N in Compile_Time_Warnings_Errors.First ..
32301 Compile_Time_Warnings_Errors.Last
32304 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32307 Set_Scope (T.Scope);
32308 Reset_Analyzed_Flags (T.Prag);
32309 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32310 Unset_Scope (T.Scope);
32314 In_Compile_Time_Warning_Or_Error := False;
32315 Expander_Mode_Restore;
32316 end Validate_Compile_Time_Warning_Errors;