1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects; use Aspects;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Checks; use Checks;
36 with Contracts; use Contracts;
37 with Csets; use Csets;
38 with Debug; use Debug;
39 with Einfo; use Einfo;
40 with Elists; use Elists;
41 with Errout; use Errout;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Util; use Exp_Util;
44 with Expander; use Expander;
45 with Freeze; use Freeze;
46 with Ghost; use Ghost;
47 with Gnatvsn; use Gnatvsn;
49 with Lib.Writ; use Lib.Writ;
50 with Lib.Xref; use Lib.Xref;
51 with Namet.Sp; use Namet.Sp;
52 with Nlists; use Nlists;
53 with Nmake; use Nmake;
54 with Output; use Output;
55 with Par_SCO; use Par_SCO;
56 with Restrict; use Restrict;
57 with Rident; use Rident;
58 with Rtsfind; use Rtsfind;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch3; use Sem_Ch3;
62 with Sem_Ch6; use Sem_Ch6;
63 with Sem_Ch8; use Sem_Ch8;
64 with Sem_Ch12; use Sem_Ch12;
65 with Sem_Ch13; use Sem_Ch13;
66 with Sem_Disp; use Sem_Disp;
67 with Sem_Dist; use Sem_Dist;
68 with Sem_Elab; use Sem_Elab;
69 with Sem_Elim; use Sem_Elim;
70 with Sem_Eval; use Sem_Eval;
71 with Sem_Intr; use Sem_Intr;
72 with Sem_Mech; use Sem_Mech;
73 with Sem_Res; use Sem_Res;
74 with Sem_Type; use Sem_Type;
75 with Sem_Util; use Sem_Util;
76 with Sem_Warn; use Sem_Warn;
77 with Stand; use Stand;
78 with Sinfo; use Sinfo;
79 with Sinfo.CN; use Sinfo.CN;
80 with Sinput; use Sinput;
81 with Stringt; use Stringt;
82 with Stylesw; use Stylesw;
84 with Targparm; use Targparm;
85 with Tbuild; use Tbuild;
87 with Uintp; use Uintp;
88 with Uname; use Uname;
89 with Urealp; use Urealp;
90 with Validsw; use Validsw;
91 with Warnsw; use Warnsw;
93 with System.Case_Util;
95 package body Sem_Prag is
97 ----------------------------------------------
98 -- Common Handling of Import-Export Pragmas --
99 ----------------------------------------------
101 -- In the following section, a number of Import_xxx and Export_xxx pragmas
102 -- are defined by GNAT. These are compatible with the DEC pragmas of the
103 -- same name, and all have the following common form and processing:
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
111 -- [Internal =>] LOCAL_NAME
112 -- [, [External =>] EXTERNAL_SYMBOL]
113 -- [, other optional parameters ]);
115 -- EXTERNAL_SYMBOL ::=
117 -- | static_string_EXPRESSION
119 -- The internal LOCAL_NAME designates the entity that is imported or
120 -- exported, and must refer to an entity in the current declarative
121 -- part (as required by the rules for LOCAL_NAME).
123 -- The external linker name is designated by the External parameter if
124 -- given, or the Internal parameter if not (if there is no External
125 -- parameter, the External parameter is a copy of the Internal name).
127 -- If the External parameter is given as a string, then this string is
128 -- treated as an external name (exactly as though it had been given as an
129 -- External_Name parameter for a normal Import pragma).
131 -- If the External parameter is given as an identifier (or there is no
132 -- External parameter, so that the Internal identifier is used), then
133 -- the external name is the characters of the identifier, translated
134 -- to all lower case letters.
136 -- Note: the external name specified or implied by any of these special
137 -- Import_xxx or Export_xxx pragmas override an external or link name
138 -- specified in a previous Import or Export pragma.
140 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
141 -- named notation, following the standard rules for subprogram calls, i.e.
142 -- parameters can be given in any order if named notation is used, and
143 -- positional and named notation can be mixed, subject to the rule that all
144 -- positional parameters must appear first.
146 -- Note: All these pragmas are implemented exactly following the DEC design
147 -- and implementation and are intended to be fully compatible with the use
148 -- of these pragmas in the DEC Ada compiler.
150 --------------------------------------------
151 -- Checking for Duplicated External Names --
152 --------------------------------------------
154 -- It is suspicious if two separate Export pragmas use the same external
155 -- name. The following table is used to diagnose this situation so that
156 -- an appropriate warning can be issued.
158 -- The Node_Id stored is for the N_String_Literal node created to hold
159 -- the value of the external name. The Sloc of this node is used to
160 -- cross-reference the location of the duplication.
162 package Externals is new Table.Table (
163 Table_Component_Type => Node_Id,
164 Table_Index_Type => Int,
165 Table_Low_Bound => 0,
166 Table_Initial => 100,
167 Table_Increment => 100,
168 Table_Name => "Name_Externals");
170 -------------------------------------
171 -- Local Subprograms and Variables --
172 -------------------------------------
174 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
175 -- This routine is used for possible casing adjustment of an explicit
176 -- external name supplied as a string literal (the node N), according to
177 -- the casing requirement of Opt.External_Name_Casing. If this is set to
178 -- As_Is, then the string literal is returned unchanged, but if it is set
179 -- to Uppercase or Lowercase, then a new string literal with appropriate
180 -- casing is constructed.
182 procedure Analyze_Part_Of
186 Encap_Id : out Entity_Id;
187 Legal : out Boolean);
188 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
189 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
190 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
191 -- package instantiation. Encap denotes the encapsulating state or single
192 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
193 -- the indicator is legal.
195 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
196 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
197 -- Query whether a particular item appears in a mixed list of nodes and
198 -- entities. It is assumed that all nodes in the list have entities.
200 procedure Check_Postcondition_Use_In_Inlined_Subprogram
202 Spec_Id : Entity_Id);
203 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
204 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
205 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
206 -- and assertions are enabled.
208 procedure Check_State_And_Constituent_Use
212 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
213 -- Global and Initializes. Determine whether a state from list States and a
214 -- corresponding constituent from list Constits (if any) appear in the same
215 -- context denoted by Context. If this is the case, emit an error.
217 procedure Contract_Freeze_Error
218 (Contract_Id : Entity_Id;
219 Freeze_Id : Entity_Id);
220 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
221 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
222 -- of a body which caused contract freezing and Contract_Id denotes the
223 -- entity of the affected contstruct.
225 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
226 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
227 -- Prag that duplicates previous pragma Prev.
229 function Find_Encapsulating_State
231 Constit_Id : Entity_Id) return Entity_Id;
232 -- Given the entity of a constituent Constit_Id, find the corresponding
233 -- encapsulating state which appears in States. The routine returns Empty
234 -- if no such state is found.
236 function Find_Related_Context
238 Do_Checks : Boolean := False) return Node_Id;
239 -- Subsidiary to the analysis of pragmas
242 -- Constant_After_Elaboration
246 -- Find the first source declaration or statement found while traversing
247 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
248 -- set, the routine reports duplicate pragmas. The routine returns Empty
249 -- when reaching the start of the node chain.
251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
253 -- original one, following the renaming chain) is returned. Otherwise the
254 -- entity is returned unchanged. Should be in Einfo???
256 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
258 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
259 -- value of type SPARK_Mode_Type.
261 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
262 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
263 -- Determine whether dependency clause Clause is surrounded by extra
264 -- parentheses. If this is the case, issue an error message.
266 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
267 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
268 -- pragma Depends. Determine whether the type of dependency item Item is
269 -- tagged, unconstrained array, unconstrained record or a record with at
270 -- least one unconstrained component.
272 procedure Record_Possible_Body_Reference
273 (State_Id : Entity_Id;
275 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
276 -- Global. Given an abstract state denoted by State_Id and a reference Ref
277 -- to it, determine whether the reference appears in a package body that
278 -- will eventually refine the state. If this is the case, record the
279 -- reference for future checks (see Analyze_Refined_State_In_Decls).
281 procedure Resolve_State (N : Node_Id);
282 -- Handle the overloading of state names by functions. When N denotes a
283 -- function, this routine finds the corresponding state and sets the entity
284 -- of N to that of the state.
286 procedure Rewrite_Assertion_Kind
288 From_Policy : Boolean := False);
289 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
290 -- then it is rewritten as an identifier with the corresponding special
291 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
292 -- and Check_Policy. If the names are Precondition or Postcondition, this
293 -- combination is deprecated in favor of Assertion_Policy and Ada2012
294 -- Aspect names. The parameter From_Policy indicates that the pragma
295 -- is the old non-standard Check_Policy and not a rewritten pragma.
297 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
298 -- Place semantic information on the argument of an Elaborate/Elaborate_All
299 -- pragma. Entity name for unit and its parents is taken from item in
300 -- previous with_clause that mentions the unit.
302 procedure Validate_Compile_Time_Warning_Error (N : Node_Id);
303 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
304 -- expression is not known at compile time. This procedure makes an entry
305 -- in a table. The actual checking is performed by Validate_Compile_Time_
306 -- Warning_Errors, which is invoked after calling the back end.
308 Dummy : Integer := 0;
309 pragma Volatile (Dummy);
310 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
313 pragma No_Inline (ip);
314 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
315 -- is just to help debugging the front end. If a pragma Inspection_Point
316 -- is added to a source program, then breaking on ip will get you to that
317 -- point in the program.
320 pragma No_Inline (rv);
321 -- This is a dummy function called by the processing for pragma Reviewable.
322 -- It is there for assisting front end debugging. By placing a Reviewable
323 -- pragma in the source program, a breakpoint on rv catches this place in
324 -- the source, allowing convenient stepping to the point of interest.
326 ---------------------------------------------------
327 -- Table for Validate_Compile_Time_Warning_Error --
328 ---------------------------------------------------
330 -- The following table collects pragmas Compile_Time_Error and Compile_
331 -- Time_Warning for validation. Entries are made by calls to subprogram
332 -- Validate_Compile_Time_Warning_Error, and the call to the procedure
333 -- Validate_Compile_Time_Warning_Errors does the actual error checking
334 -- and posting of warning and error messages. The reason for this delayed
335 -- processing is to take advantage of back-annotations of attributes size
336 -- and alignment values performed by the back end.
338 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
339 -- that by the time Validate_Unchecked_Conversions is called, Sprint will
340 -- already have modified all Sloc values if the -gnatD option is set.
342 type CTWE_Entry is record
344 -- Source location used in warnings and error messages
347 -- Pragma Compile_Time_Error or Compile_Time_Warning
350 -- The scope which encloses the pragma
353 package Compile_Time_Warnings_Errors is new Table.Table (
354 Table_Component_Type => CTWE_Entry,
355 Table_Index_Type => Int,
356 Table_Low_Bound => 1,
358 Table_Increment => 200,
359 Table_Name => "Compile_Time_Warnings_Errors");
361 -------------------------------
362 -- Adjust_External_Name_Case --
363 -------------------------------
365 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
369 -- Adjust case of literal if required
371 if Opt.External_Name_Exp_Casing = As_Is then
375 -- Copy existing string
381 for J in 1 .. String_Length (Strval (N)) loop
382 CC := Get_String_Char (Strval (N), J);
384 if Opt.External_Name_Exp_Casing = Uppercase
385 and then CC >= Get_Char_Code ('a')
386 and then CC <= Get_Char_Code ('z')
388 Store_String_Char (CC - 32);
390 elsif Opt.External_Name_Exp_Casing = Lowercase
391 and then CC >= Get_Char_Code ('A')
392 and then CC <= Get_Char_Code ('Z')
394 Store_String_Char (CC + 32);
397 Store_String_Char (CC);
402 Make_String_Literal (Sloc (N),
403 Strval => End_String);
405 end Adjust_External_Name_Case;
407 -----------------------------------------
408 -- Analyze_Contract_Cases_In_Decl_Part --
409 -----------------------------------------
411 -- WARNING: This routine manages Ghost regions. Return statements must be
412 -- replaced by gotos which jump to the end of the routine and restore the
415 procedure Analyze_Contract_Cases_In_Decl_Part
417 Freeze_Id : Entity_Id := Empty)
419 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
420 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
422 Others_Seen : Boolean := False;
423 -- This flag is set when an "others" choice is encountered. It is used
424 -- to detect multiple illegal occurrences of "others".
426 procedure Analyze_Contract_Case (CCase : Node_Id);
427 -- Verify the legality of a single contract case
429 ---------------------------
430 -- Analyze_Contract_Case --
431 ---------------------------
433 procedure Analyze_Contract_Case (CCase : Node_Id) is
434 Case_Guard : Node_Id;
437 Extra_Guard : Node_Id;
440 if Nkind (CCase) = N_Component_Association then
441 Case_Guard := First (Choices (CCase));
442 Conseq := Expression (CCase);
444 -- Each contract case must have exactly one case guard
446 Extra_Guard := Next (Case_Guard);
448 if Present (Extra_Guard) then
450 ("contract case must have exactly one case guard",
454 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
456 if Nkind (Case_Guard) = N_Others_Choice then
459 ("only one others choice allowed in contract cases",
465 elsif Others_Seen then
467 ("others must be the last choice in contract cases", N);
470 -- Preanalyze the case guard and consequence
472 if Nkind (Case_Guard) /= N_Others_Choice then
473 Errors := Serious_Errors_Detected;
474 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
476 -- Emit a clarification message when the case guard contains
477 -- at least one undefined reference, possibly due to contract
480 if Errors /= Serious_Errors_Detected
481 and then Present (Freeze_Id)
482 and then Has_Undefined_Reference (Case_Guard)
484 Contract_Freeze_Error (Spec_Id, Freeze_Id);
488 Errors := Serious_Errors_Detected;
489 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
491 -- Emit a clarification message when the consequence contains
492 -- at least one undefined reference, possibly due to contract
495 if Errors /= Serious_Errors_Detected
496 and then Present (Freeze_Id)
497 and then Has_Undefined_Reference (Conseq)
499 Contract_Freeze_Error (Spec_Id, Freeze_Id);
502 -- The contract case is malformed
505 Error_Msg_N ("wrong syntax in contract case", CCase);
507 end Analyze_Contract_Case;
511 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
513 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
514 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
515 -- Save the Ghost-related attributes to restore on exit
518 Restore_Scope : Boolean := False;
520 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
523 -- Do not analyze the pragma multiple times
525 if Is_Analyzed_Pragma (N) then
529 -- Set the Ghost mode in effect from the pragma. Due to the delayed
530 -- analysis of the pragma, the Ghost mode at point of declaration and
531 -- point of analysis may not necessarily be the same. Use the mode in
532 -- effect at the point of declaration.
536 -- Single and multiple contract cases must appear in aggregate form. If
537 -- this is not the case, then either the parser of the analysis of the
538 -- pragma failed to produce an aggregate.
540 pragma Assert (Nkind (CCases) = N_Aggregate);
542 if Present (Component_Associations (CCases)) then
544 -- Ensure that the formal parameters are visible when analyzing all
545 -- clauses. This falls out of the general rule of aspects pertaining
546 -- to subprogram declarations.
548 if not In_Open_Scopes (Spec_Id) then
549 Restore_Scope := True;
550 Push_Scope (Spec_Id);
552 if Is_Generic_Subprogram (Spec_Id) then
553 Install_Generic_Formals (Spec_Id);
555 Install_Formals (Spec_Id);
559 CCase := First (Component_Associations (CCases));
560 while Present (CCase) loop
561 Analyze_Contract_Case (CCase);
565 if Restore_Scope then
569 -- Currently it is not possible to inline pre/postconditions on a
570 -- subprogram subject to pragma Inline_Always.
572 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
574 -- Otherwise the pragma is illegal
577 Error_Msg_N ("wrong syntax for constract cases", N);
580 Set_Is_Analyzed_Pragma (N);
582 Restore_Ghost_Region (Saved_GM, Saved_IGR);
583 end Analyze_Contract_Cases_In_Decl_Part;
585 ----------------------------------
586 -- Analyze_Depends_In_Decl_Part --
587 ----------------------------------
589 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
590 Loc : constant Source_Ptr := Sloc (N);
591 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
592 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
594 All_Inputs_Seen : Elist_Id := No_Elist;
595 -- A list containing the entities of all the inputs processed so far.
596 -- The list is populated with unique entities because the same input
597 -- may appear in multiple input lists.
599 All_Outputs_Seen : Elist_Id := No_Elist;
600 -- A list containing the entities of all the outputs processed so far.
601 -- The list is populated with unique entities because output items are
602 -- unique in a dependence relation.
604 Constits_Seen : Elist_Id := No_Elist;
605 -- A list containing the entities of all constituents processed so far.
606 -- It aids in detecting illegal usage of a state and a corresponding
607 -- constituent in pragma [Refinde_]Depends.
609 Global_Seen : Boolean := False;
610 -- A flag set when pragma Global has been processed
612 Null_Output_Seen : Boolean := False;
613 -- A flag used to track the legality of a null output
615 Result_Seen : Boolean := False;
616 -- A flag set when Spec_Id'Result is processed
618 States_Seen : Elist_Id := No_Elist;
619 -- A list containing the entities of all states processed so far. It
620 -- helps in detecting illegal usage of a state and a corresponding
621 -- constituent in pragma [Refined_]Depends.
623 Subp_Inputs : Elist_Id := No_Elist;
624 Subp_Outputs : Elist_Id := No_Elist;
625 -- Two lists containing the full set of inputs and output of the related
626 -- subprograms. Note that these lists contain both nodes and entities.
628 Task_Input_Seen : Boolean := False;
629 Task_Output_Seen : Boolean := False;
630 -- Flags used to track the implicit dependence of a task unit on itself
632 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
633 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
634 -- to the name buffer. The individual kinds are as follows:
635 -- E_Abstract_State - "state"
636 -- E_Constant - "constant"
637 -- E_Generic_In_Out_Parameter - "generic parameter"
638 -- E_Generic_In_Parameter - "generic parameter"
639 -- E_In_Parameter - "parameter"
640 -- E_In_Out_Parameter - "parameter"
641 -- E_Loop_Parameter - "loop parameter"
642 -- E_Out_Parameter - "parameter"
643 -- E_Protected_Type - "current instance of protected type"
644 -- E_Task_Type - "current instance of task type"
645 -- E_Variable - "global"
647 procedure Analyze_Dependency_Clause
650 -- Verify the legality of a single dependency clause. Flag Is_Last
651 -- denotes whether Clause is the last clause in the relation.
653 procedure Check_Function_Return;
654 -- Verify that Funtion'Result appears as one of the outputs
655 -- (SPARK RM 6.1.5(10)).
662 -- Ensure that an item fulfills its designated input and/or output role
663 -- as specified by pragma Global (if any) or the enclosing context. If
664 -- this is not the case, emit an error. Item and Item_Id denote the
665 -- attributes of an item. Flag Is_Input should be set when item comes
666 -- from an input list. Flag Self_Ref should be set when the item is an
667 -- output and the dependency clause has operator "+".
669 procedure Check_Usage
670 (Subp_Items : Elist_Id;
671 Used_Items : Elist_Id;
673 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
674 -- error if this is not the case.
676 procedure Normalize_Clause (Clause : Node_Id);
677 -- Remove a self-dependency "+" from the input list of a clause
679 -----------------------------
680 -- Add_Item_To_Name_Buffer --
681 -----------------------------
683 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
685 if Ekind (Item_Id) = E_Abstract_State then
686 Add_Str_To_Name_Buffer ("state");
688 elsif Ekind (Item_Id) = E_Constant then
689 Add_Str_To_Name_Buffer ("constant");
691 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
692 E_Generic_In_Parameter)
694 Add_Str_To_Name_Buffer ("generic parameter");
696 elsif Is_Formal (Item_Id) then
697 Add_Str_To_Name_Buffer ("parameter");
699 elsif Ekind (Item_Id) = E_Loop_Parameter then
700 Add_Str_To_Name_Buffer ("loop parameter");
702 elsif Ekind (Item_Id) = E_Protected_Type
703 or else Is_Single_Protected_Object (Item_Id)
705 Add_Str_To_Name_Buffer ("current instance of protected type");
707 elsif Ekind (Item_Id) = E_Task_Type
708 or else Is_Single_Task_Object (Item_Id)
710 Add_Str_To_Name_Buffer ("current instance of task type");
712 elsif Ekind (Item_Id) = E_Variable then
713 Add_Str_To_Name_Buffer ("global");
715 -- The routine should not be called with non-SPARK items
720 end Add_Item_To_Name_Buffer;
722 -------------------------------
723 -- Analyze_Dependency_Clause --
724 -------------------------------
726 procedure Analyze_Dependency_Clause
730 procedure Analyze_Input_List (Inputs : Node_Id);
731 -- Verify the legality of a single input list
733 procedure Analyze_Input_Output
738 Seen : in out Elist_Id;
739 Null_Seen : in out Boolean;
740 Non_Null_Seen : in out Boolean);
741 -- Verify the legality of a single input or output item. Flag
742 -- Is_Input should be set whenever Item is an input, False when it
743 -- denotes an output. Flag Self_Ref should be set when the item is an
744 -- output and the dependency clause has a "+". Flag Top_Level should
745 -- be set whenever Item appears immediately within an input or output
746 -- list. Seen is a collection of all abstract states, objects and
747 -- formals processed so far. Flag Null_Seen denotes whether a null
748 -- input or output has been encountered. Flag Non_Null_Seen denotes
749 -- whether a non-null input or output has been encountered.
751 ------------------------
752 -- Analyze_Input_List --
753 ------------------------
755 procedure Analyze_Input_List (Inputs : Node_Id) is
756 Inputs_Seen : Elist_Id := No_Elist;
757 -- A list containing the entities of all inputs that appear in the
758 -- current input list.
760 Non_Null_Input_Seen : Boolean := False;
761 Null_Input_Seen : Boolean := False;
762 -- Flags used to check the legality of an input list
767 -- Multiple inputs appear as an aggregate
769 if Nkind (Inputs) = N_Aggregate then
770 if Present (Component_Associations (Inputs)) then
772 ("nested dependency relations not allowed", Inputs);
774 elsif Present (Expressions (Inputs)) then
775 Input := First (Expressions (Inputs));
776 while Present (Input) loop
783 Null_Seen => Null_Input_Seen,
784 Non_Null_Seen => Non_Null_Input_Seen);
789 -- Syntax error, always report
792 Error_Msg_N ("malformed input dependency list", Inputs);
795 -- Process a solitary input
804 Null_Seen => Null_Input_Seen,
805 Non_Null_Seen => Non_Null_Input_Seen);
808 -- Detect an illegal dependency clause of the form
812 if Null_Output_Seen and then Null_Input_Seen then
814 ("null dependency clause cannot have a null input list",
817 end Analyze_Input_List;
819 --------------------------
820 -- Analyze_Input_Output --
821 --------------------------
823 procedure Analyze_Input_Output
828 Seen : in out Elist_Id;
829 Null_Seen : in out Boolean;
830 Non_Null_Seen : in out Boolean)
832 procedure Current_Task_Instance_Seen;
833 -- Set the appropriate global flag when the current instance of a
834 -- task unit is encountered.
836 --------------------------------
837 -- Current_Task_Instance_Seen --
838 --------------------------------
840 procedure Current_Task_Instance_Seen is
843 Task_Input_Seen := True;
845 Task_Output_Seen := True;
847 end Current_Task_Instance_Seen;
851 Is_Output : constant Boolean := not Is_Input;
855 -- Start of processing for Analyze_Input_Output
858 -- Multiple input or output items appear as an aggregate
860 if Nkind (Item) = N_Aggregate then
861 if not Top_Level then
862 SPARK_Msg_N ("nested grouping of items not allowed", Item);
864 elsif Present (Component_Associations (Item)) then
866 ("nested dependency relations not allowed", Item);
868 -- Recursively analyze the grouped items
870 elsif Present (Expressions (Item)) then
871 Grouped := First (Expressions (Item));
872 while Present (Grouped) loop
875 Is_Input => Is_Input,
876 Self_Ref => Self_Ref,
879 Null_Seen => Null_Seen,
880 Non_Null_Seen => Non_Null_Seen);
885 -- Syntax error, always report
888 Error_Msg_N ("malformed dependency list", Item);
891 -- Process attribute 'Result in the context of a dependency clause
893 elsif Is_Attribute_Result (Item) then
894 Non_Null_Seen := True;
898 -- Attribute 'Result is allowed to appear on the output side of
899 -- a dependency clause (SPARK RM 6.1.5(6)).
902 SPARK_Msg_N ("function result cannot act as input", Item);
906 ("cannot mix null and non-null dependency items", Item);
912 -- Detect multiple uses of null in a single dependency list or
913 -- throughout the whole relation. Verify the placement of a null
914 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
916 elsif Nkind (Item) = N_Null then
919 ("multiple null dependency relations not allowed", Item);
921 elsif Non_Null_Seen then
923 ("cannot mix null and non-null dependency items", Item);
931 ("null output list must be the last clause in a "
932 & "dependency relation", Item);
934 -- Catch a useless dependence of the form:
939 ("useless dependence, null depends on itself", Item);
947 Non_Null_Seen := True;
950 SPARK_Msg_N ("cannot mix null and non-null items", Item);
954 Resolve_State (Item);
956 -- Find the entity of the item. If this is a renaming, climb
957 -- the renaming chain to reach the root object. Renamings of
958 -- non-entire objects do not yield an entity (Empty).
960 Item_Id := Entity_Of (Item);
962 if Present (Item_Id) then
966 if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter)
969 -- Current instances of concurrent types
971 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
976 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
977 E_Generic_In_Parameter,
985 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
987 -- A [generic] function is not allowed to have Output
988 -- items in its dependency relations. Note that "null"
989 -- and attribute 'Result are still valid items.
991 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
992 and then not Is_Input
995 ("output item is not applicable to function", Item);
998 -- The item denotes a concurrent type. Note that single
999 -- protected/task types are not considered here because
1000 -- they behave as objects in the context of pragma
1001 -- [Refined_]Depends.
1003 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
1005 -- This use is legal as long as the concurrent type is
1006 -- the current instance of an enclosing type.
1008 if Is_CCT_Instance (Item_Id, Spec_Id) then
1010 -- The dependence of a task unit on itself is
1011 -- implicit and may or may not be explicitly
1012 -- specified (SPARK RM 6.1.4).
1014 if Ekind (Item_Id) = E_Task_Type then
1015 Current_Task_Instance_Seen;
1018 -- Otherwise this is not the current instance
1022 ("invalid use of subtype mark in dependency "
1023 & "relation", Item);
1026 -- The dependency of a task unit on itself is implicit
1027 -- and may or may not be explicitly specified
1028 -- (SPARK RM 6.1.4).
1030 elsif Is_Single_Task_Object (Item_Id)
1031 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
1033 Current_Task_Instance_Seen;
1036 -- Ensure that the item fulfills its role as input and/or
1037 -- output as specified by pragma Global or the enclosing
1040 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1042 -- Detect multiple uses of the same state, variable or
1043 -- formal parameter. If this is not the case, add the
1044 -- item to the list of processed relations.
1046 if Contains (Seen, Item_Id) then
1048 ("duplicate use of item &", Item, Item_Id);
1050 Append_New_Elmt (Item_Id, Seen);
1053 -- Detect illegal use of an input related to a null
1054 -- output. Such input items cannot appear in other
1055 -- input lists (SPARK RM 6.1.5(13)).
1058 and then Null_Output_Seen
1059 and then Contains (All_Inputs_Seen, Item_Id)
1062 ("input of a null output list cannot appear in "
1063 & "multiple input lists", Item);
1066 -- Add an input or a self-referential output to the list
1067 -- of all processed inputs.
1069 if Is_Input or else Self_Ref then
1070 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1073 -- State related checks (SPARK RM 6.1.5(3))
1075 if Ekind (Item_Id) = E_Abstract_State then
1077 -- Package and subprogram bodies are instantiated
1078 -- individually in a separate compiler pass. Due to
1079 -- this mode of instantiation, the refinement of a
1080 -- state may no longer be visible when a subprogram
1081 -- body contract is instantiated. Since the generic
1082 -- template is legal, do not perform this check in
1083 -- the instance to circumvent this oddity.
1085 if Is_Generic_Instance (Spec_Id) then
1088 -- An abstract state with visible refinement cannot
1089 -- appear in pragma [Refined_]Depends as its place
1090 -- must be taken by some of its constituents
1091 -- (SPARK RM 6.1.4(7)).
1093 elsif Has_Visible_Refinement (Item_Id) then
1095 ("cannot mention state & in dependence relation",
1097 SPARK_Msg_N ("\use its constituents instead", Item);
1100 -- If the reference to the abstract state appears in
1101 -- an enclosing package body that will eventually
1102 -- refine the state, record the reference for future
1106 Record_Possible_Body_Reference
1107 (State_Id => Item_Id,
1112 -- When the item renames an entire object, replace the
1113 -- item with a reference to the object.
1115 if Entity (Item) /= Item_Id then
1117 New_Occurrence_Of (Item_Id, Sloc (Item)));
1121 -- Add the entity of the current item to the list of
1124 if Ekind (Item_Id) = E_Abstract_State then
1125 Append_New_Elmt (Item_Id, States_Seen);
1127 -- The variable may eventually become a constituent of a
1128 -- single protected/task type. Record the reference now
1129 -- and verify its legality when analyzing the contract of
1130 -- the variable (SPARK RM 9.3).
1132 elsif Ekind (Item_Id) = E_Variable then
1133 Record_Possible_Part_Of_Reference
1138 if Ekind_In (Item_Id, E_Abstract_State,
1141 and then Present (Encapsulating_State (Item_Id))
1143 Append_New_Elmt (Item_Id, Constits_Seen);
1146 -- All other input/output items are illegal
1147 -- (SPARK RM 6.1.5(1)).
1151 ("item must denote parameter, variable, state or "
1152 & "current instance of concurrent type", Item);
1155 -- All other input/output items are illegal
1156 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1160 ("item must denote parameter, variable, state or current "
1161 & "instance of concurrent type", Item);
1164 end Analyze_Input_Output;
1172 Non_Null_Output_Seen : Boolean := False;
1173 -- Flag used to check the legality of an output list
1175 -- Start of processing for Analyze_Dependency_Clause
1178 Inputs := Expression (Clause);
1181 -- An input list with a self-dependency appears as operator "+" where
1182 -- the actuals inputs are the right operand.
1184 if Nkind (Inputs) = N_Op_Plus then
1185 Inputs := Right_Opnd (Inputs);
1189 -- Process the output_list of a dependency_clause
1191 Output := First (Choices (Clause));
1192 while Present (Output) loop
1193 Analyze_Input_Output
1196 Self_Ref => Self_Ref,
1198 Seen => All_Outputs_Seen,
1199 Null_Seen => Null_Output_Seen,
1200 Non_Null_Seen => Non_Null_Output_Seen);
1205 -- Process the input_list of a dependency_clause
1207 Analyze_Input_List (Inputs);
1208 end Analyze_Dependency_Clause;
1210 ---------------------------
1211 -- Check_Function_Return --
1212 ---------------------------
1214 procedure Check_Function_Return is
1216 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1217 and then not Result_Seen
1220 ("result of & must appear in exactly one output list",
1223 end Check_Function_Return;
1229 procedure Check_Role
1231 Item_Id : Entity_Id;
1236 (Item_Is_Input : out Boolean;
1237 Item_Is_Output : out Boolean);
1238 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1239 -- Item_Is_Output are set depending on the role.
1241 procedure Role_Error
1242 (Item_Is_Input : Boolean;
1243 Item_Is_Output : Boolean);
1244 -- Emit an error message concerning the incorrect use of Item in
1245 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1246 -- denote whether the item is an input and/or an output.
1253 (Item_Is_Input : out Boolean;
1254 Item_Is_Output : out Boolean)
1257 case Ekind (Item_Id) is
1261 when E_Abstract_State =>
1263 -- When pragma Global is present it determines the mode of
1264 -- the abstract state.
1267 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1268 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1270 -- Otherwise the state has a default IN OUT mode, because it
1271 -- behaves as a variable.
1274 Item_Is_Input := True;
1275 Item_Is_Output := True;
1278 -- Constants and IN parameters
1281 | E_Generic_In_Parameter
1285 -- When pragma Global is present it determines the mode
1286 -- of constant objects as inputs (and such objects cannot
1287 -- appear as outputs in the Global contract).
1290 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
1292 Item_Is_Input := True;
1295 Item_Is_Output := False;
1297 -- Variables and IN OUT parameters
1299 when E_Generic_In_Out_Parameter
1300 | E_In_Out_Parameter
1303 -- When pragma Global is present it determines the mode of
1308 -- A variable has mode IN when its type is unconstrained
1309 -- or tagged because array bounds, discriminants or tags
1313 Appears_In (Subp_Inputs, Item_Id)
1314 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1316 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1318 -- Otherwise the variable has a default IN OUT mode
1321 Item_Is_Input := True;
1322 Item_Is_Output := True;
1325 when E_Out_Parameter =>
1327 -- An OUT parameter of the related subprogram; it cannot
1328 -- appear in Global.
1330 if Scope (Item_Id) = Spec_Id then
1332 -- The parameter has mode IN if its type is unconstrained
1333 -- or tagged because array bounds, discriminants or tags
1337 Is_Unconstrained_Or_Tagged_Item (Item_Id);
1339 Item_Is_Output := True;
1341 -- An OUT parameter of an enclosing subprogram; it can
1342 -- appear in Global and behaves as a read-write variable.
1345 -- When pragma Global is present it determines the mode
1350 -- A variable has mode IN when its type is
1351 -- unconstrained or tagged because array
1352 -- bounds, discriminants or tags can be read.
1355 Appears_In (Subp_Inputs, Item_Id)
1356 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1358 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1360 -- Otherwise the variable has a default IN OUT mode
1363 Item_Is_Input := True;
1364 Item_Is_Output := True;
1370 when E_Protected_Type =>
1373 -- A variable has mode IN when its type is unconstrained
1374 -- or tagged because array bounds, discriminants or tags
1378 Appears_In (Subp_Inputs, Item_Id)
1379 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1381 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1384 -- A protected type acts as a formal parameter of mode IN
1385 -- when it applies to a protected function.
1387 if Ekind (Spec_Id) = E_Function then
1388 Item_Is_Input := True;
1389 Item_Is_Output := False;
1391 -- Otherwise the protected type acts as a formal of mode
1395 Item_Is_Input := True;
1396 Item_Is_Output := True;
1404 -- When pragma Global is present it determines the mode of
1409 Appears_In (Subp_Inputs, Item_Id)
1410 or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
1412 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
1414 -- Otherwise task types act as IN OUT parameters
1417 Item_Is_Input := True;
1418 Item_Is_Output := True;
1422 raise Program_Error;
1430 procedure Role_Error
1431 (Item_Is_Input : Boolean;
1432 Item_Is_Output : Boolean)
1434 Error_Msg : Name_Id;
1439 -- When the item is not part of the input and the output set of
1440 -- the related subprogram, then it appears as extra in pragma
1441 -- [Refined_]Depends.
1443 if not Item_Is_Input and then not Item_Is_Output then
1444 Add_Item_To_Name_Buffer (Item_Id);
1445 Add_Str_To_Name_Buffer
1446 (" & cannot appear in dependence relation");
1448 Error_Msg := Name_Find;
1449 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1451 Error_Msg_Name_1 := Chars (Spec_Id);
1453 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1454 & "set of subprogram %"), Item, Item_Id);
1456 -- The mode of the item and its role in pragma [Refined_]Depends
1457 -- are in conflict. Construct a detailed message explaining the
1458 -- illegality (SPARK RM 6.1.5(5-6)).
1461 if Item_Is_Input then
1462 Add_Str_To_Name_Buffer ("read-only");
1464 Add_Str_To_Name_Buffer ("write-only");
1467 Add_Char_To_Name_Buffer (' ');
1468 Add_Item_To_Name_Buffer (Item_Id);
1469 Add_Str_To_Name_Buffer (" & cannot appear as ");
1471 if Item_Is_Input then
1472 Add_Str_To_Name_Buffer ("output");
1474 Add_Str_To_Name_Buffer ("input");
1477 Add_Str_To_Name_Buffer (" in dependence relation");
1478 Error_Msg := Name_Find;
1479 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1485 Item_Is_Input : Boolean;
1486 Item_Is_Output : Boolean;
1488 -- Start of processing for Check_Role
1491 Find_Role (Item_Is_Input, Item_Is_Output);
1496 if not Item_Is_Input then
1497 Role_Error (Item_Is_Input, Item_Is_Output);
1500 -- Self-referential item
1503 if not Item_Is_Input or else not Item_Is_Output then
1504 Role_Error (Item_Is_Input, Item_Is_Output);
1509 elsif not Item_Is_Output then
1510 Role_Error (Item_Is_Input, Item_Is_Output);
1518 procedure Check_Usage
1519 (Subp_Items : Elist_Id;
1520 Used_Items : Elist_Id;
1523 procedure Usage_Error (Item_Id : Entity_Id);
1524 -- Emit an error concerning the illegal usage of an item
1530 procedure Usage_Error (Item_Id : Entity_Id) is
1531 Error_Msg : Name_Id;
1538 -- Unconstrained and tagged items are not part of the explicit
1539 -- input set of the related subprogram, they do not have to be
1540 -- present in a dependence relation and should not be flagged
1541 -- (SPARK RM 6.1.5(5)).
1543 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1546 Add_Item_To_Name_Buffer (Item_Id);
1547 Add_Str_To_Name_Buffer
1548 (" & is missing from input dependence list");
1550 Error_Msg := Name_Find;
1551 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1553 ("\add `null ='> &` dependency to ignore this input",
1557 -- Output case (SPARK RM 6.1.5(10))
1562 Add_Item_To_Name_Buffer (Item_Id);
1563 Add_Str_To_Name_Buffer
1564 (" & is missing from output dependence list");
1566 Error_Msg := Name_Find;
1567 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1575 Item_Id : Entity_Id;
1577 -- Start of processing for Check_Usage
1580 if No (Subp_Items) then
1584 -- Each input or output of the subprogram must appear in a dependency
1587 Elmt := First_Elmt (Subp_Items);
1588 while Present (Elmt) loop
1589 Item := Node (Elmt);
1591 if Nkind (Item) = N_Defining_Identifier then
1594 Item_Id := Entity_Of (Item);
1597 -- The item does not appear in a dependency
1599 if Present (Item_Id)
1600 and then not Contains (Used_Items, Item_Id)
1602 if Is_Formal (Item_Id) then
1603 Usage_Error (Item_Id);
1605 -- The current instance of a protected type behaves as a formal
1606 -- parameter (SPARK RM 6.1.4).
1608 elsif Ekind (Item_Id) = E_Protected_Type
1609 or else Is_Single_Protected_Object (Item_Id)
1611 Usage_Error (Item_Id);
1613 -- The current instance of a task type behaves as a formal
1614 -- parameter (SPARK RM 6.1.4).
1616 elsif Ekind (Item_Id) = E_Task_Type
1617 or else Is_Single_Task_Object (Item_Id)
1619 -- The dependence of a task unit on itself is implicit and
1620 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1621 -- Emit an error if only one input/output is present.
1623 if Task_Input_Seen /= Task_Output_Seen then
1624 Usage_Error (Item_Id);
1627 -- States and global objects are not used properly only when
1628 -- the subprogram is subject to pragma Global.
1630 elsif Global_Seen then
1631 Usage_Error (Item_Id);
1639 ----------------------
1640 -- Normalize_Clause --
1641 ----------------------
1643 procedure Normalize_Clause (Clause : Node_Id) is
1644 procedure Create_Or_Modify_Clause
1650 Multiple : Boolean);
1651 -- Create a brand new clause to represent the self-reference or
1652 -- modify the input and/or output lists of an existing clause. Output
1653 -- denotes a self-referencial output. Outputs is the output list of a
1654 -- clause. Inputs is the input list of a clause. After denotes the
1655 -- clause after which the new clause is to be inserted. Flag In_Place
1656 -- should be set when normalizing the last output of an output list.
1657 -- Flag Multiple should be set when Output comes from a list with
1660 -----------------------------
1661 -- Create_Or_Modify_Clause --
1662 -----------------------------
1664 procedure Create_Or_Modify_Clause
1672 procedure Propagate_Output
1675 -- Handle the various cases of output propagation to the input
1676 -- list. Output denotes a self-referencial output item. Inputs
1677 -- is the input list of a clause.
1679 ----------------------
1680 -- Propagate_Output --
1681 ----------------------
1683 procedure Propagate_Output
1687 function In_Input_List
1689 Inputs : List_Id) return Boolean;
1690 -- Determine whether a particulat item appears in the input
1691 -- list of a clause.
1697 function In_Input_List
1699 Inputs : List_Id) return Boolean
1704 Elmt := First (Inputs);
1705 while Present (Elmt) loop
1706 if Entity_Of (Elmt) = Item then
1718 Output_Id : constant Entity_Id := Entity_Of (Output);
1721 -- Start of processing for Propagate_Output
1724 -- The clause is of the form:
1726 -- (Output =>+ null)
1728 -- Remove null input and replace it with a copy of the output:
1730 -- (Output => Output)
1732 if Nkind (Inputs) = N_Null then
1733 Rewrite (Inputs, New_Copy_Tree (Output));
1735 -- The clause is of the form:
1737 -- (Output =>+ (Input1, ..., InputN))
1739 -- Determine whether the output is not already mentioned in the
1740 -- input list and if not, add it to the list of inputs:
1742 -- (Output => (Output, Input1, ..., InputN))
1744 elsif Nkind (Inputs) = N_Aggregate then
1745 Grouped := Expressions (Inputs);
1747 if not In_Input_List
1751 Prepend_To (Grouped, New_Copy_Tree (Output));
1754 -- The clause is of the form:
1756 -- (Output =>+ Input)
1758 -- If the input does not mention the output, group the two
1761 -- (Output => (Output, Input))
1763 elsif Entity_Of (Inputs) /= Output_Id then
1765 Make_Aggregate (Loc,
1766 Expressions => New_List (
1767 New_Copy_Tree (Output),
1768 New_Copy_Tree (Inputs))));
1770 end Propagate_Output;
1774 Loc : constant Source_Ptr := Sloc (Clause);
1775 New_Clause : Node_Id;
1777 -- Start of processing for Create_Or_Modify_Clause
1780 -- A null output depending on itself does not require any
1783 if Nkind (Output) = N_Null then
1786 -- A function result cannot depend on itself because it cannot
1787 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1789 elsif Is_Attribute_Result (Output) then
1790 SPARK_Msg_N ("function result cannot depend on itself", Output);
1794 -- When performing the transformation in place, simply add the
1795 -- output to the list of inputs (if not already there). This
1796 -- case arises when dealing with the last output of an output
1797 -- list. Perform the normalization in place to avoid generating
1798 -- a malformed tree.
1801 Propagate_Output (Output, Inputs);
1803 -- A list with multiple outputs is slowly trimmed until only
1804 -- one element remains. When this happens, replace aggregate
1805 -- with the element itself.
1809 Rewrite (Outputs, Output);
1815 -- Unchain the output from its output list as it will appear in
1816 -- a new clause. Note that we cannot simply rewrite the output
1817 -- as null because this will violate the semantics of pragma
1822 -- Generate a new clause of the form:
1823 -- (Output => Inputs)
1826 Make_Component_Association (Loc,
1827 Choices => New_List (Output),
1828 Expression => New_Copy_Tree (Inputs));
1830 -- The new clause contains replicated content that has already
1831 -- been analyzed. There is not need to reanalyze or renormalize
1834 Set_Analyzed (New_Clause);
1837 (Output => First (Choices (New_Clause)),
1838 Inputs => Expression (New_Clause));
1840 Insert_After (After, New_Clause);
1842 end Create_Or_Modify_Clause;
1846 Outputs : constant Node_Id := First (Choices (Clause));
1848 Last_Output : Node_Id;
1849 Next_Output : Node_Id;
1852 -- Start of processing for Normalize_Clause
1855 -- A self-dependency appears as operator "+". Remove the "+" from the
1856 -- tree by moving the real inputs to their proper place.
1858 if Nkind (Expression (Clause)) = N_Op_Plus then
1859 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1860 Inputs := Expression (Clause);
1862 -- Multiple outputs appear as an aggregate
1864 if Nkind (Outputs) = N_Aggregate then
1865 Last_Output := Last (Expressions (Outputs));
1867 Output := First (Expressions (Outputs));
1868 while Present (Output) loop
1870 -- Normalization may remove an output from its list,
1871 -- preserve the subsequent output now.
1873 Next_Output := Next (Output);
1875 Create_Or_Modify_Clause
1880 In_Place => Output = Last_Output,
1883 Output := Next_Output;
1889 Create_Or_Modify_Clause
1898 end Normalize_Clause;
1902 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1903 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1907 Last_Clause : Node_Id;
1908 Restore_Scope : Boolean := False;
1910 -- Start of processing for Analyze_Depends_In_Decl_Part
1913 -- Do not analyze the pragma multiple times
1915 if Is_Analyzed_Pragma (N) then
1919 -- Empty dependency list
1921 if Nkind (Deps) = N_Null then
1923 -- Gather all states, objects and formal parameters that the
1924 -- subprogram may depend on. These items are obtained from the
1925 -- parameter profile or pragma [Refined_]Global (if available).
1927 Collect_Subprogram_Inputs_Outputs
1928 (Subp_Id => Subp_Id,
1929 Subp_Inputs => Subp_Inputs,
1930 Subp_Outputs => Subp_Outputs,
1931 Global_Seen => Global_Seen);
1933 -- Verify that every input or output of the subprogram appear in a
1936 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1937 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1938 Check_Function_Return;
1940 -- Dependency clauses appear as component associations of an aggregate
1942 elsif Nkind (Deps) = N_Aggregate then
1944 -- Do not attempt to perform analysis of a syntactically illegal
1945 -- clause as this will lead to misleading errors.
1947 if Has_Extra_Parentheses (Deps) then
1951 if Present (Component_Associations (Deps)) then
1952 Last_Clause := Last (Component_Associations (Deps));
1954 -- Gather all states, objects and formal parameters that the
1955 -- subprogram may depend on. These items are obtained from the
1956 -- parameter profile or pragma [Refined_]Global (if available).
1958 Collect_Subprogram_Inputs_Outputs
1959 (Subp_Id => Subp_Id,
1960 Subp_Inputs => Subp_Inputs,
1961 Subp_Outputs => Subp_Outputs,
1962 Global_Seen => Global_Seen);
1964 -- When pragma [Refined_]Depends appears on a single concurrent
1965 -- type, it is relocated to the anonymous object.
1967 if Is_Single_Concurrent_Object (Spec_Id) then
1970 -- Ensure that the formal parameters are visible when analyzing
1971 -- all clauses. This falls out of the general rule of aspects
1972 -- pertaining to subprogram declarations.
1974 elsif not In_Open_Scopes (Spec_Id) then
1975 Restore_Scope := True;
1976 Push_Scope (Spec_Id);
1978 if Ekind (Spec_Id) = E_Task_Type then
1979 if Has_Discriminants (Spec_Id) then
1980 Install_Discriminants (Spec_Id);
1983 elsif Is_Generic_Subprogram (Spec_Id) then
1984 Install_Generic_Formals (Spec_Id);
1987 Install_Formals (Spec_Id);
1991 Clause := First (Component_Associations (Deps));
1992 while Present (Clause) loop
1993 Errors := Serious_Errors_Detected;
1995 -- The normalization mechanism may create extra clauses that
1996 -- contain replicated input and output names. There is no need
1997 -- to reanalyze them.
1999 if not Analyzed (Clause) then
2000 Set_Analyzed (Clause);
2002 Analyze_Dependency_Clause
2004 Is_Last => Clause = Last_Clause);
2007 -- Do not normalize a clause if errors were detected (count
2008 -- of Serious_Errors has increased) because the inputs and/or
2009 -- outputs may denote illegal items. Normalization is disabled
2010 -- in ASIS mode as it alters the tree by introducing new nodes
2011 -- similar to expansion.
2013 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
2014 Normalize_Clause (Clause);
2020 if Restore_Scope then
2024 -- Verify that every input or output of the subprogram appear in a
2027 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
2028 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
2029 Check_Function_Return;
2031 -- The dependency list is malformed. This is a syntax error, always
2035 Error_Msg_N ("malformed dependency relation", Deps);
2039 -- The top level dependency relation is malformed. This is a syntax
2040 -- error, always report.
2043 Error_Msg_N ("malformed dependency relation", Deps);
2047 -- Ensure that a state and a corresponding constituent do not appear
2048 -- together in pragma [Refined_]Depends.
2050 Check_State_And_Constituent_Use
2051 (States => States_Seen,
2052 Constits => Constits_Seen,
2056 Set_Is_Analyzed_Pragma (N);
2057 end Analyze_Depends_In_Decl_Part;
2059 --------------------------------------------
2060 -- Analyze_External_Property_In_Decl_Part --
2061 --------------------------------------------
2063 procedure Analyze_External_Property_In_Decl_Part
2065 Expr_Val : out Boolean)
2067 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N));
2068 Arg1 : constant Node_Id :=
2069 First (Pragma_Argument_Associations (N));
2070 Obj_Decl : constant Node_Id := Find_Related_Context (N);
2071 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2077 -- Do not analyze the pragma multiple times
2079 if Is_Analyzed_Pragma (N) then
2083 Error_Msg_Name_1 := Pragma_Name (N);
2085 -- An external property pragma must apply to an effectively volatile
2086 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2087 -- The check is performed at the end of the declarative region due to a
2088 -- possible out-of-order arrangement of pragmas:
2091 -- pragma Async_Readers (Obj);
2092 -- pragma Volatile (Obj);
2094 if Prag_Id /= Pragma_No_Caching
2095 and then not Is_Effectively_Volatile (Obj_Id)
2097 if No_Caching_Enabled (Obj_Id) then
2099 ("illegal combination of external property % and property "
2100 & """No_Caching"" (SPARK RM 7.1.2(6))", N);
2103 ("external property % must apply to a volatile object", N);
2106 -- Pragma No_Caching should only apply to volatile variables of
2107 -- a non-effectively volatile type (SPARK RM 7.1.2).
2109 elsif Prag_Id = Pragma_No_Caching then
2110 if Is_Effectively_Volatile (Etype (Obj_Id)) then
2111 SPARK_Msg_N ("property % must not apply to an object of "
2112 & "an effectively volatile type", N);
2113 elsif not Is_Volatile (Obj_Id) then
2114 SPARK_Msg_N ("property % must apply to a volatile object", N);
2118 -- Ensure that the Boolean expression (if present) is static. A missing
2119 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2123 if Present (Arg1) then
2124 Expr := Get_Pragma_Arg (Arg1);
2126 if Is_OK_Static_Expression (Expr) then
2127 Expr_Val := Is_True (Expr_Value (Expr));
2131 Set_Is_Analyzed_Pragma (N);
2132 end Analyze_External_Property_In_Decl_Part;
2134 ---------------------------------
2135 -- Analyze_Global_In_Decl_Part --
2136 ---------------------------------
2138 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2139 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2140 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2141 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2143 Constits_Seen : Elist_Id := No_Elist;
2144 -- A list containing the entities of all constituents processed so far.
2145 -- It aids in detecting illegal usage of a state and a corresponding
2146 -- constituent in pragma [Refinde_]Global.
2148 Seen : Elist_Id := No_Elist;
2149 -- A list containing the entities of all the items processed so far. It
2150 -- plays a role in detecting distinct entities.
2152 States_Seen : Elist_Id := No_Elist;
2153 -- A list containing the entities of all states processed so far. It
2154 -- helps in detecting illegal usage of a state and a corresponding
2155 -- constituent in pragma [Refined_]Global.
2157 In_Out_Seen : Boolean := False;
2158 Input_Seen : Boolean := False;
2159 Output_Seen : Boolean := False;
2160 Proof_Seen : Boolean := False;
2161 -- Flags used to verify the consistency of modes
2163 procedure Analyze_Global_List
2165 Global_Mode : Name_Id := Name_Input);
2166 -- Verify the legality of a single global list declaration. Global_Mode
2167 -- denotes the current mode in effect.
2169 -------------------------
2170 -- Analyze_Global_List --
2171 -------------------------
2173 procedure Analyze_Global_List
2175 Global_Mode : Name_Id := Name_Input)
2177 procedure Analyze_Global_Item
2179 Global_Mode : Name_Id);
2180 -- Verify the legality of a single global item declaration denoted by
2181 -- Item. Global_Mode denotes the current mode in effect.
2183 procedure Check_Duplicate_Mode
2185 Status : in out Boolean);
2186 -- Flag Status denotes whether a particular mode has been seen while
2187 -- processing a global list. This routine verifies that Mode is not a
2188 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2190 procedure Check_Mode_Restriction_In_Enclosing_Context
2192 Item_Id : Entity_Id);
2193 -- Verify that an item of mode In_Out or Output does not appear as
2194 -- an input in the Global aspect of an enclosing subprogram or task
2195 -- unit. If this is the case, emit an error. Item and Item_Id are
2196 -- respectively the item and its entity.
2198 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2199 -- Mode denotes either In_Out or Output. Depending on the kind of the
2200 -- related subprogram, emit an error if those two modes apply to a
2201 -- function (SPARK RM 6.1.4(10)).
2203 -------------------------
2204 -- Analyze_Global_Item --
2205 -------------------------
2207 procedure Analyze_Global_Item
2209 Global_Mode : Name_Id)
2211 Item_Id : Entity_Id;
2214 -- Detect one of the following cases
2216 -- with Global => (null, Name)
2217 -- with Global => (Name_1, null, Name_2)
2218 -- with Global => (Name, null)
2220 if Nkind (Item) = N_Null then
2221 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2226 Resolve_State (Item);
2228 -- Find the entity of the item. If this is a renaming, climb the
2229 -- renaming chain to reach the root object. Renamings of non-
2230 -- entire objects do not yield an entity (Empty).
2232 Item_Id := Entity_Of (Item);
2234 if Present (Item_Id) then
2236 -- A global item may denote a formal parameter of an enclosing
2237 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2238 -- provide a better error diagnostic.
2240 if Is_Formal (Item_Id) then
2241 if Scope (Item_Id) = Spec_Id then
2243 (Fix_Msg (Spec_Id, "global item cannot reference "
2244 & "parameter of subprogram &"), Item, Spec_Id);
2248 -- A global item may denote a concurrent type as long as it is
2249 -- the current instance of an enclosing protected or task type
2250 -- (SPARK RM 6.1.4).
2252 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2253 if Is_CCT_Instance (Item_Id, Spec_Id) then
2255 -- Pragma [Refined_]Global associated with a protected
2256 -- subprogram cannot mention the current instance of a
2257 -- protected type because the instance behaves as a
2258 -- formal parameter.
2260 if Ekind (Item_Id) = E_Protected_Type then
2261 if Scope (Spec_Id) = Item_Id then
2262 Error_Msg_Name_1 := Chars (Item_Id);
2264 (Fix_Msg (Spec_Id, "global item of subprogram & "
2265 & "cannot reference current instance of "
2266 & "protected type %"), Item, Spec_Id);
2270 -- Pragma [Refined_]Global associated with a task type
2271 -- cannot mention the current instance of a task type
2272 -- because the instance behaves as a formal parameter.
2274 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2275 if Spec_Id = Item_Id then
2276 Error_Msg_Name_1 := Chars (Item_Id);
2278 (Fix_Msg (Spec_Id, "global item of subprogram & "
2279 & "cannot reference current instance of task "
2280 & "type %"), Item, Spec_Id);
2285 -- Otherwise the global item denotes a subtype mark that is
2286 -- not a current instance.
2290 ("invalid use of subtype mark in global list", Item);
2294 -- A global item may denote the anonymous object created for a
2295 -- single protected/task type as long as the current instance
2296 -- is the same single type (SPARK RM 6.1.4).
2298 elsif Is_Single_Concurrent_Object (Item_Id)
2299 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id)
2301 -- Pragma [Refined_]Global associated with a protected
2302 -- subprogram cannot mention the current instance of a
2303 -- protected type because the instance behaves as a formal
2306 if Is_Single_Protected_Object (Item_Id) then
2307 if Scope (Spec_Id) = Etype (Item_Id) then
2308 Error_Msg_Name_1 := Chars (Item_Id);
2310 (Fix_Msg (Spec_Id, "global item of subprogram & "
2311 & "cannot reference current instance of protected "
2312 & "type %"), Item, Spec_Id);
2316 -- Pragma [Refined_]Global associated with a task type
2317 -- cannot mention the current instance of a task type
2318 -- because the instance behaves as a formal parameter.
2320 else pragma Assert (Is_Single_Task_Object (Item_Id));
2321 if Spec_Id = Item_Id then
2322 Error_Msg_Name_1 := Chars (Item_Id);
2324 (Fix_Msg (Spec_Id, "global item of subprogram & "
2325 & "cannot reference current instance of task "
2326 & "type %"), Item, Spec_Id);
2331 -- A formal object may act as a global item inside a generic
2333 elsif Is_Formal_Object (Item_Id) then
2336 -- The only legal references are those to abstract states,
2337 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2339 elsif not Ekind_In (Item_Id, E_Abstract_State,
2345 ("global item must denote object, state or current "
2346 & "instance of concurrent type", Item);
2348 if Ekind (Item_Id) in Named_Kind then
2350 ("\named number & is not an object", Item, Item);
2356 -- State related checks
2358 if Ekind (Item_Id) = E_Abstract_State then
2360 -- Package and subprogram bodies are instantiated
2361 -- individually in a separate compiler pass. Due to this
2362 -- mode of instantiation, the refinement of a state may
2363 -- no longer be visible when a subprogram body contract
2364 -- is instantiated. Since the generic template is legal,
2365 -- do not perform this check in the instance to circumvent
2368 if Is_Generic_Instance (Spec_Id) then
2371 -- An abstract state with visible refinement cannot appear
2372 -- in pragma [Refined_]Global as its place must be taken by
2373 -- some of its constituents (SPARK RM 6.1.4(7)).
2375 elsif Has_Visible_Refinement (Item_Id) then
2377 ("cannot mention state & in global refinement",
2379 SPARK_Msg_N ("\use its constituents instead", Item);
2382 -- An external state cannot appear as a global item of a
2383 -- nonvolatile function (SPARK RM 7.1.3(8)).
2385 elsif Is_External_State (Item_Id)
2386 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2387 and then not Is_Volatile_Function (Spec_Id)
2390 ("external state & cannot act as global item of "
2391 & "nonvolatile function", Item, Item_Id);
2394 -- If the reference to the abstract state appears in an
2395 -- enclosing package body that will eventually refine the
2396 -- state, record the reference for future checks.
2399 Record_Possible_Body_Reference
2400 (State_Id => Item_Id,
2404 -- Constant related checks
2406 elsif Ekind (Item_Id) = E_Constant then
2408 -- A constant is a read-only item, therefore it cannot act
2411 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2413 ("constant & cannot act as output", Item, Item_Id);
2417 -- Loop parameter related checks
2419 elsif Ekind (Item_Id) = E_Loop_Parameter then
2421 -- A loop parameter is a read-only item, therefore it cannot
2422 -- act as an output.
2424 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2426 ("loop parameter & cannot act as output",
2431 -- Variable related checks. These are only relevant when
2432 -- SPARK_Mode is on as they are not standard Ada legality
2435 elsif SPARK_Mode = On
2436 and then Ekind (Item_Id) = E_Variable
2437 and then Is_Effectively_Volatile (Item_Id)
2439 -- An effectively volatile object cannot appear as a global
2440 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2442 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2443 and then not Is_Volatile_Function (Spec_Id)
2446 ("volatile object & cannot act as global item of a "
2447 & "function", Item, Item_Id);
2450 -- An effectively volatile object with external property
2451 -- Effective_Reads set to True must have mode Output or
2452 -- In_Out (SPARK RM 7.1.3(10)).
2454 elsif Effective_Reads_Enabled (Item_Id)
2455 and then Global_Mode = Name_Input
2458 ("volatile object & with property Effective_Reads must "
2459 & "have mode In_Out or Output", Item, Item_Id);
2464 -- When the item renames an entire object, replace the item
2465 -- with a reference to the object.
2467 if Entity (Item) /= Item_Id then
2468 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2472 -- Some form of illegal construct masquerading as a name
2473 -- (SPARK RM 6.1.4(4)).
2477 ("global item must denote object, state or current instance "
2478 & "of concurrent type", Item);
2482 -- Verify that an output does not appear as an input in an
2483 -- enclosing subprogram.
2485 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2486 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2489 -- The same entity might be referenced through various way.
2490 -- Check the entity of the item rather than the item itself
2491 -- (SPARK RM 6.1.4(10)).
2493 if Contains (Seen, Item_Id) then
2494 SPARK_Msg_N ("duplicate global item", Item);
2496 -- Add the entity of the current item to the list of processed
2500 Append_New_Elmt (Item_Id, Seen);
2502 if Ekind (Item_Id) = E_Abstract_State then
2503 Append_New_Elmt (Item_Id, States_Seen);
2505 -- The variable may eventually become a constituent of a single
2506 -- protected/task type. Record the reference now and verify its
2507 -- legality when analyzing the contract of the variable
2510 elsif Ekind (Item_Id) = E_Variable then
2511 Record_Possible_Part_Of_Reference
2516 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2517 and then Present (Encapsulating_State (Item_Id))
2519 Append_New_Elmt (Item_Id, Constits_Seen);
2522 end Analyze_Global_Item;
2524 --------------------------
2525 -- Check_Duplicate_Mode --
2526 --------------------------
2528 procedure Check_Duplicate_Mode
2530 Status : in out Boolean)
2534 SPARK_Msg_N ("duplicate global mode", Mode);
2538 end Check_Duplicate_Mode;
2540 -------------------------------------------------
2541 -- Check_Mode_Restriction_In_Enclosing_Context --
2542 -------------------------------------------------
2544 procedure Check_Mode_Restriction_In_Enclosing_Context
2546 Item_Id : Entity_Id)
2548 Context : Entity_Id;
2550 Inputs : Elist_Id := No_Elist;
2551 Outputs : Elist_Id := No_Elist;
2554 -- Traverse the scope stack looking for enclosing subprograms or
2555 -- tasks subject to pragma [Refined_]Global.
2557 Context := Scope (Subp_Id);
2558 while Present (Context) and then Context /= Standard_Standard loop
2560 -- For a single task type, retrieve the corresponding object to
2561 -- which pragma [Refined_]Global is attached.
2563 if Ekind (Context) = E_Task_Type
2564 and then Is_Single_Concurrent_Type (Context)
2566 Context := Anonymous_Object (Context);
2569 if (Is_Subprogram (Context)
2570 or else Ekind (Context) = E_Task_Type
2571 or else Is_Single_Task_Object (Context))
2573 (Present (Get_Pragma (Context, Pragma_Global))
2575 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2577 Collect_Subprogram_Inputs_Outputs
2578 (Subp_Id => Context,
2579 Subp_Inputs => Inputs,
2580 Subp_Outputs => Outputs,
2581 Global_Seen => Dummy);
2583 -- The item is classified as In_Out or Output but appears as
2584 -- an Input in an enclosing subprogram or task unit (SPARK
2587 if Appears_In (Inputs, Item_Id)
2588 and then not Appears_In (Outputs, Item_Id)
2591 ("global item & cannot have mode In_Out or Output",
2594 if Is_Subprogram (Context) then
2596 (Fix_Msg (Subp_Id, "\item already appears as input "
2597 & "of subprogram &"), Item, Context);
2600 (Fix_Msg (Subp_Id, "\item already appears as input "
2601 & "of task &"), Item, Context);
2604 -- Stop the traversal once an error has been detected
2610 Context := Scope (Context);
2612 end Check_Mode_Restriction_In_Enclosing_Context;
2614 ----------------------------------------
2615 -- Check_Mode_Restriction_In_Function --
2616 ----------------------------------------
2618 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2620 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2622 ("global mode & is not applicable to functions", Mode);
2624 end Check_Mode_Restriction_In_Function;
2632 -- Start of processing for Analyze_Global_List
2635 if Nkind (List) = N_Null then
2636 Set_Analyzed (List);
2638 -- Single global item declaration
2640 elsif Nkind_In (List, N_Expanded_Name,
2642 N_Selected_Component)
2644 Analyze_Global_Item (List, Global_Mode);
2646 -- Simple global list or moded global list declaration
2648 elsif Nkind (List) = N_Aggregate then
2649 Set_Analyzed (List);
2651 -- The declaration of a simple global list appear as a collection
2654 if Present (Expressions (List)) then
2655 if Present (Component_Associations (List)) then
2657 ("cannot mix moded and non-moded global lists", List);
2660 Item := First (Expressions (List));
2661 while Present (Item) loop
2662 Analyze_Global_Item (Item, Global_Mode);
2666 -- The declaration of a moded global list appears as a collection
2667 -- of component associations where individual choices denote
2670 elsif Present (Component_Associations (List)) then
2671 if Present (Expressions (List)) then
2673 ("cannot mix moded and non-moded global lists", List);
2676 Assoc := First (Component_Associations (List));
2677 while Present (Assoc) loop
2678 Mode := First (Choices (Assoc));
2680 if Nkind (Mode) = N_Identifier then
2681 if Chars (Mode) = Name_In_Out then
2682 Check_Duplicate_Mode (Mode, In_Out_Seen);
2683 Check_Mode_Restriction_In_Function (Mode);
2685 elsif Chars (Mode) = Name_Input then
2686 Check_Duplicate_Mode (Mode, Input_Seen);
2688 elsif Chars (Mode) = Name_Output then
2689 Check_Duplicate_Mode (Mode, Output_Seen);
2690 Check_Mode_Restriction_In_Function (Mode);
2692 elsif Chars (Mode) = Name_Proof_In then
2693 Check_Duplicate_Mode (Mode, Proof_Seen);
2696 SPARK_Msg_N ("invalid mode selector", Mode);
2700 SPARK_Msg_N ("invalid mode selector", Mode);
2703 -- Items in a moded list appear as a collection of
2704 -- expressions. Reuse the existing machinery to analyze
2708 (List => Expression (Assoc),
2709 Global_Mode => Chars (Mode));
2717 raise Program_Error;
2720 -- Any other attempt to declare a global item is illegal. This is a
2721 -- syntax error, always report.
2724 Error_Msg_N ("malformed global list", List);
2726 end Analyze_Global_List;
2730 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2732 Restore_Scope : Boolean := False;
2734 -- Start of processing for Analyze_Global_In_Decl_Part
2737 -- Do not analyze the pragma multiple times
2739 if Is_Analyzed_Pragma (N) then
2743 -- There is nothing to be done for a null global list
2745 if Nkind (Items) = N_Null then
2746 Set_Analyzed (Items);
2748 -- Analyze the various forms of global lists and items. Note that some
2749 -- of these may be malformed in which case the analysis emits error
2753 -- When pragma [Refined_]Global appears on a single concurrent type,
2754 -- it is relocated to the anonymous object.
2756 if Is_Single_Concurrent_Object (Spec_Id) then
2759 -- Ensure that the formal parameters are visible when processing an
2760 -- item. This falls out of the general rule of aspects pertaining to
2761 -- subprogram declarations.
2763 elsif not In_Open_Scopes (Spec_Id) then
2764 Restore_Scope := True;
2765 Push_Scope (Spec_Id);
2767 if Ekind (Spec_Id) = E_Task_Type then
2768 if Has_Discriminants (Spec_Id) then
2769 Install_Discriminants (Spec_Id);
2772 elsif Is_Generic_Subprogram (Spec_Id) then
2773 Install_Generic_Formals (Spec_Id);
2776 Install_Formals (Spec_Id);
2780 Analyze_Global_List (Items);
2782 if Restore_Scope then
2787 -- Ensure that a state and a corresponding constituent do not appear
2788 -- together in pragma [Refined_]Global.
2790 Check_State_And_Constituent_Use
2791 (States => States_Seen,
2792 Constits => Constits_Seen,
2795 Set_Is_Analyzed_Pragma (N);
2796 end Analyze_Global_In_Decl_Part;
2798 --------------------------------------------
2799 -- Analyze_Initial_Condition_In_Decl_Part --
2800 --------------------------------------------
2802 -- WARNING: This routine manages Ghost regions. Return statements must be
2803 -- replaced by gotos which jump to the end of the routine and restore the
2806 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2807 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2808 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2809 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2811 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2812 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2813 -- Save the Ghost-related attributes to restore on exit
2816 -- Do not analyze the pragma multiple times
2818 if Is_Analyzed_Pragma (N) then
2822 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2823 -- analysis of the pragma, the Ghost mode at point of declaration and
2824 -- point of analysis may not necessarily be the same. Use the mode in
2825 -- effect at the point of declaration.
2829 -- The expression is preanalyzed because it has not been moved to its
2830 -- final place yet. A direct analysis may generate side effects and this
2831 -- is not desired at this point.
2833 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2834 Set_Is_Analyzed_Pragma (N);
2836 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2837 end Analyze_Initial_Condition_In_Decl_Part;
2839 --------------------------------------
2840 -- Analyze_Initializes_In_Decl_Part --
2841 --------------------------------------
2843 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2844 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2845 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2847 Constits_Seen : Elist_Id := No_Elist;
2848 -- A list containing the entities of all constituents processed so far.
2849 -- It aids in detecting illegal usage of a state and a corresponding
2850 -- constituent in pragma Initializes.
2852 Items_Seen : Elist_Id := No_Elist;
2853 -- A list of all initialization items processed so far. This list is
2854 -- used to detect duplicate items.
2856 States_And_Objs : Elist_Id := No_Elist;
2857 -- A list of all abstract states and objects declared in the visible
2858 -- declarations of the related package. This list is used to detect the
2859 -- legality of initialization items.
2861 States_Seen : Elist_Id := No_Elist;
2862 -- A list containing the entities of all states processed so far. It
2863 -- helps in detecting illegal usage of a state and a corresponding
2864 -- constituent in pragma Initializes.
2866 procedure Analyze_Initialization_Item (Item : Node_Id);
2867 -- Verify the legality of a single initialization item
2869 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2870 -- Verify the legality of a single initialization item followed by a
2871 -- list of input items.
2873 procedure Collect_States_And_Objects;
2874 -- Inspect the visible declarations of the related package and gather
2875 -- the entities of all abstract states and objects in States_And_Objs.
2877 ---------------------------------
2878 -- Analyze_Initialization_Item --
2879 ---------------------------------
2881 procedure Analyze_Initialization_Item (Item : Node_Id) is
2882 Item_Id : Entity_Id;
2886 Resolve_State (Item);
2888 if Is_Entity_Name (Item) then
2889 Item_Id := Entity_Of (Item);
2891 if Present (Item_Id)
2892 and then Ekind_In (Item_Id, E_Abstract_State,
2896 -- When the initialization item is undefined, it appears as
2897 -- Any_Id. Do not continue with the analysis of the item.
2899 if Item_Id = Any_Id then
2902 -- The state or variable must be declared in the visible
2903 -- declarations of the package (SPARK RM 7.1.5(7)).
2905 elsif not Contains (States_And_Objs, Item_Id) then
2906 Error_Msg_Name_1 := Chars (Pack_Id);
2908 ("initialization item & must appear in the visible "
2909 & "declarations of package %", Item, Item_Id);
2911 -- Detect a duplicate use of the same initialization item
2912 -- (SPARK RM 7.1.5(5)).
2914 elsif Contains (Items_Seen, Item_Id) then
2915 SPARK_Msg_N ("duplicate initialization item", Item);
2917 -- The item is legal, add it to the list of processed states
2921 Append_New_Elmt (Item_Id, Items_Seen);
2923 if Ekind (Item_Id) = E_Abstract_State then
2924 Append_New_Elmt (Item_Id, States_Seen);
2927 if Present (Encapsulating_State (Item_Id)) then
2928 Append_New_Elmt (Item_Id, Constits_Seen);
2932 -- The item references something that is not a state or object
2933 -- (SPARK RM 7.1.5(3)).
2937 ("initialization item must denote object or state", Item);
2940 -- Some form of illegal construct masquerading as a name
2941 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2945 ("initialization item must denote object or state", Item);
2947 end Analyze_Initialization_Item;
2949 ---------------------------------------------
2950 -- Analyze_Initialization_Item_With_Inputs --
2951 ---------------------------------------------
2953 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2954 Inputs_Seen : Elist_Id := No_Elist;
2955 -- A list of all inputs processed so far. This list is used to detect
2956 -- duplicate uses of an input.
2958 Non_Null_Seen : Boolean := False;
2959 Null_Seen : Boolean := False;
2960 -- Flags used to check the legality of an input list
2962 procedure Analyze_Input_Item (Input : Node_Id);
2963 -- Verify the legality of a single input item
2965 ------------------------
2966 -- Analyze_Input_Item --
2967 ------------------------
2969 procedure Analyze_Input_Item (Input : Node_Id) is
2970 Input_Id : Entity_Id;
2975 if Nkind (Input) = N_Null then
2978 ("multiple null initializations not allowed", Item);
2980 elsif Non_Null_Seen then
2982 ("cannot mix null and non-null initialization item", Item);
2990 Non_Null_Seen := True;
2994 ("cannot mix null and non-null initialization item", Item);
2998 Resolve_State (Input);
3000 if Is_Entity_Name (Input) then
3001 Input_Id := Entity_Of (Input);
3003 if Present (Input_Id)
3004 and then Ekind_In (Input_Id, E_Abstract_State,
3006 E_Generic_In_Out_Parameter,
3007 E_Generic_In_Parameter,
3015 -- The input cannot denote states or objects declared
3016 -- within the related package (SPARK RM 7.1.5(4)).
3018 if Within_Scope (Input_Id, Current_Scope) then
3020 -- Do not consider generic formal parameters or their
3021 -- respective mappings to generic formals. Even though
3022 -- the formals appear within the scope of the package,
3023 -- it is allowed for an initialization item to depend
3024 -- on an input item.
3026 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
3027 E_Generic_In_Parameter)
3031 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
3032 and then Present (Corresponding_Generic_Association
3033 (Declaration_Node (Input_Id)))
3038 Error_Msg_Name_1 := Chars (Pack_Id);
3040 ("input item & cannot denote a visible object or "
3041 & "state of package %", Input, Input_Id);
3046 -- Detect a duplicate use of the same input item
3047 -- (SPARK RM 7.1.5(5)).
3049 if Contains (Inputs_Seen, Input_Id) then
3050 SPARK_Msg_N ("duplicate input item", Input);
3054 -- At this point it is known that the input is legal. Add
3055 -- it to the list of processed inputs.
3057 Append_New_Elmt (Input_Id, Inputs_Seen);
3059 if Ekind (Input_Id) = E_Abstract_State then
3060 Append_New_Elmt (Input_Id, States_Seen);
3063 if Ekind_In (Input_Id, E_Abstract_State,
3066 and then Present (Encapsulating_State (Input_Id))
3068 Append_New_Elmt (Input_Id, Constits_Seen);
3071 -- The input references something that is not a state or an
3072 -- object (SPARK RM 7.1.5(3)).
3076 ("input item must denote object or state", Input);
3079 -- Some form of illegal construct masquerading as a name
3080 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3084 ("input item must denote object or state", Input);
3087 end Analyze_Input_Item;
3091 Inputs : constant Node_Id := Expression (Item);
3095 Name_Seen : Boolean := False;
3096 -- A flag used to detect multiple item names
3098 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3101 -- Inspect the name of an item with inputs
3103 Elmt := First (Choices (Item));
3104 while Present (Elmt) loop
3106 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3109 Analyze_Initialization_Item (Elmt);
3115 -- Multiple input items appear as an aggregate
3117 if Nkind (Inputs) = N_Aggregate then
3118 if Present (Expressions (Inputs)) then
3119 Input := First (Expressions (Inputs));
3120 while Present (Input) loop
3121 Analyze_Input_Item (Input);
3126 if Present (Component_Associations (Inputs)) then
3128 ("inputs must appear in named association form", Inputs);
3131 -- Single input item
3134 Analyze_Input_Item (Inputs);
3136 end Analyze_Initialization_Item_With_Inputs;
3138 --------------------------------
3139 -- Collect_States_And_Objects --
3140 --------------------------------
3142 procedure Collect_States_And_Objects is
3143 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3147 -- Collect the abstract states defined in the package (if any)
3149 if Present (Abstract_States (Pack_Id)) then
3150 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3153 -- Collect all objects that appear in the visible declarations of the
3156 if Present (Visible_Declarations (Pack_Spec)) then
3157 Decl := First (Visible_Declarations (Pack_Spec));
3158 while Present (Decl) loop
3159 if Comes_From_Source (Decl)
3160 and then Nkind_In (Decl, N_Object_Declaration,
3161 N_Object_Renaming_Declaration)
3163 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3165 elsif Is_Single_Concurrent_Type_Declaration (Decl) then
3167 (Anonymous_Object (Defining_Entity (Decl)),
3174 end Collect_States_And_Objects;
3178 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3181 -- Start of processing for Analyze_Initializes_In_Decl_Part
3184 -- Do not analyze the pragma multiple times
3186 if Is_Analyzed_Pragma (N) then
3190 -- Nothing to do when the initialization list is empty
3192 if Nkind (Inits) = N_Null then
3196 -- Single and multiple initialization clauses appear as an aggregate. If
3197 -- this is not the case, then either the parser or the analysis of the
3198 -- pragma failed to produce an aggregate.
3200 pragma Assert (Nkind (Inits) = N_Aggregate);
3202 -- Initialize the various lists used during analysis
3204 Collect_States_And_Objects;
3206 if Present (Expressions (Inits)) then
3207 Init := First (Expressions (Inits));
3208 while Present (Init) loop
3209 Analyze_Initialization_Item (Init);
3214 if Present (Component_Associations (Inits)) then
3215 Init := First (Component_Associations (Inits));
3216 while Present (Init) loop
3217 Analyze_Initialization_Item_With_Inputs (Init);
3222 -- Ensure that a state and a corresponding constituent do not appear
3223 -- together in pragma Initializes.
3225 Check_State_And_Constituent_Use
3226 (States => States_Seen,
3227 Constits => Constits_Seen,
3230 Set_Is_Analyzed_Pragma (N);
3231 end Analyze_Initializes_In_Decl_Part;
3233 ---------------------
3234 -- Analyze_Part_Of --
3235 ---------------------
3237 procedure Analyze_Part_Of
3239 Item_Id : Entity_Id;
3241 Encap_Id : out Entity_Id;
3242 Legal : out Boolean)
3244 procedure Check_Part_Of_Abstract_State;
3245 pragma Inline (Check_Part_Of_Abstract_State);
3246 -- Verify the legality of indicator Part_Of when the encapsulator is an
3249 procedure Check_Part_Of_Concurrent_Type;
3250 pragma Inline (Check_Part_Of_Concurrent_Type);
3251 -- Verify the legality of indicator Part_Of when the encapsulator is a
3252 -- single concurrent type.
3254 ----------------------------------
3255 -- Check_Part_Of_Abstract_State --
3256 ----------------------------------
3258 procedure Check_Part_Of_Abstract_State is
3259 Pack_Id : Entity_Id;
3260 Placement : State_Space_Kind;
3261 Parent_Unit : Entity_Id;
3264 -- Determine where the object, package instantiation or state lives
3265 -- with respect to the enclosing packages or package bodies.
3267 Find_Placement_In_State_Space
3268 (Item_Id => Item_Id,
3269 Placement => Placement,
3270 Pack_Id => Pack_Id);
3272 -- The item appears in a non-package construct with a declarative
3273 -- part (subprogram, block, etc). As such, the item is not allowed
3274 -- to be a part of an encapsulating state because the item is not
3277 if Placement = Not_In_Package then
3279 ("indicator Part_Of cannot appear in this context "
3280 & "(SPARK RM 7.2.6(5))", Indic);
3282 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3284 ("\& is not part of the hidden state of package %",
3288 -- The item appears in the visible state space of some package. In
3289 -- general this scenario does not warrant Part_Of except when the
3290 -- package is a nongeneric private child unit and the encapsulating
3291 -- state is declared in a parent unit or a public descendant of that
3294 elsif Placement = Visible_State_Space then
3295 if Is_Child_Unit (Pack_Id)
3296 and then not Is_Generic_Unit (Pack_Id)
3297 and then Is_Private_Descendant (Pack_Id)
3299 -- A variable or state abstraction which is part of the visible
3300 -- state of a nongeneric private child unit or its public
3301 -- descendants must have its Part_Of indicator specified. The
3302 -- Part_Of indicator must denote a state declared by either the
3303 -- parent unit of the private unit or by a public descendant of
3304 -- that parent unit.
3306 -- Find the nearest private ancestor (which can be the current
3309 Parent_Unit := Pack_Id;
3310 while Present (Parent_Unit) loop
3313 (Parent (Unit_Declaration_Node (Parent_Unit)));
3314 Parent_Unit := Scope (Parent_Unit);
3317 Parent_Unit := Scope (Parent_Unit);
3319 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3321 ("indicator Part_Of must denote abstract state of & or of "
3322 & "its public descendant (SPARK RM 7.2.6(3))",
3323 Indic, Parent_Unit);
3326 elsif Scope (Encap_Id) = Parent_Unit
3328 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3329 and then not Is_Private_Descendant (Scope (Encap_Id)))
3335 ("indicator Part_Of must denote abstract state of & or of "
3336 & "its public descendant (SPARK RM 7.2.6(3))",
3337 Indic, Parent_Unit);
3341 -- Indicator Part_Of is not needed when the related package is
3342 -- not a nongeneric private child unit or a public descendant
3347 ("indicator Part_Of cannot appear in this context "
3348 & "(SPARK RM 7.2.6(5))", Indic);
3350 Error_Msg_Name_1 := Chars (Pack_Id);
3352 ("\& is declared in the visible part of package %",
3357 -- When the item appears in the private state space of a package, the
3358 -- encapsulating state must be declared in the same package.
3360 elsif Placement = Private_State_Space then
3361 if Scope (Encap_Id) /= Pack_Id then
3363 ("indicator Part_Of must denote an abstract state of "
3364 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3366 Error_Msg_Name_1 := Chars (Pack_Id);
3368 ("\& is declared in the private part of package %",
3373 -- Items declared in the body state space of a package do not need
3374 -- Part_Of indicators as the refinement has already been seen.
3378 ("indicator Part_Of cannot appear in this context "
3379 & "(SPARK RM 7.2.6(5))", Indic);
3381 if Scope (Encap_Id) = Pack_Id then
3382 Error_Msg_Name_1 := Chars (Pack_Id);
3384 ("\& is declared in the body of package %", Indic, Item_Id);
3390 -- At this point it is known that the Part_Of indicator is legal
3393 end Check_Part_Of_Abstract_State;
3395 -----------------------------------
3396 -- Check_Part_Of_Concurrent_Type --
3397 -----------------------------------
3399 procedure Check_Part_Of_Concurrent_Type is
3400 function In_Proper_Order
3402 Second : Node_Id) return Boolean;
3403 pragma Inline (In_Proper_Order);
3404 -- Determine whether node First precedes node Second
3406 procedure Placement_Error;
3407 pragma Inline (Placement_Error);
3408 -- Emit an error concerning the illegal placement of the item with
3409 -- respect to the single concurrent type.
3411 ---------------------
3412 -- In_Proper_Order --
3413 ---------------------
3415 function In_Proper_Order
3417 Second : Node_Id) return Boolean
3422 if List_Containing (First) = List_Containing (Second) then
3424 while Present (N) loop
3434 end In_Proper_Order;
3436 ---------------------
3437 -- Placement_Error --
3438 ---------------------
3440 procedure Placement_Error is
3443 ("indicator Part_Of must denote a previously declared single "
3444 & "protected type or single task type", Encap);
3445 end Placement_Error;
3449 Conc_Typ : constant Entity_Id := Etype (Encap_Id);
3450 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id);
3451 Encap_Context : constant Node_Id := Parent (Encap_Decl);
3453 Item_Context : Node_Id;
3454 Item_Decl : Node_Id;
3455 Prv_Decls : List_Id;
3456 Vis_Decls : List_Id;
3458 -- Start of processing for Check_Part_Of_Concurrent_Type
3461 -- Only abstract states and variables can act as constituents of an
3462 -- encapsulating single concurrent type.
3464 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3467 -- The constituent is a constant
3469 elsif Ekind (Item_Id) = E_Constant then
3470 Error_Msg_Name_1 := Chars (Encap_Id);
3472 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of "
3473 & "single protected type %"), Indic, Item_Id);
3476 -- The constituent is a package instantiation
3479 Error_Msg_Name_1 := Chars (Encap_Id);
3481 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as "
3482 & "constituent of single protected type %"), Indic, Item_Id);
3486 -- When the item denotes an abstract state of a nested package, use
3487 -- the declaration of the package to detect proper placement.
3492 -- with Abstract_State => (State with Part_Of => T)
3494 if Ekind (Item_Id) = E_Abstract_State then
3495 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3497 Item_Decl := Declaration_Node (Item_Id);
3500 Item_Context := Parent (Item_Decl);
3502 -- The item and the single concurrent type must appear in the same
3503 -- declarative region, with the item following the declaration of
3504 -- the single concurrent type (SPARK RM 9(3)).
3506 if Item_Context = Encap_Context then
3507 if Nkind_In (Item_Context, N_Package_Specification,
3508 N_Protected_Definition,
3511 Prv_Decls := Private_Declarations (Item_Context);
3512 Vis_Decls := Visible_Declarations (Item_Context);
3514 -- The placement is OK when the single concurrent type appears
3515 -- within the visible declarations and the item in the private
3521 -- Constit : ... with Part_Of => PO;
3524 if List_Containing (Encap_Decl) = Vis_Decls
3525 and then List_Containing (Item_Decl) = Prv_Decls
3529 -- The placement is illegal when the item appears within the
3530 -- visible declarations and the single concurrent type is in
3531 -- the private declarations.
3534 -- Constit : ... with Part_Of => PO;
3539 elsif List_Containing (Item_Decl) = Vis_Decls
3540 and then List_Containing (Encap_Decl) = Prv_Decls
3545 -- Otherwise both the item and the single concurrent type are
3546 -- in the same list. Ensure that the declaration of the single
3547 -- concurrent type precedes that of the item.
3549 elsif not In_Proper_Order
3550 (First => Encap_Decl,
3551 Second => Item_Decl)
3557 -- Otherwise both the item and the single concurrent type are
3558 -- in the same list. Ensure that the declaration of the single
3559 -- concurrent type precedes that of the item.
3561 elsif not In_Proper_Order
3562 (First => Encap_Decl,
3563 Second => Item_Decl)
3569 -- Otherwise the item and the single concurrent type reside within
3570 -- unrelated regions.
3573 Error_Msg_Name_1 := Chars (Encap_Id);
3575 (Fix_Msg (Conc_Typ, "constituent & must be declared "
3576 & "immediately within the same region as single protected "
3577 & "type %"), Indic, Item_Id);
3581 -- At this point it is known that the Part_Of indicator is legal
3584 end Check_Part_Of_Concurrent_Type;
3586 -- Start of processing for Analyze_Part_Of
3589 -- Assume that the indicator is illegal
3594 if Nkind_In (Encap, N_Expanded_Name,
3596 N_Selected_Component)
3599 Resolve_State (Encap);
3601 Encap_Id := Entity (Encap);
3603 -- The encapsulator is an abstract state
3605 if Ekind (Encap_Id) = E_Abstract_State then
3608 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3610 elsif Is_Single_Concurrent_Object (Encap_Id) then
3613 -- Otherwise the encapsulator is not a legal choice
3617 ("indicator Part_Of must denote abstract state, single "
3618 & "protected type or single task type", Encap);
3622 -- This is a syntax error, always report
3626 ("indicator Part_Of must denote abstract state, single protected "
3627 & "type or single task type", Encap);
3631 -- Catch a case where indicator Part_Of denotes the abstract view of a
3632 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3634 if From_Limited_With (Encap_Id)
3635 and then Present (Non_Limited_View (Encap_Id))
3636 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3638 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3639 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3643 -- The encapsulator is an abstract state
3645 if Ekind (Encap_Id) = E_Abstract_State then
3646 Check_Part_Of_Abstract_State;
3648 -- The encapsulator is a single concurrent type
3651 Check_Part_Of_Concurrent_Type;
3653 end Analyze_Part_Of;
3655 ----------------------------------
3656 -- Analyze_Part_Of_In_Decl_Part --
3657 ----------------------------------
3659 procedure Analyze_Part_Of_In_Decl_Part
3661 Freeze_Id : Entity_Id := Empty)
3663 Encap : constant Node_Id :=
3664 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3665 Errors : constant Nat := Serious_Errors_Detected;
3666 Var_Decl : constant Node_Id := Find_Related_Context (N);
3667 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3668 Constits : Elist_Id;
3669 Encap_Id : Entity_Id;
3673 -- Detect any discrepancies between the placement of the variable with
3674 -- respect to general state space and the encapsulating state or single
3681 Encap_Id => Encap_Id,
3684 -- The Part_Of indicator turns the variable into a constituent of the
3685 -- encapsulating state or single concurrent type.
3688 pragma Assert (Present (Encap_Id));
3689 Constits := Part_Of_Constituents (Encap_Id);
3691 if No (Constits) then
3692 Constits := New_Elmt_List;
3693 Set_Part_Of_Constituents (Encap_Id, Constits);
3696 Append_Elmt (Var_Id, Constits);
3697 Set_Encapsulating_State (Var_Id, Encap_Id);
3699 -- A Part_Of constituent partially refines an abstract state. This
3700 -- property does not apply to protected or task units.
3702 if Ekind (Encap_Id) = E_Abstract_State then
3703 Set_Has_Partial_Visible_Refinement (Encap_Id);
3707 -- Emit a clarification message when the encapsulator is undefined,
3708 -- possibly due to contract freezing.
3710 if Errors /= Serious_Errors_Detected
3711 and then Present (Freeze_Id)
3712 and then Has_Undefined_Reference (Encap)
3714 Contract_Freeze_Error (Var_Id, Freeze_Id);
3716 end Analyze_Part_Of_In_Decl_Part;
3718 --------------------
3719 -- Analyze_Pragma --
3720 --------------------
3722 procedure Analyze_Pragma (N : Node_Id) is
3723 Loc : constant Source_Ptr := Sloc (N);
3725 Pname : Name_Id := Pragma_Name (N);
3726 -- Name of the source pragma, or name of the corresponding aspect for
3727 -- pragmas which originate in a source aspect. In the latter case, the
3728 -- name may be different from the pragma name.
3730 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
3732 Pragma_Exit : exception;
3733 -- This exception is used to exit pragma processing completely. It
3734 -- is used when an error is detected, and no further processing is
3735 -- required. It is also used if an earlier error has left the tree in
3736 -- a state where the pragma should not be processed.
3739 -- Number of pragma argument associations
3745 -- First four pragma arguments (pragma argument association nodes, or
3746 -- Empty if the corresponding argument does not exist).
3748 type Name_List is array (Natural range <>) of Name_Id;
3749 type Args_List is array (Natural range <>) of Node_Id;
3750 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3752 -----------------------
3753 -- Local Subprograms --
3754 -----------------------
3756 function Acc_First (N : Node_Id) return Node_Id;
3757 -- Helper function to iterate over arguments given to OpenAcc pragmas
3759 function Acc_Next (N : Node_Id) return Node_Id;
3760 -- Helper function to iterate over arguments given to OpenAcc pragmas
3762 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3763 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3764 -- get the given string argument, and place it in Name_Buffer, adding
3765 -- leading and trailing asterisks if they are not already present. The
3766 -- caller has already checked that Arg is a static string expression.
3768 procedure Ada_2005_Pragma;
3769 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3770 -- Ada 95 mode, these are implementation defined pragmas, so should be
3771 -- caught by the No_Implementation_Pragmas restriction.
3773 procedure Ada_2012_Pragma;
3774 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3775 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3776 -- should be caught by the No_Implementation_Pragmas restriction.
3778 procedure Analyze_Depends_Global
3779 (Spec_Id : out Entity_Id;
3780 Subp_Decl : out Node_Id;
3781 Legal : out Boolean);
3782 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3783 -- legality of the placement and related context of the pragma. Spec_Id
3784 -- is the entity of the related subprogram. Subp_Decl is the declaration
3785 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3787 procedure Analyze_If_Present (Id : Pragma_Id);
3788 -- Inspect the remainder of the list containing pragma N and look for
3789 -- a pragma that matches Id. If found, analyze the pragma.
3791 procedure Analyze_Pre_Post_Condition;
3792 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3794 procedure Analyze_Refined_Depends_Global_Post
3795 (Spec_Id : out Entity_Id;
3796 Body_Id : out Entity_Id;
3797 Legal : out Boolean);
3798 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3799 -- Refined_Global and Refined_Post. Verify the legality of the placement
3800 -- and related context of the pragma. Spec_Id is the entity of the
3801 -- related subprogram. Body_Id is the entity of the subprogram body.
3802 -- Flag Legal is set when the pragma is legal.
3804 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3805 -- Perform full analysis of pragma Unmodified and the write aspect of
3806 -- pragma Unused. Flag Is_Unused should be set when verifying the
3807 -- semantics of pragma Unused.
3809 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3810 -- Perform full analysis of pragma Unreferenced and the read aspect of
3811 -- pragma Unused. Flag Is_Unused should be set when verifying the
3812 -- semantics of pragma Unused.
3814 procedure Check_Ada_83_Warning;
3815 -- Issues a warning message for the current pragma if operating in Ada
3816 -- 83 mode (used for language pragmas that are not a standard part of
3817 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3820 procedure Check_Arg_Count (Required : Nat);
3821 -- Check argument count for pragma is equal to given parameter. If not,
3822 -- then issue an error message and raise Pragma_Exit.
3824 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3825 -- Arg which can either be a pragma argument association, in which case
3826 -- the check is applied to the expression of the association or an
3827 -- expression directly.
3829 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3830 -- Check that an argument has the right form for an EXTERNAL_NAME
3831 -- parameter of an extended import/export pragma. The rule is that the
3832 -- name must be an identifier or string literal (in Ada 83 mode) or a
3833 -- static string expression (in Ada 95 mode).
3835 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3836 -- Check the specified argument Arg to make sure that it is an
3837 -- identifier. If not give error and raise Pragma_Exit.
3839 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3840 -- Check the specified argument Arg to make sure that it is an integer
3841 -- literal. If not give error and raise Pragma_Exit.
3843 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3844 -- Check the specified argument Arg to make sure that it has the proper
3845 -- syntactic form for a local name and meets the semantic requirements
3846 -- for a local name. The local name is analyzed as part of the
3847 -- processing for this call. In addition, the local name is required
3848 -- to represent an entity at the library level.
3850 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3851 -- Check the specified argument Arg to make sure that it has the proper
3852 -- syntactic form for a local name and meets the semantic requirements
3853 -- for a local name. The local name is analyzed as part of the
3854 -- processing for this call.
3856 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3857 -- Check the specified argument Arg to make sure that it is a valid
3858 -- locking policy name. If not give error and raise Pragma_Exit.
3860 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3861 -- Check the specified argument Arg to make sure that it is a valid
3862 -- elaboration policy name. If not give error and raise Pragma_Exit.
3864 procedure Check_Arg_Is_One_Of
3867 procedure Check_Arg_Is_One_Of
3869 N1, N2, N3 : Name_Id);
3870 procedure Check_Arg_Is_One_Of
3872 N1, N2, N3, N4 : Name_Id);
3873 procedure Check_Arg_Is_One_Of
3875 N1, N2, N3, N4, N5 : Name_Id);
3876 -- Check the specified argument Arg to make sure that it is an
3877 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3878 -- present). If not then give error and raise Pragma_Exit.
3880 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3881 -- Check the specified argument Arg to make sure that it is a valid
3882 -- queuing policy name. If not give error and raise Pragma_Exit.
3884 procedure Check_Arg_Is_OK_Static_Expression
3886 Typ : Entity_Id := Empty);
3887 -- Check the specified argument Arg to make sure that it is a static
3888 -- expression of the given type (i.e. it will be analyzed and resolved
3889 -- using this type, which can be any valid argument to Resolve, e.g.
3890 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3891 -- Typ is left Empty, then any static expression is allowed. Includes
3892 -- checking that the argument does not raise Constraint_Error.
3894 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3895 -- Check the specified argument Arg to make sure that it is a valid task
3896 -- dispatching policy name. If not give error and raise Pragma_Exit.
3898 procedure Check_Arg_Order (Names : Name_List);
3899 -- Checks for an instance of two arguments with identifiers for the
3900 -- current pragma which are not in the sequence indicated by Names,
3901 -- and if so, generates a fatal message about bad order of arguments.
3903 procedure Check_At_Least_N_Arguments (N : Nat);
3904 -- Check there are at least N arguments present
3906 procedure Check_At_Most_N_Arguments (N : Nat);
3907 -- Check there are no more than N arguments present
3909 procedure Check_Component
3912 In_Variant_Part : Boolean := False);
3913 -- Examine an Unchecked_Union component for correct use of per-object
3914 -- constrained subtypes, and for restrictions on finalizable components.
3915 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3916 -- should be set when Comp comes from a record variant.
3918 procedure Check_Duplicate_Pragma (E : Entity_Id);
3919 -- Check if a rep item of the same name as the current pragma is already
3920 -- chained as a rep pragma to the given entity. If so give a message
3921 -- about the duplicate, and then raise Pragma_Exit so does not return.
3922 -- Note that if E is a type, then this routine avoids flagging a pragma
3923 -- which applies to a parent type from which E is derived.
3925 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3926 -- Nam is an N_String_Literal node containing the external name set by
3927 -- an Import or Export pragma (or extended Import or Export pragma).
3928 -- This procedure checks for possible duplications if this is the export
3929 -- case, and if found, issues an appropriate error message.
3931 procedure Check_Expr_Is_OK_Static_Expression
3933 Typ : Entity_Id := Empty);
3934 -- Check the specified expression Expr to make sure that it is a static
3935 -- expression of the given type (i.e. it will be analyzed and resolved
3936 -- using this type, which can be any valid argument to Resolve, e.g.
3937 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3938 -- Typ is left Empty, then any static expression is allowed. Includes
3939 -- checking that the expression does not raise Constraint_Error.
3941 procedure Check_First_Subtype (Arg : Node_Id);
3942 -- Checks that Arg, whose expression is an entity name, references a
3945 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3946 -- Checks that the given argument has an identifier, and if so, requires
3947 -- it to match the given identifier name. If there is no identifier, or
3948 -- a non-matching identifier, then an error message is given and
3949 -- Pragma_Exit is raised.
3951 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3952 -- Checks that the given argument has an identifier, and if so, requires
3953 -- it to match one of the given identifier names. If there is no
3954 -- identifier, or a non-matching identifier, then an error message is
3955 -- given and Pragma_Exit is raised.
3957 procedure Check_In_Main_Program;
3958 -- Common checks for pragmas that appear within a main program
3959 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3961 procedure Check_Interrupt_Or_Attach_Handler;
3962 -- Common processing for first argument of pragma Interrupt_Handler or
3963 -- pragma Attach_Handler.
3965 procedure Check_Loop_Pragma_Placement;
3966 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3967 -- appear immediately within a construct restricted to loops, and that
3968 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3970 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3971 -- Check that pragma appears in a declarative part, or in a package
3972 -- specification, i.e. that it does not occur in a statement sequence
3975 procedure Check_No_Identifier (Arg : Node_Id);
3976 -- Checks that the given argument does not have an identifier. If
3977 -- an identifier is present, then an error message is issued, and
3978 -- Pragma_Exit is raised.
3980 procedure Check_No_Identifiers;
3981 -- Checks that none of the arguments to the pragma has an identifier.
3982 -- If any argument has an identifier, then an error message is issued,
3983 -- and Pragma_Exit is raised.
3985 procedure Check_No_Link_Name;
3986 -- Checks that no link name is specified
3988 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3989 -- Checks if the given argument has an identifier, and if so, requires
3990 -- it to match the given identifier name. If there is a non-matching
3991 -- identifier, then an error message is given and Pragma_Exit is raised.
3993 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3994 -- Checks if the given argument has an identifier, and if so, requires
3995 -- it to match the given identifier name. If there is a non-matching
3996 -- identifier, then an error message is given and Pragma_Exit is raised.
3997 -- In this version of the procedure, the identifier name is given as
3998 -- a string with lower case letters.
4000 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
4001 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4002 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4003 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4004 -- is an OK static boolean expression. Emit an error if this is not the
4007 procedure Check_Static_Constraint (Constr : Node_Id);
4008 -- Constr is a constraint from an N_Subtype_Indication node from a
4009 -- component constraint in an Unchecked_Union type. This routine checks
4010 -- that the constraint is static as required by the restrictions for
4013 procedure Check_Valid_Configuration_Pragma;
4014 -- Legality checks for placement of a configuration pragma
4016 procedure Check_Valid_Library_Unit_Pragma;
4017 -- Legality checks for library unit pragmas. A special case arises for
4018 -- pragmas in generic instances that come from copies of the original
4019 -- library unit pragmas in the generic templates. In the case of other
4020 -- than library level instantiations these can appear in contexts which
4021 -- would normally be invalid (they only apply to the original template
4022 -- and to library level instantiations), and they are simply ignored,
4023 -- which is implemented by rewriting them as null statements.
4025 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
4026 -- Check an Unchecked_Union variant for lack of nested variants and
4027 -- presence of at least one component. UU_Typ is the related Unchecked_
4030 procedure Ensure_Aggregate_Form (Arg : Node_Id);
4031 -- Subsidiary routine to the processing of pragmas Abstract_State,
4032 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4033 -- Refined_Global and Refined_State. Transform argument Arg into
4034 -- an aggregate if not one already. N_Null is never transformed.
4035 -- Arg may denote an aspect specification or a pragma argument
4038 procedure Error_Pragma (Msg : String);
4039 pragma No_Return (Error_Pragma);
4040 -- Outputs error message for current pragma. The message contains a %
4041 -- that will be replaced with the pragma name, and the flag is placed
4042 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4043 -- calls Fix_Error (see spec of that procedure for details).
4045 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
4046 pragma No_Return (Error_Pragma_Arg);
4047 -- Outputs error message for current pragma. The message may contain
4048 -- a % that will be replaced with the pragma name. The parameter Arg
4049 -- may either be a pragma argument association, in which case the flag
4050 -- is placed on the expression of this association, or an expression,
4051 -- in which case the flag is placed directly on the expression. The
4052 -- message is placed using Error_Msg_N, so the message may also contain
4053 -- an & insertion character which will reference the given Arg value.
4054 -- After placing the message, Pragma_Exit is raised. Note: this routine
4055 -- calls Fix_Error (see spec of that procedure for details).
4057 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
4058 pragma No_Return (Error_Pragma_Arg);
4059 -- Similar to above form of Error_Pragma_Arg except that two messages
4060 -- are provided, the second is a continuation comment starting with \.
4062 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
4063 pragma No_Return (Error_Pragma_Arg_Ident);
4064 -- Outputs error message for current pragma. The message may contain a %
4065 -- that will be replaced with the pragma name. The parameter Arg must be
4066 -- a pragma argument association with a non-empty identifier (i.e. its
4067 -- Chars field must be set), and the error message is placed on the
4068 -- identifier. The message is placed using Error_Msg_N so the message
4069 -- may also contain an & insertion character which will reference
4070 -- the identifier. After placing the message, Pragma_Exit is raised.
4071 -- Note: this routine calls Fix_Error (see spec of that procedure for
4074 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
4075 pragma No_Return (Error_Pragma_Ref);
4076 -- Outputs error message for current pragma. The message may contain
4077 -- a % that will be replaced with the pragma name. The parameter Ref
4078 -- must be an entity whose name can be referenced by & and sloc by #.
4079 -- After placing the message, Pragma_Exit is raised. Note: this routine
4080 -- calls Fix_Error (see spec of that procedure for details).
4082 function Find_Lib_Unit_Name return Entity_Id;
4083 -- Used for a library unit pragma to find the entity to which the
4084 -- library unit pragma applies, returns the entity found.
4086 procedure Find_Program_Unit_Name (Id : Node_Id);
4087 -- If the pragma is a compilation unit pragma, the id must denote the
4088 -- compilation unit in the same compilation, and the pragma must appear
4089 -- in the list of preceding or trailing pragmas. If it is a program
4090 -- unit pragma that is not a compilation unit pragma, then the
4091 -- identifier must be visible.
4093 function Find_Unique_Parameterless_Procedure
4095 Arg : Node_Id) return Entity_Id;
4096 -- Used for a procedure pragma to find the unique parameterless
4097 -- procedure identified by Name, returns it if it exists, otherwise
4098 -- errors out and uses Arg as the pragma argument for the message.
4100 function Fix_Error (Msg : String) return String;
4101 -- This is called prior to issuing an error message. Msg is the normal
4102 -- error message issued in the pragma case. This routine checks for the
4103 -- case of a pragma coming from an aspect in the source, and returns a
4104 -- message suitable for the aspect case as follows:
4106 -- Each substring "pragma" is replaced by "aspect"
4108 -- If "argument of" is at the start of the error message text, it is
4109 -- replaced by "entity for".
4111 -- If "argument" is at the start of the error message text, it is
4112 -- replaced by "entity".
4114 -- So for example, "argument of pragma X must be discrete type"
4115 -- returns "entity for aspect X must be a discrete type".
4117 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4118 -- be different from the pragma name). If the current pragma results
4119 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4120 -- original pragma name.
4122 procedure Gather_Associations
4124 Args : out Args_List);
4125 -- This procedure is used to gather the arguments for a pragma that
4126 -- permits arbitrary ordering of parameters using the normal rules
4127 -- for named and positional parameters. The Names argument is a list
4128 -- of Name_Id values that corresponds to the allowed pragma argument
4129 -- association identifiers in order. The result returned in Args is
4130 -- a list of corresponding expressions that are the pragma arguments.
4131 -- Note that this is a list of expressions, not of pragma argument
4132 -- associations (Gather_Associations has completely checked all the
4133 -- optional identifiers when it returns). An entry in Args is Empty
4134 -- on return if the corresponding argument is not present.
4136 procedure GNAT_Pragma;
4137 -- Called for all GNAT defined pragmas to check the relevant restriction
4138 -- (No_Implementation_Pragmas).
4140 function Is_Before_First_Decl
4141 (Pragma_Node : Node_Id;
4142 Decls : List_Id) return Boolean;
4143 -- Return True if Pragma_Node is before the first declarative item in
4144 -- Decls where Decls is the list of declarative items.
4146 function Is_Configuration_Pragma return Boolean;
4147 -- Determines if the placement of the current pragma is appropriate
4148 -- for a configuration pragma.
4150 function Is_In_Context_Clause return Boolean;
4151 -- Returns True if pragma appears within the context clause of a unit,
4152 -- and False for any other placement (does not generate any messages).
4154 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
4155 -- Analyzes the argument, and determines if it is a static string
4156 -- expression, returns True if so, False if non-static or not String.
4157 -- A special case is that a string literal returns True in Ada 83 mode
4158 -- (which has no such thing as static string expressions). Note that
4159 -- the call analyzes its argument, so this cannot be used for the case
4160 -- where an identifier might not be declared.
4162 procedure Pragma_Misplaced;
4163 pragma No_Return (Pragma_Misplaced);
4164 -- Issue fatal error message for misplaced pragma
4166 procedure Process_Atomic_Independent_Shared_Volatile;
4167 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4168 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4169 -- and treated as being identical in effect to pragma Atomic.
4171 procedure Process_Compile_Time_Warning_Or_Error;
4172 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4174 procedure Process_Convention
4175 (C : out Convention_Id;
4176 Ent : out Entity_Id);
4177 -- Common processing for Convention, Interface, Import and Export.
4178 -- Checks first two arguments of pragma, and sets the appropriate
4179 -- convention value in the specified entity or entities. On return
4180 -- C is the convention, Ent is the referenced entity.
4182 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
4183 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4184 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4186 procedure Process_Extended_Import_Export_Object_Pragma
4187 (Arg_Internal : Node_Id;
4188 Arg_External : Node_Id;
4189 Arg_Size : Node_Id);
4190 -- Common processing for the pragmas Import/Export_Object. The three
4191 -- arguments correspond to the three named parameters of the pragmas. An
4192 -- argument is empty if the corresponding parameter is not present in
4195 procedure Process_Extended_Import_Export_Internal_Arg
4196 (Arg_Internal : Node_Id := Empty);
4197 -- Common processing for all extended Import and Export pragmas. The
4198 -- argument is the pragma parameter for the Internal argument. If
4199 -- Arg_Internal is empty or inappropriate, an error message is posted.
4200 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4201 -- set to identify the referenced entity.
4203 procedure Process_Extended_Import_Export_Subprogram_Pragma
4204 (Arg_Internal : Node_Id;
4205 Arg_External : Node_Id;
4206 Arg_Parameter_Types : Node_Id;
4207 Arg_Result_Type : Node_Id := Empty;
4208 Arg_Mechanism : Node_Id;
4209 Arg_Result_Mechanism : Node_Id := Empty);
4210 -- Common processing for all extended Import and Export pragmas applying
4211 -- to subprograms. The caller omits any arguments that do not apply to
4212 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4213 -- only in the Import_Function and Export_Function cases). The argument
4214 -- names correspond to the allowed pragma association identifiers.
4216 procedure Process_Generic_List;
4217 -- Common processing for Share_Generic and Inline_Generic
4219 procedure Process_Import_Or_Interface;
4220 -- Common processing for Import or Interface
4222 procedure Process_Import_Predefined_Type;
4223 -- Processing for completing a type with pragma Import. This is used
4224 -- to declare types that match predefined C types, especially for cases
4225 -- without corresponding Ada predefined type.
4227 type Inline_Status is (Suppressed, Disabled, Enabled);
4228 -- Inline status of a subprogram, indicated as follows:
4229 -- Suppressed: inlining is suppressed for the subprogram
4230 -- Disabled: no inlining is requested for the subprogram
4231 -- Enabled: inlining is requested/required for the subprogram
4233 procedure Process_Inline (Status : Inline_Status);
4234 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4235 -- indicates the inline status specified by the pragma.
4237 procedure Process_Interface_Name
4238 (Subprogram_Def : Entity_Id;
4242 -- Given the last two arguments of pragma Import, pragma Export, or
4243 -- pragma Interface_Name, performs validity checks and sets the
4244 -- Interface_Name field of the given subprogram entity to the
4245 -- appropriate external or link name, depending on the arguments given.
4246 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4247 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4248 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4249 -- nor Link_Arg is present, the interface name is set to the default
4250 -- from the subprogram name. In addition, the pragma itself is passed
4251 -- to analyze any expressions in the case the pragma came from an aspect
4254 procedure Process_Interrupt_Or_Attach_Handler;
4255 -- Common processing for Interrupt and Attach_Handler pragmas
4257 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
4258 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4259 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4260 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4261 -- is not set in the Restrictions case.
4263 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
4264 -- Common processing for Suppress and Unsuppress. The boolean parameter
4265 -- Suppress_Case is True for the Suppress case, and False for the
4268 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
4269 -- Subsidiary to the analysis of pragmas Independent[_Components].
4270 -- Record such a pragma N applied to entity E for future checks.
4272 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
4273 -- This procedure sets the Is_Exported flag for the given entity,
4274 -- checking that the entity was not previously imported. Arg is
4275 -- the argument that specified the entity. A check is also made
4276 -- for exporting inappropriate entities.
4278 procedure Set_Extended_Import_Export_External_Name
4279 (Internal_Ent : Entity_Id;
4280 Arg_External : Node_Id);
4281 -- Common processing for all extended import export pragmas. The first
4282 -- argument, Internal_Ent, is the internal entity, which has already
4283 -- been checked for validity by the caller. Arg_External is from the
4284 -- Import or Export pragma, and may be null if no External parameter
4285 -- was present. If Arg_External is present and is a non-null string
4286 -- (a null string is treated as the default), then the Interface_Name
4287 -- field of Internal_Ent is set appropriately.
4289 procedure Set_Imported (E : Entity_Id);
4290 -- This procedure sets the Is_Imported flag for the given entity,
4291 -- checking that it is not previously exported or imported.
4293 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
4294 -- Mech is a parameter passing mechanism (see Import_Function syntax
4295 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4296 -- has the right form, and if not issues an error message. If the
4297 -- argument has the right form then the Mechanism field of Ent is
4298 -- set appropriately.
4300 procedure Set_Rational_Profile;
4301 -- Activate the set of configuration pragmas and permissions that make
4302 -- up the Rational profile.
4304 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4305 -- Activate the set of configuration pragmas and restrictions that make
4306 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4307 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4308 -- which is used for error messages on any constructs violating the
4311 procedure Validate_Acc_Condition_Clause (Clause : Node_Id);
4312 -- Make sure the argument of a given Acc_If clause is a Boolean
4314 procedure Validate_Acc_Data_Clause (Clause : Node_Id);
4315 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4316 -- Copyout...) is an identifier or an aggregate of identifiers.
4318 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id);
4319 -- Make sure the argument of an OpenAcc clause is an Integer expression
4321 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id);
4322 -- Make sure the argument of an OpenAcc clause is an Integer expression
4323 -- or a list of Integer expressions.
4325 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id);
4326 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4327 -- contains at least N-1 nested loops.
4329 procedure Validate_Acc_Loop_Gang (Clause : Node_Id);
4330 -- Make sure the argument of the Gang clause of a Loop directive is
4331 -- either an integer expression or a (Static => integer expressions)
4334 procedure Validate_Acc_Loop_Vector (Clause : Node_Id);
4335 -- When this procedure is called in a construct offloaded by an
4336 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4337 -- not exist on said pragma. In all cases, make sure the argument
4338 -- is an Integer expression.
4340 procedure Validate_Acc_Loop_Worker (Clause : Node_Id);
4341 -- When this procedure is called in a construct offloaded by an
4342 -- Acc_Parallel pragma, makes sure that no argument has been given.
4343 -- When this procedure is called in a construct offloaded by an
4344 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4345 -- makes sure that the Num_Workers clause does not appear on the
4346 -- Acc_Kernels pragma and that the argument is an integer.
4348 procedure Validate_Acc_Name_Reduction (Clause : Node_Id);
4349 -- Make sure the reduction clause is an aggregate made of a string
4350 -- representing a supported reduction operation (i.e. "+", "*", "and",
4351 -- "or", "min" or "max") and either an identifier or aggregate of
4354 procedure Validate_Acc_Size_Expressions (Clause : Node_Id);
4355 -- Makes sure that Clause is either an integer expression or an
4356 -- association with a Static as name and a list of integer expressions
4357 -- or "*" strings on the right hand side.
4363 function Acc_First (N : Node_Id) return Node_Id is
4365 if Nkind (N) = N_Aggregate then
4366 if Present (Expressions (N)) then
4367 return First (Expressions (N));
4369 elsif Present (Component_Associations (N)) then
4370 return Expression (First (Component_Associations (N)));
4381 function Acc_Next (N : Node_Id) return Node_Id is
4383 if Nkind (Parent (N)) = N_Component_Association then
4384 return Expression (Next (Parent (N)));
4386 elsif Nkind (Parent (N)) = N_Aggregate then
4394 ----------------------------------
4395 -- Acquire_Warning_Match_String --
4396 ----------------------------------
4398 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4400 String_To_Name_Buffer
4401 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4403 -- Add asterisk at start if not already there
4405 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4406 Name_Buffer (2 .. Name_Len + 1) :=
4407 Name_Buffer (1 .. Name_Len);
4408 Name_Buffer (1) := '*';
4409 Name_Len := Name_Len + 1;
4412 -- Add asterisk at end if not already there
4414 if Name_Buffer (Name_Len) /= '*' then
4415 Name_Len := Name_Len + 1;
4416 Name_Buffer (Name_Len) := '*';
4418 end Acquire_Warning_Match_String;
4420 ---------------------
4421 -- Ada_2005_Pragma --
4422 ---------------------
4424 procedure Ada_2005_Pragma is
4426 if Ada_Version <= Ada_95 then
4427 Check_Restriction (No_Implementation_Pragmas, N);
4429 end Ada_2005_Pragma;
4431 ---------------------
4432 -- Ada_2012_Pragma --
4433 ---------------------
4435 procedure Ada_2012_Pragma is
4437 if Ada_Version <= Ada_2005 then
4438 Check_Restriction (No_Implementation_Pragmas, N);
4440 end Ada_2012_Pragma;
4442 ----------------------------
4443 -- Analyze_Depends_Global --
4444 ----------------------------
4446 procedure Analyze_Depends_Global
4447 (Spec_Id : out Entity_Id;
4448 Subp_Decl : out Node_Id;
4449 Legal : out Boolean)
4452 -- Assume that the pragma is illegal
4459 Check_Arg_Count (1);
4461 -- Ensure the proper placement of the pragma. Depends/Global must be
4462 -- associated with a subprogram declaration or a body that acts as a
4465 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4469 if Nkind (Subp_Decl) = N_Entry_Declaration then
4472 -- Generic subprogram
4474 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4477 -- Object declaration of a single concurrent type
4479 elsif Nkind (Subp_Decl) = N_Object_Declaration
4480 and then Is_Single_Concurrent_Object
4481 (Unique_Defining_Entity (Subp_Decl))
4487 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4490 -- Subprogram body acts as spec
4492 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4493 and then No (Corresponding_Spec (Subp_Decl))
4497 -- Subprogram body stub acts as spec
4499 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4500 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4504 -- Subprogram declaration
4506 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4511 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4519 -- If we get here, then the pragma is legal
4522 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4524 -- When the related context is an entry, the entry must belong to a
4525 -- protected unit (SPARK RM 6.1.4(6)).
4527 if Is_Entry_Declaration (Spec_Id)
4528 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4533 -- When the related context is an anonymous object created for a
4534 -- simple concurrent type, the type must be a task
4535 -- (SPARK RM 6.1.4(6)).
4537 elsif Is_Single_Concurrent_Object (Spec_Id)
4538 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4544 -- A pragma that applies to a Ghost entity becomes Ghost for the
4545 -- purposes of legality checks and removal of ignored Ghost code.
4547 Mark_Ghost_Pragma (N, Spec_Id);
4548 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4549 end Analyze_Depends_Global;
4551 ------------------------
4552 -- Analyze_If_Present --
4553 ------------------------
4555 procedure Analyze_If_Present (Id : Pragma_Id) is
4559 pragma Assert (Is_List_Member (N));
4561 -- Inspect the declarations or statements following pragma N looking
4562 -- for another pragma whose Id matches the caller's request. If it is
4563 -- available, analyze it.
4566 while Present (Stmt) loop
4567 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4568 Analyze_Pragma (Stmt);
4571 -- The first source declaration or statement immediately following
4572 -- N ends the region where a pragma may appear.
4574 elsif Comes_From_Source (Stmt) then
4580 end Analyze_If_Present;
4582 --------------------------------
4583 -- Analyze_Pre_Post_Condition --
4584 --------------------------------
4586 procedure Analyze_Pre_Post_Condition is
4587 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4588 Subp_Decl : Node_Id;
4589 Subp_Id : Entity_Id;
4591 Duplicates_OK : Boolean := False;
4592 -- Flag set when a pre/postcondition allows multiple pragmas of the
4595 In_Body_OK : Boolean := False;
4596 -- Flag set when a pre/postcondition is allowed to appear on a body
4597 -- even though the subprogram may have a spec.
4599 Is_Pre_Post : Boolean := False;
4600 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4603 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean;
4604 -- Implement rules in AI12-0131: an overriding operation can have
4605 -- a class-wide precondition only if one of its ancestors has an
4606 -- explicit class-wide precondition.
4608 -----------------------------
4609 -- Inherits_Class_Wide_Pre --
4610 -----------------------------
4612 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is
4613 Typ : constant Entity_Id := Find_Dispatching_Type (E);
4616 Prev : Entity_Id := Overridden_Operation (E);
4619 -- Check ancestors on the overriding operation to examine the
4620 -- preconditions that may apply to them.
4622 while Present (Prev) loop
4623 Cont := Contract (Prev);
4624 if Present (Cont) then
4625 Prag := Pre_Post_Conditions (Cont);
4626 while Present (Prag) loop
4627 if Pragma_Name (Prag) = Name_Precondition
4628 and then Class_Present (Prag)
4633 Prag := Next_Pragma (Prag);
4637 -- For a type derived from a generic formal type, the operation
4638 -- inheriting the condition is a renaming, not an overriding of
4639 -- the operation of the formal. Ditto for an inherited
4640 -- operation which has no explicit contracts.
4642 if Is_Generic_Type (Find_Dispatching_Type (Prev))
4643 or else not Comes_From_Source (Prev)
4645 Prev := Alias (Prev);
4647 Prev := Overridden_Operation (Prev);
4651 -- If the controlling type of the subprogram has progenitors, an
4652 -- interface operation implemented by the current operation may
4653 -- have a class-wide precondition.
4655 if Has_Interfaces (Typ) then
4660 Prim_Elmt : Elmt_Id;
4661 Prim_List : Elist_Id;
4664 Collect_Interfaces (Typ, Ints);
4665 Elmt := First_Elmt (Ints);
4667 -- Iterate over the primitive operations of each interface
4669 while Present (Elmt) loop
4670 Prim_List := Direct_Primitive_Operations (Node (Elmt));
4671 Prim_Elmt := First_Elmt (Prim_List);
4672 while Present (Prim_Elmt) loop
4673 Prim := Node (Prim_Elmt);
4674 if Chars (Prim) = Chars (E)
4675 and then Present (Contract (Prim))
4676 and then Class_Present
4677 (Pre_Post_Conditions (Contract (Prim)))
4682 Next_Elmt (Prim_Elmt);
4691 end Inherits_Class_Wide_Pre;
4693 -- Start of processing for Analyze_Pre_Post_Condition
4696 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4697 -- offer uniformity among the various kinds of pre/postconditions by
4698 -- rewriting the pragma identifier. This allows the retrieval of the
4699 -- original pragma name by routine Original_Aspect_Pragma_Name.
4701 if Comes_From_Source (N) then
4702 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4703 Is_Pre_Post := True;
4704 Set_Class_Present (N, Pname = Name_Pre_Class);
4705 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4707 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4708 Is_Pre_Post := True;
4709 Set_Class_Present (N, Pname = Name_Post_Class);
4710 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4714 -- Determine the semantics with respect to duplicates and placement
4715 -- in a body. Pragmas Precondition and Postcondition were introduced
4716 -- before aspects and are not subject to the same aspect-like rules.
4718 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4719 Duplicates_OK := True;
4725 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4726 -- argument without an identifier.
4729 Check_Arg_Count (1);
4730 Check_No_Identifiers;
4732 -- Pragmas Precondition and Postcondition have complex argument
4736 Check_At_Least_N_Arguments (1);
4737 Check_At_Most_N_Arguments (2);
4738 Check_Optional_Identifier (Arg1, Name_Check);
4740 if Present (Arg2) then
4741 Check_Optional_Identifier (Arg2, Name_Message);
4742 Preanalyze_Spec_Expression
4743 (Get_Pragma_Arg (Arg2), Standard_String);
4747 -- For a pragma PPC in the extended main source unit, record enabled
4749 -- ??? nothing checks that the pragma is in the main source unit
4751 if Is_Checked (N) and then not Split_PPC (N) then
4752 Set_SCO_Pragma_Enabled (Loc);
4755 -- Ensure the proper placement of the pragma
4758 Find_Related_Declaration_Or_Body
4759 (N, Do_Checks => not Duplicates_OK);
4761 -- When a pre/postcondition pragma applies to an abstract subprogram,
4762 -- its original form must be an aspect with 'Class.
4764 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4765 if not From_Aspect_Specification (N) then
4767 ("pragma % cannot be applied to abstract subprogram");
4769 elsif not Class_Present (N) then
4771 ("aspect % requires ''Class for abstract subprogram");
4774 -- Entry declaration
4776 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4779 -- Generic subprogram declaration
4781 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4786 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4787 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4791 -- Subprogram body stub
4793 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4794 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4798 -- Subprogram declaration
4800 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4802 -- AI05-0230: When a pre/postcondition pragma applies to a null
4803 -- procedure, its original form must be an aspect with 'Class.
4805 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4806 and then Null_Present (Specification (Subp_Decl))
4807 and then From_Aspect_Specification (N)
4808 and then not Class_Present (N)
4810 Error_Pragma ("aspect % requires ''Class for null procedure");
4813 -- Implement the legality checks mandated by AI12-0131:
4814 -- Pre'Class shall not be specified for an overriding primitive
4815 -- subprogram of a tagged type T unless the Pre'Class aspect is
4816 -- specified for the corresponding primitive subprogram of some
4820 E : constant Entity_Id := Defining_Entity (Subp_Decl);
4823 if Class_Present (N)
4824 and then Pragma_Name (N) = Name_Precondition
4825 and then Present (Overridden_Operation (E))
4826 and then not Inherits_Class_Wide_Pre (E)
4829 ("illegal class-wide precondition on overriding operation",
4830 Corresponding_Aspect (N));
4834 -- A renaming declaration may inherit a generated pragma, its
4835 -- placement comes from expansion, not from source.
4837 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
4838 and then not Comes_From_Source (N)
4842 -- Otherwise the placement is illegal
4849 Subp_Id := Defining_Entity (Subp_Decl);
4851 -- A pragma that applies to a Ghost entity becomes Ghost for the
4852 -- purposes of legality checks and removal of ignored Ghost code.
4854 Mark_Ghost_Pragma (N, Subp_Id);
4856 -- Chain the pragma on the contract for further processing by
4857 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4859 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4861 -- Fully analyze the pragma when it appears inside an entry or
4862 -- subprogram body because it cannot benefit from forward references.
4864 if Nkind_In (Subp_Decl, N_Entry_Body,
4866 N_Subprogram_Body_Stub)
4868 -- The legality checks of pragmas Precondition and Postcondition
4869 -- are affected by the SPARK mode in effect and the volatility of
4870 -- the context. Analyze all pragmas in a specific order.
4872 Analyze_If_Present (Pragma_SPARK_Mode);
4873 Analyze_If_Present (Pragma_Volatile_Function);
4874 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4876 end Analyze_Pre_Post_Condition;
4878 -----------------------------------------
4879 -- Analyze_Refined_Depends_Global_Post --
4880 -----------------------------------------
4882 procedure Analyze_Refined_Depends_Global_Post
4883 (Spec_Id : out Entity_Id;
4884 Body_Id : out Entity_Id;
4885 Legal : out Boolean)
4887 Body_Decl : Node_Id;
4888 Spec_Decl : Node_Id;
4891 -- Assume that the pragma is illegal
4898 Check_Arg_Count (1);
4899 Check_No_Identifiers;
4901 -- Verify the placement of the pragma and check for duplicates. The
4902 -- pragma must apply to a subprogram body [stub].
4904 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4906 if not Nkind_In (Body_Decl, N_Entry_Body,
4908 N_Subprogram_Body_Stub,
4916 Body_Id := Defining_Entity (Body_Decl);
4917 Spec_Id := Unique_Defining_Entity (Body_Decl);
4919 -- The pragma must apply to the second declaration of a subprogram.
4920 -- In other words, the body [stub] cannot acts as a spec.
4922 if No (Spec_Id) then
4923 Error_Pragma ("pragma % cannot apply to a stand alone body");
4926 -- Catch the case where the subprogram body is a subunit and acts as
4927 -- the third declaration of the subprogram.
4929 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4930 Error_Pragma ("pragma % cannot apply to a subunit");
4934 -- A refined pragma can only apply to the body [stub] of a subprogram
4935 -- declared in the visible part of a package. Retrieve the context of
4936 -- the subprogram declaration.
4938 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4940 -- When dealing with protected entries or protected subprograms, use
4941 -- the enclosing protected type as the proper context.
4943 if Ekind_In (Spec_Id, E_Entry,
4947 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4949 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4952 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4954 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4955 & "subprogram declared in a package specification"));
4959 -- If we get here, then the pragma is legal
4963 -- A pragma that applies to a Ghost entity becomes Ghost for the
4964 -- purposes of legality checks and removal of ignored Ghost code.
4966 Mark_Ghost_Pragma (N, Spec_Id);
4968 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4969 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4971 end Analyze_Refined_Depends_Global_Post;
4973 ----------------------------------
4974 -- Analyze_Unmodified_Or_Unused --
4975 ----------------------------------
4977 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4982 Ghost_Error_Posted : Boolean := False;
4983 -- Flag set when an error concerning the illegal mix of Ghost and
4984 -- non-Ghost variables is emitted.
4986 Ghost_Id : Entity_Id := Empty;
4987 -- The entity of the first Ghost variable encountered while
4988 -- processing the arguments of the pragma.
4992 Check_At_Least_N_Arguments (1);
4994 -- Loop through arguments
4997 while Present (Arg) loop
4998 Check_No_Identifier (Arg);
5000 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5001 -- in fact generate reference, so that the entity will have a
5002 -- reference, which will inhibit any warnings about it not
5003 -- being referenced, and also properly show up in the ali file
5004 -- as a reference. But this reference is recorded before the
5005 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5006 -- generated for this reference.
5008 Check_Arg_Is_Local_Name (Arg);
5009 Arg_Expr := Get_Pragma_Arg (Arg);
5011 if Is_Entity_Name (Arg_Expr) then
5012 Arg_Id := Entity (Arg_Expr);
5014 -- Skip processing the argument if already flagged
5016 if Is_Assignable (Arg_Id)
5017 and then not Has_Pragma_Unmodified (Arg_Id)
5018 and then not Has_Pragma_Unused (Arg_Id)
5020 Set_Has_Pragma_Unmodified (Arg_Id);
5023 Set_Has_Pragma_Unused (Arg_Id);
5026 -- A pragma that applies to a Ghost entity becomes Ghost for
5027 -- the purposes of legality checks and removal of ignored
5030 Mark_Ghost_Pragma (N, Arg_Id);
5032 -- Capture the entity of the first Ghost variable being
5033 -- processed for error detection purposes.
5035 if Is_Ghost_Entity (Arg_Id) then
5036 if No (Ghost_Id) then
5040 -- Otherwise the variable is non-Ghost. It is illegal to mix
5041 -- references to Ghost and non-Ghost entities
5044 elsif Present (Ghost_Id)
5045 and then not Ghost_Error_Posted
5047 Ghost_Error_Posted := True;
5049 Error_Msg_Name_1 := Pname;
5051 ("pragma % cannot mention ghost and non-ghost "
5054 Error_Msg_Sloc := Sloc (Ghost_Id);
5055 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
5057 Error_Msg_Sloc := Sloc (Arg_Id);
5058 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
5061 -- Warn if already flagged as Unused or Unmodified
5063 elsif Has_Pragma_Unmodified (Arg_Id) then
5064 if Has_Pragma_Unused (Arg_Id) then
5066 ("??pragma Unused already given for &!", Arg_Expr,
5070 ("??pragma Unmodified already given for &!", Arg_Expr,
5074 -- Otherwise the pragma referenced an illegal entity
5078 ("pragma% can only be applied to a variable", Arg_Expr);
5084 end Analyze_Unmodified_Or_Unused;
5086 ------------------------------------
5087 -- Analyze_Unreferenced_Or_Unused --
5088 ------------------------------------
5090 procedure Analyze_Unreferenced_Or_Unused
5091 (Is_Unused : Boolean := False)
5098 Ghost_Error_Posted : Boolean := False;
5099 -- Flag set when an error concerning the illegal mix of Ghost and
5100 -- non-Ghost names is emitted.
5102 Ghost_Id : Entity_Id := Empty;
5103 -- The entity of the first Ghost name encountered while processing
5104 -- the arguments of the pragma.
5108 Check_At_Least_N_Arguments (1);
5110 -- Check case of appearing within context clause
5112 if not Is_Unused and then Is_In_Context_Clause then
5114 -- The arguments must all be units mentioned in a with clause in
5115 -- the same context clause. Note that Par.Prag already checked
5116 -- that the arguments are either identifiers or selected
5120 while Present (Arg) loop
5121 Citem := First (List_Containing (N));
5122 while Citem /= N loop
5123 Arg_Expr := Get_Pragma_Arg (Arg);
5125 if Nkind (Citem) = N_With_Clause
5126 and then Same_Name (Name (Citem), Arg_Expr)
5128 Set_Has_Pragma_Unreferenced
5131 (Library_Unit (Citem))));
5132 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
5141 ("argument of pragma% is not withed unit", Arg);
5147 -- Case of not in list of context items
5151 while Present (Arg) loop
5152 Check_No_Identifier (Arg);
5154 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5155 -- in fact generate reference, so that the entity will have a
5156 -- reference, which will inhibit any warnings about it not
5157 -- being referenced, and also properly show up in the ali file
5158 -- as a reference. But this reference is recorded before the
5159 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5160 -- generated for this reference.
5162 Check_Arg_Is_Local_Name (Arg);
5163 Arg_Expr := Get_Pragma_Arg (Arg);
5165 if Is_Entity_Name (Arg_Expr) then
5166 Arg_Id := Entity (Arg_Expr);
5168 -- Warn if already flagged as Unused or Unreferenced and
5169 -- skip processing the argument.
5171 if Has_Pragma_Unreferenced (Arg_Id) then
5172 if Has_Pragma_Unused (Arg_Id) then
5174 ("??pragma Unused already given for &!", Arg_Expr,
5178 ("??pragma Unreferenced already given for &!",
5182 -- Apply Unreferenced to the entity
5185 -- If the entity is overloaded, the pragma applies to the
5186 -- most recent overloading, as documented. In this case,
5187 -- name resolution does not generate a reference, so it
5188 -- must be done here explicitly.
5190 if Is_Overloaded (Arg_Expr) then
5191 Generate_Reference (Arg_Id, N);
5194 Set_Has_Pragma_Unreferenced (Arg_Id);
5197 Set_Has_Pragma_Unused (Arg_Id);
5200 -- A pragma that applies to a Ghost entity becomes Ghost
5201 -- for the purposes of legality checks and removal of
5202 -- ignored Ghost code.
5204 Mark_Ghost_Pragma (N, Arg_Id);
5206 -- Capture the entity of the first Ghost name being
5207 -- processed for error detection purposes.
5209 if Is_Ghost_Entity (Arg_Id) then
5210 if No (Ghost_Id) then
5214 -- Otherwise the name is non-Ghost. It is illegal to mix
5215 -- references to Ghost and non-Ghost entities
5218 elsif Present (Ghost_Id)
5219 and then not Ghost_Error_Posted
5221 Ghost_Error_Posted := True;
5223 Error_Msg_Name_1 := Pname;
5225 ("pragma % cannot mention ghost and non-ghost "
5228 Error_Msg_Sloc := Sloc (Ghost_Id);
5230 ("\& # declared as ghost", N, Ghost_Id);
5232 Error_Msg_Sloc := Sloc (Arg_Id);
5234 ("\& # declared as non-ghost", N, Arg_Id);
5242 end Analyze_Unreferenced_Or_Unused;
5244 --------------------------
5245 -- Check_Ada_83_Warning --
5246 --------------------------
5248 procedure Check_Ada_83_Warning is
5250 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5251 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
5253 end Check_Ada_83_Warning;
5255 ---------------------
5256 -- Check_Arg_Count --
5257 ---------------------
5259 procedure Check_Arg_Count (Required : Nat) is
5261 if Arg_Count /= Required then
5262 Error_Pragma ("wrong number of arguments for pragma%");
5264 end Check_Arg_Count;
5266 --------------------------------
5267 -- Check_Arg_Is_External_Name --
5268 --------------------------------
5270 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
5271 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5274 if Nkind (Argx) = N_Identifier then
5278 Analyze_And_Resolve (Argx, Standard_String);
5280 if Is_OK_Static_Expression (Argx) then
5283 elsif Etype (Argx) = Any_Type then
5286 -- An interesting special case, if we have a string literal and
5287 -- we are in Ada 83 mode, then we allow it even though it will
5288 -- not be flagged as static. This allows expected Ada 83 mode
5289 -- use of external names which are string literals, even though
5290 -- technically these are not static in Ada 83.
5292 elsif Ada_Version = Ada_83
5293 and then Nkind (Argx) = N_String_Literal
5297 -- Here we have a real error (non-static expression)
5300 Error_Msg_Name_1 := Pname;
5301 Flag_Non_Static_Expr
5302 (Fix_Error ("argument for pragma% must be a identifier or "
5303 & "static string expression!"), Argx);
5308 end Check_Arg_Is_External_Name;
5310 -----------------------------
5311 -- Check_Arg_Is_Identifier --
5312 -----------------------------
5314 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
5315 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5317 if Nkind (Argx) /= N_Identifier then
5318 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
5320 end Check_Arg_Is_Identifier;
5322 ----------------------------------
5323 -- Check_Arg_Is_Integer_Literal --
5324 ----------------------------------
5326 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
5327 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5329 if Nkind (Argx) /= N_Integer_Literal then
5331 ("argument for pragma% must be integer literal", Argx);
5333 end Check_Arg_Is_Integer_Literal;
5335 -------------------------------------------
5336 -- Check_Arg_Is_Library_Level_Local_Name --
5337 -------------------------------------------
5341 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5342 -- | library_unit_NAME
5344 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
5346 Check_Arg_Is_Local_Name (Arg);
5348 -- If it came from an aspect, we want to give the error just as if it
5349 -- came from source.
5351 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
5352 and then (Comes_From_Source (N)
5353 or else Present (Corresponding_Aspect (Parent (Arg))))
5356 ("argument for pragma% must be library level entity", Arg);
5358 end Check_Arg_Is_Library_Level_Local_Name;
5360 -----------------------------
5361 -- Check_Arg_Is_Local_Name --
5362 -----------------------------
5366 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5367 -- | library_unit_NAME
5369 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
5370 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5373 -- If this pragma came from an aspect specification, we don't want to
5374 -- check for this error, because that would cause spurious errors, in
5375 -- case a type is frozen in a scope more nested than the type. The
5376 -- aspect itself of course can't be anywhere but on the declaration
5379 if Nkind (Arg) = N_Pragma_Argument_Association then
5380 if From_Aspect_Specification (Parent (Arg)) then
5384 -- Arg is the Expression of an N_Pragma_Argument_Association
5387 if From_Aspect_Specification (Parent (Parent (Arg))) then
5394 if Nkind (Argx) not in N_Direct_Name
5395 and then (Nkind (Argx) /= N_Attribute_Reference
5396 or else Present (Expressions (Argx))
5397 or else Nkind (Prefix (Argx)) /= N_Identifier)
5398 and then (not Is_Entity_Name (Argx)
5399 or else not Is_Compilation_Unit (Entity (Argx)))
5401 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
5404 -- No further check required if not an entity name
5406 if not Is_Entity_Name (Argx) then
5412 Ent : constant Entity_Id := Entity (Argx);
5413 Scop : constant Entity_Id := Scope (Ent);
5416 -- Case of a pragma applied to a compilation unit: pragma must
5417 -- occur immediately after the program unit in the compilation.
5419 if Is_Compilation_Unit (Ent) then
5421 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
5424 -- Case of pragma placed immediately after spec
5426 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
5429 -- Case of pragma placed immediately after body
5431 elsif Nkind (Decl) = N_Subprogram_Declaration
5432 and then Present (Corresponding_Body (Decl))
5436 (Parent (Unit_Declaration_Node
5437 (Corresponding_Body (Decl))));
5439 -- All other cases are illegal
5446 -- Special restricted placement rule from 10.2.1(11.8/2)
5448 elsif Is_Generic_Formal (Ent)
5449 and then Prag_Id = Pragma_Preelaborable_Initialization
5451 OK := List_Containing (N) =
5452 Generic_Formal_Declarations
5453 (Unit_Declaration_Node (Scop));
5455 -- If this is an aspect applied to a subprogram body, the
5456 -- pragma is inserted in its declarative part.
5458 elsif From_Aspect_Specification (N)
5459 and then Ent = Current_Scope
5461 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
5465 -- If the aspect is a predicate (possibly others ???) and the
5466 -- context is a record type, this is a discriminant expression
5467 -- within a type declaration, that freezes the predicated
5470 elsif From_Aspect_Specification (N)
5471 and then Prag_Id = Pragma_Predicate
5472 and then Ekind (Current_Scope) = E_Record_Type
5473 and then Scop = Scope (Current_Scope)
5477 -- Default case, just check that the pragma occurs in the scope
5478 -- of the entity denoted by the name.
5481 OK := Current_Scope = Scop;
5486 ("pragma% argument must be in same declarative part", Arg);
5490 end Check_Arg_Is_Local_Name;
5492 ---------------------------------
5493 -- Check_Arg_Is_Locking_Policy --
5494 ---------------------------------
5496 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5497 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5500 Check_Arg_Is_Identifier (Argx);
5502 if not Is_Locking_Policy_Name (Chars (Argx)) then
5503 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5505 end Check_Arg_Is_Locking_Policy;
5507 -----------------------------------------------
5508 -- Check_Arg_Is_Partition_Elaboration_Policy --
5509 -----------------------------------------------
5511 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5512 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5515 Check_Arg_Is_Identifier (Argx);
5517 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5519 ("& is not a valid partition elaboration policy name", Argx);
5521 end Check_Arg_Is_Partition_Elaboration_Policy;
5523 -------------------------
5524 -- Check_Arg_Is_One_Of --
5525 -------------------------
5527 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5528 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5531 Check_Arg_Is_Identifier (Argx);
5533 if not Nam_In (Chars (Argx), N1, N2) then
5534 Error_Msg_Name_2 := N1;
5535 Error_Msg_Name_3 := N2;
5536 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5538 end Check_Arg_Is_One_Of;
5540 procedure Check_Arg_Is_One_Of
5542 N1, N2, N3 : Name_Id)
5544 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5547 Check_Arg_Is_Identifier (Argx);
5549 if not Nam_In (Chars (Argx), N1, N2, N3) then
5550 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5552 end Check_Arg_Is_One_Of;
5554 procedure Check_Arg_Is_One_Of
5556 N1, N2, N3, N4 : Name_Id)
5558 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5561 Check_Arg_Is_Identifier (Argx);
5563 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5564 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5566 end Check_Arg_Is_One_Of;
5568 procedure Check_Arg_Is_One_Of
5570 N1, N2, N3, N4, N5 : Name_Id)
5572 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5575 Check_Arg_Is_Identifier (Argx);
5577 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5578 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5580 end Check_Arg_Is_One_Of;
5582 ---------------------------------
5583 -- Check_Arg_Is_Queuing_Policy --
5584 ---------------------------------
5586 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5587 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5590 Check_Arg_Is_Identifier (Argx);
5592 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5593 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5595 end Check_Arg_Is_Queuing_Policy;
5597 ---------------------------------------
5598 -- Check_Arg_Is_OK_Static_Expression --
5599 ---------------------------------------
5601 procedure Check_Arg_Is_OK_Static_Expression
5603 Typ : Entity_Id := Empty)
5606 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5607 end Check_Arg_Is_OK_Static_Expression;
5609 ------------------------------------------
5610 -- Check_Arg_Is_Task_Dispatching_Policy --
5611 ------------------------------------------
5613 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5614 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5617 Check_Arg_Is_Identifier (Argx);
5619 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5621 ("& is not an allowed task dispatching policy name", Argx);
5623 end Check_Arg_Is_Task_Dispatching_Policy;
5625 ---------------------
5626 -- Check_Arg_Order --
5627 ---------------------
5629 procedure Check_Arg_Order (Names : Name_List) is
5632 Highest_So_Far : Natural := 0;
5633 -- Highest index in Names seen do far
5637 for J in 1 .. Arg_Count loop
5638 if Chars (Arg) /= No_Name then
5639 for K in Names'Range loop
5640 if Chars (Arg) = Names (K) then
5641 if K < Highest_So_Far then
5642 Error_Msg_Name_1 := Pname;
5644 ("parameters out of order for pragma%", Arg);
5645 Error_Msg_Name_1 := Names (K);
5646 Error_Msg_Name_2 := Names (Highest_So_Far);
5647 Error_Msg_N ("\% must appear before %", Arg);
5651 Highest_So_Far := K;
5659 end Check_Arg_Order;
5661 --------------------------------
5662 -- Check_At_Least_N_Arguments --
5663 --------------------------------
5665 procedure Check_At_Least_N_Arguments (N : Nat) is
5667 if Arg_Count < N then
5668 Error_Pragma ("too few arguments for pragma%");
5670 end Check_At_Least_N_Arguments;
5672 -------------------------------
5673 -- Check_At_Most_N_Arguments --
5674 -------------------------------
5676 procedure Check_At_Most_N_Arguments (N : Nat) is
5679 if Arg_Count > N then
5681 for J in 1 .. N loop
5683 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5686 end Check_At_Most_N_Arguments;
5688 ---------------------
5689 -- Check_Component --
5690 ---------------------
5692 procedure Check_Component
5695 In_Variant_Part : Boolean := False)
5697 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5698 Sindic : constant Node_Id :=
5699 Subtype_Indication (Component_Definition (Comp));
5700 Typ : constant Entity_Id := Etype (Comp_Id);
5703 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5704 -- object constraint, then the component type shall be an Unchecked_
5707 if Nkind (Sindic) = N_Subtype_Indication
5708 and then Has_Per_Object_Constraint (Comp_Id)
5709 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5712 ("component subtype subject to per-object constraint "
5713 & "must be an Unchecked_Union", Comp);
5715 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5716 -- the body of a generic unit, or within the body of any of its
5717 -- descendant library units, no part of the type of a component
5718 -- declared in a variant_part of the unchecked union type shall be of
5719 -- a formal private type or formal private extension declared within
5720 -- the formal part of the generic unit.
5722 elsif Ada_Version >= Ada_2012
5723 and then In_Generic_Body (UU_Typ)
5724 and then In_Variant_Part
5725 and then Is_Private_Type (Typ)
5726 and then Is_Generic_Type (Typ)
5729 ("component of unchecked union cannot be of generic type", Comp);
5731 elsif Needs_Finalization (Typ) then
5733 ("component of unchecked union cannot be controlled", Comp);
5735 elsif Has_Task (Typ) then
5737 ("component of unchecked union cannot have tasks", Comp);
5739 end Check_Component;
5741 ----------------------------
5742 -- Check_Duplicate_Pragma --
5743 ----------------------------
5745 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5746 Id : Entity_Id := E;
5750 -- Nothing to do if this pragma comes from an aspect specification,
5751 -- since we could not be duplicating a pragma, and we dealt with the
5752 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5754 if From_Aspect_Specification (N) then
5758 -- Otherwise current pragma may duplicate previous pragma or a
5759 -- previously given aspect specification or attribute definition
5760 -- clause for the same pragma.
5762 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5766 -- If the entity is a type, then we have to make sure that the
5767 -- ostensible duplicate is not for a parent type from which this
5771 if Nkind (P) = N_Pragma then
5773 Args : constant List_Id :=
5774 Pragma_Argument_Associations (P);
5777 and then Is_Entity_Name (Expression (First (Args)))
5778 and then Is_Type (Entity (Expression (First (Args))))
5779 and then Entity (Expression (First (Args))) /= E
5785 elsif Nkind (P) = N_Aspect_Specification
5786 and then Is_Type (Entity (P))
5787 and then Entity (P) /= E
5793 -- Here we have a definite duplicate
5795 Error_Msg_Name_1 := Pragma_Name (N);
5796 Error_Msg_Sloc := Sloc (P);
5798 -- For a single protected or a single task object, the error is
5799 -- issued on the original entity.
5801 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5802 Id := Defining_Identifier (Original_Node (Parent (Id)));
5805 if Nkind (P) = N_Aspect_Specification
5806 or else From_Aspect_Specification (P)
5808 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5810 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5815 end Check_Duplicate_Pragma;
5817 ----------------------------------
5818 -- Check_Duplicated_Export_Name --
5819 ----------------------------------
5821 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5822 String_Val : constant String_Id := Strval (Nam);
5825 -- We are only interested in the export case, and in the case of
5826 -- generics, it is the instance, not the template, that is the
5827 -- problem (the template will generate a warning in any case).
5829 if not Inside_A_Generic
5830 and then (Prag_Id = Pragma_Export
5832 Prag_Id = Pragma_Export_Procedure
5834 Prag_Id = Pragma_Export_Valued_Procedure
5836 Prag_Id = Pragma_Export_Function)
5838 for J in Externals.First .. Externals.Last loop
5839 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5840 Error_Msg_Sloc := Sloc (Externals.Table (J));
5841 Error_Msg_N ("external name duplicates name given#", Nam);
5846 Externals.Append (Nam);
5848 end Check_Duplicated_Export_Name;
5850 ----------------------------------------
5851 -- Check_Expr_Is_OK_Static_Expression --
5852 ----------------------------------------
5854 procedure Check_Expr_Is_OK_Static_Expression
5856 Typ : Entity_Id := Empty)
5859 if Present (Typ) then
5860 Analyze_And_Resolve (Expr, Typ);
5862 Analyze_And_Resolve (Expr);
5865 -- An expression cannot be considered static if its resolution failed
5866 -- or if it's erroneous. Stop the analysis of the related pragma.
5868 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5871 elsif Is_OK_Static_Expression (Expr) then
5874 -- An interesting special case, if we have a string literal and we
5875 -- are in Ada 83 mode, then we allow it even though it will not be
5876 -- flagged as static. This allows the use of Ada 95 pragmas like
5877 -- Import in Ada 83 mode. They will of course be flagged with
5878 -- warnings as usual, but will not cause errors.
5880 elsif Ada_Version = Ada_83
5881 and then Nkind (Expr) = N_String_Literal
5885 -- Finally, we have a real error
5888 Error_Msg_Name_1 := Pname;
5889 Flag_Non_Static_Expr
5890 (Fix_Error ("argument for pragma% must be a static expression!"),
5894 end Check_Expr_Is_OK_Static_Expression;
5896 -------------------------
5897 -- Check_First_Subtype --
5898 -------------------------
5900 procedure Check_First_Subtype (Arg : Node_Id) is
5901 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5902 Ent : constant Entity_Id := Entity (Argx);
5905 if Is_First_Subtype (Ent) then
5908 elsif Is_Type (Ent) then
5910 ("pragma% cannot apply to subtype", Argx);
5912 elsif Is_Object (Ent) then
5914 ("pragma% cannot apply to object, requires a type", Argx);
5918 ("pragma% cannot apply to&, requires a type", Argx);
5920 end Check_First_Subtype;
5922 ----------------------
5923 -- Check_Identifier --
5924 ----------------------
5926 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5929 and then Nkind (Arg) = N_Pragma_Argument_Association
5931 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5932 Error_Msg_Name_1 := Pname;
5933 Error_Msg_Name_2 := Id;
5934 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5938 end Check_Identifier;
5940 --------------------------------
5941 -- Check_Identifier_Is_One_Of --
5942 --------------------------------
5944 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5947 and then Nkind (Arg) = N_Pragma_Argument_Association
5949 if Chars (Arg) = No_Name then
5950 Error_Msg_Name_1 := Pname;
5951 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5954 elsif Chars (Arg) /= N1
5955 and then Chars (Arg) /= N2
5957 Error_Msg_Name_1 := Pname;
5958 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5962 end Check_Identifier_Is_One_Of;
5964 ---------------------------
5965 -- Check_In_Main_Program --
5966 ---------------------------
5968 procedure Check_In_Main_Program is
5969 P : constant Node_Id := Parent (N);
5972 -- Must be in subprogram body
5974 if Nkind (P) /= N_Subprogram_Body then
5975 Error_Pragma ("% pragma allowed only in subprogram");
5977 -- Otherwise warn if obviously not main program
5979 elsif Present (Parameter_Specifications (Specification (P)))
5980 or else not Is_Compilation_Unit (Defining_Entity (P))
5982 Error_Msg_Name_1 := Pname;
5984 ("??pragma% is only effective in main program", N);
5986 end Check_In_Main_Program;
5988 ---------------------------------------
5989 -- Check_Interrupt_Or_Attach_Handler --
5990 ---------------------------------------
5992 procedure Check_Interrupt_Or_Attach_Handler is
5993 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5994 Handler_Proc, Proc_Scope : Entity_Id;
5999 if Prag_Id = Pragma_Interrupt_Handler then
6000 Check_Restriction (No_Dynamic_Attachment, N);
6003 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
6004 Proc_Scope := Scope (Handler_Proc);
6006 if Ekind (Proc_Scope) /= E_Protected_Type then
6008 ("argument of pragma% must be protected procedure", Arg1);
6011 -- For pragma case (as opposed to access case), check placement.
6012 -- We don't need to do that for aspects, because we have the
6013 -- check that they aspect applies an appropriate procedure.
6015 if not From_Aspect_Specification (N)
6016 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
6018 Error_Pragma ("pragma% must be in protected definition");
6021 if not Is_Library_Level_Entity (Proc_Scope) then
6023 ("argument for pragma% must be library level entity", Arg1);
6026 -- AI05-0033: A pragma cannot appear within a generic body, because
6027 -- instance can be in a nested scope. The check that protected type
6028 -- is itself a library-level declaration is done elsewhere.
6030 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6031 -- handle code prior to AI-0033. Analysis tools typically are not
6032 -- interested in this pragma in any case, so no need to worry too
6033 -- much about its placement.
6035 if Inside_A_Generic then
6036 if Ekind (Scope (Current_Scope)) = E_Generic_Package
6037 and then In_Package_Body (Scope (Current_Scope))
6038 and then not Relaxed_RM_Semantics
6040 Error_Pragma ("pragma% cannot be used inside a generic");
6043 end Check_Interrupt_Or_Attach_Handler;
6045 ---------------------------------
6046 -- Check_Loop_Pragma_Placement --
6047 ---------------------------------
6049 procedure Check_Loop_Pragma_Placement is
6050 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
6051 -- Verify whether the current pragma is properly grouped with other
6052 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6053 -- related loop where the pragma appears.
6055 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
6056 -- Determine whether an arbitrary statement Stmt denotes pragma
6057 -- Loop_Invariant or Loop_Variant.
6059 procedure Placement_Error (Constr : Node_Id);
6060 pragma No_Return (Placement_Error);
6061 -- Node Constr denotes the last loop restricted construct before we
6062 -- encountered an illegal relation between enclosing constructs. Emit
6063 -- an error depending on what Constr was.
6065 --------------------------------
6066 -- Check_Loop_Pragma_Grouping --
6067 --------------------------------
6069 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
6070 Stop_Search : exception;
6071 -- This exception is used to terminate the recursive descent of
6072 -- routine Check_Grouping.
6074 procedure Check_Grouping (L : List_Id);
6075 -- Find the first group of pragmas in list L and if successful,
6076 -- ensure that the current pragma is part of that group. The
6077 -- routine raises Stop_Search once such a check is performed to
6078 -- halt the recursive descent.
6080 procedure Grouping_Error (Prag : Node_Id);
6081 pragma No_Return (Grouping_Error);
6082 -- Emit an error concerning the current pragma indicating that it
6083 -- should be placed after pragma Prag.
6085 --------------------
6086 -- Check_Grouping --
6087 --------------------
6089 procedure Check_Grouping (L : List_Id) is
6092 Prag : Node_Id := Empty; -- init to avoid warning
6095 -- Inspect the list of declarations or statements looking for
6096 -- the first grouping of pragmas:
6099 -- pragma Loop_Invariant ...;
6100 -- pragma Loop_Variant ...;
6102 -- pragma Loop_Variant ...; -- current pragma
6104 -- If the current pragma is not in the grouping, then it must
6105 -- either appear in a different declarative or statement list
6106 -- or the construct at (1) is separating the pragma from the
6110 while Present (Stmt) loop
6112 -- First pragma of the first topmost grouping has been found
6114 if Is_Loop_Pragma (Stmt) then
6116 -- The group and the current pragma are not in the same
6117 -- declarative or statement list.
6119 if List_Containing (Stmt) /= List_Containing (N) then
6120 Grouping_Error (Stmt);
6122 -- Try to reach the current pragma from the first pragma
6123 -- of the grouping while skipping other members:
6125 -- pragma Loop_Invariant ...; -- first pragma
6126 -- pragma Loop_Variant ...; -- member
6128 -- pragma Loop_Variant ...; -- current pragma
6131 while Present (Stmt) loop
6132 -- The current pragma is either the first pragma
6133 -- of the group or is a member of the group.
6134 -- Stop the search as the placement is legal.
6139 -- Skip group members, but keep track of the
6140 -- last pragma in the group.
6142 elsif Is_Loop_Pragma (Stmt) then
6145 -- Skip declarations and statements generated by
6146 -- the compiler during expansion. Note that some
6147 -- source statements (e.g. pragma Assert) may have
6148 -- been transformed so that they do not appear as
6149 -- coming from source anymore, so we instead look
6150 -- at their Original_Node.
6152 elsif not Comes_From_Source (Original_Node (Stmt))
6156 -- A non-pragma is separating the group from the
6157 -- current pragma, the placement is illegal.
6160 Grouping_Error (Prag);
6166 -- If the traversal did not reach the current pragma,
6167 -- then the list must be malformed.
6169 raise Program_Error;
6172 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6173 -- inside a loop or a block housed inside a loop. Inspect
6174 -- the declarations and statements of the block as they may
6175 -- contain the first grouping. This case follows the one for
6176 -- loop pragmas, as block statements which originate in a
6177 -- loop pragma (and so Is_Loop_Pragma will return True on
6178 -- that block statement) should be treated in the previous
6181 elsif Nkind (Stmt) = N_Block_Statement then
6182 HSS := Handled_Statement_Sequence (Stmt);
6184 Check_Grouping (Declarations (Stmt));
6186 if Present (HSS) then
6187 Check_Grouping (Statements (HSS));
6195 --------------------
6196 -- Grouping_Error --
6197 --------------------
6199 procedure Grouping_Error (Prag : Node_Id) is
6201 Error_Msg_Sloc := Sloc (Prag);
6202 Error_Pragma ("pragma% must appear next to pragma#");
6205 -- Start of processing for Check_Loop_Pragma_Grouping
6208 -- Inspect the statements of the loop or nested blocks housed
6209 -- within to determine whether the current pragma is part of the
6210 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6212 Check_Grouping (Statements (Loop_Stmt));
6215 when Stop_Search => null;
6216 end Check_Loop_Pragma_Grouping;
6218 --------------------
6219 -- Is_Loop_Pragma --
6220 --------------------
6222 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
6224 -- Inspect the original node as Loop_Invariant and Loop_Variant
6225 -- pragmas are rewritten to null when assertions are disabled.
6227 if Nkind (Original_Node (Stmt)) = N_Pragma then
6229 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
6230 Name_Loop_Invariant,
6237 ---------------------
6238 -- Placement_Error --
6239 ---------------------
6241 procedure Placement_Error (Constr : Node_Id) is
6242 LA : constant String := " with Loop_Entry";
6245 if Prag_Id = Pragma_Assert then
6246 Error_Msg_String (1 .. LA'Length) := LA;
6247 Error_Msg_Strlen := LA'Length;
6249 Error_Msg_Strlen := 0;
6252 if Nkind (Constr) = N_Pragma then
6254 ("pragma %~ must appear immediately within the statements "
6258 ("block containing pragma %~ must appear immediately within "
6259 & "the statements of a loop", Constr);
6261 end Placement_Error;
6263 -- Local declarations
6268 -- Start of processing for Check_Loop_Pragma_Placement
6271 -- Check that pragma appears immediately within a loop statement,
6272 -- ignoring intervening block statements.
6276 while Present (Stmt) loop
6278 -- The pragma or previous block must appear immediately within the
6279 -- current block's declarative or statement part.
6281 if Nkind (Stmt) = N_Block_Statement then
6282 if (No (Declarations (Stmt))
6283 or else List_Containing (Prev) /= Declarations (Stmt))
6285 List_Containing (Prev) /=
6286 Statements (Handled_Statement_Sequence (Stmt))
6288 Placement_Error (Prev);
6291 -- Keep inspecting the parents because we are now within a
6292 -- chain of nested blocks.
6296 Stmt := Parent (Stmt);
6299 -- The pragma or previous block must appear immediately within the
6300 -- statements of the loop.
6302 elsif Nkind (Stmt) = N_Loop_Statement then
6303 if List_Containing (Prev) /= Statements (Stmt) then
6304 Placement_Error (Prev);
6307 -- Stop the traversal because we reached the innermost loop
6308 -- regardless of whether we encountered an error or not.
6312 -- Ignore a handled statement sequence. Note that this node may
6313 -- be related to a subprogram body in which case we will emit an
6314 -- error on the next iteration of the search.
6316 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
6317 Stmt := Parent (Stmt);
6319 -- Any other statement breaks the chain from the pragma to the
6323 Placement_Error (Prev);
6328 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6329 -- grouped together with other such pragmas.
6331 if Is_Loop_Pragma (N) then
6333 -- The previous check should have located the related loop
6335 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
6336 Check_Loop_Pragma_Grouping (Stmt);
6338 end Check_Loop_Pragma_Placement;
6340 -------------------------------------------
6341 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6342 -------------------------------------------
6344 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
6353 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
6356 elsif Nkind_In (P, N_Package_Specification,
6361 -- Note: the following tests seem a little peculiar, because
6362 -- they test for bodies, but if we were in the statement part
6363 -- of the body, we would already have hit the handled statement
6364 -- sequence, so the only way we get here is by being in the
6365 -- declarative part of the body.
6367 elsif Nkind_In (P, N_Subprogram_Body,
6378 Error_Pragma ("pragma% is not in declarative part or package spec");
6379 end Check_Is_In_Decl_Part_Or_Package_Spec;
6381 -------------------------
6382 -- Check_No_Identifier --
6383 -------------------------
6385 procedure Check_No_Identifier (Arg : Node_Id) is
6387 if Nkind (Arg) = N_Pragma_Argument_Association
6388 and then Chars (Arg) /= No_Name
6390 Error_Pragma_Arg_Ident
6391 ("pragma% does not permit identifier& here", Arg);
6393 end Check_No_Identifier;
6395 --------------------------
6396 -- Check_No_Identifiers --
6397 --------------------------
6399 procedure Check_No_Identifiers is
6403 for J in 1 .. Arg_Count loop
6404 Check_No_Identifier (Arg_Node);
6407 end Check_No_Identifiers;
6409 ------------------------
6410 -- Check_No_Link_Name --
6411 ------------------------
6413 procedure Check_No_Link_Name is
6415 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
6419 if Present (Arg4) then
6421 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
6423 end Check_No_Link_Name;
6425 -------------------------------
6426 -- Check_Optional_Identifier --
6427 -------------------------------
6429 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
6432 and then Nkind (Arg) = N_Pragma_Argument_Association
6433 and then Chars (Arg) /= No_Name
6435 if Chars (Arg) /= Id then
6436 Error_Msg_Name_1 := Pname;
6437 Error_Msg_Name_2 := Id;
6438 Error_Msg_N ("pragma% argument expects identifier%", Arg);
6442 end Check_Optional_Identifier;
6444 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
6446 Check_Optional_Identifier (Arg, Name_Find (Id));
6447 end Check_Optional_Identifier;
6449 -------------------------------------
6450 -- Check_Static_Boolean_Expression --
6451 -------------------------------------
6453 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
6455 if Present (Expr) then
6456 Analyze_And_Resolve (Expr, Standard_Boolean);
6458 if not Is_OK_Static_Expression (Expr) then
6460 ("expression of pragma % must be static", Expr);
6463 end Check_Static_Boolean_Expression;
6465 -----------------------------
6466 -- Check_Static_Constraint --
6467 -----------------------------
6469 -- Note: for convenience in writing this procedure, in addition to
6470 -- the officially (i.e. by spec) allowed argument which is always a
6471 -- constraint, it also allows ranges and discriminant associations.
6472 -- Above is not clear ???
6474 procedure Check_Static_Constraint (Constr : Node_Id) is
6476 procedure Require_Static (E : Node_Id);
6477 -- Require given expression to be static expression
6479 --------------------
6480 -- Require_Static --
6481 --------------------
6483 procedure Require_Static (E : Node_Id) is
6485 if not Is_OK_Static_Expression (E) then
6486 Flag_Non_Static_Expr
6487 ("non-static constraint not allowed in Unchecked_Union!", E);
6492 -- Start of processing for Check_Static_Constraint
6495 case Nkind (Constr) is
6496 when N_Discriminant_Association =>
6497 Require_Static (Expression (Constr));
6500 Require_Static (Low_Bound (Constr));
6501 Require_Static (High_Bound (Constr));
6503 when N_Attribute_Reference =>
6504 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6505 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6507 when N_Range_Constraint =>
6508 Check_Static_Constraint (Range_Expression (Constr));
6510 when N_Index_Or_Discriminant_Constraint =>
6514 IDC := First (Constraints (Constr));
6515 while Present (IDC) loop
6516 Check_Static_Constraint (IDC);
6524 end Check_Static_Constraint;
6526 --------------------------------------
6527 -- Check_Valid_Configuration_Pragma --
6528 --------------------------------------
6530 -- A configuration pragma must appear in the context clause of a
6531 -- compilation unit, and only other pragmas may precede it. Note that
6532 -- the test also allows use in a configuration pragma file.
6534 procedure Check_Valid_Configuration_Pragma is
6536 if not Is_Configuration_Pragma then
6537 Error_Pragma ("incorrect placement for configuration pragma%");
6539 end Check_Valid_Configuration_Pragma;
6541 -------------------------------------
6542 -- Check_Valid_Library_Unit_Pragma --
6543 -------------------------------------
6545 procedure Check_Valid_Library_Unit_Pragma is
6547 Parent_Node : Node_Id;
6548 Unit_Name : Entity_Id;
6549 Unit_Kind : Node_Kind;
6550 Unit_Node : Node_Id;
6551 Sindex : Source_File_Index;
6554 if not Is_List_Member (N) then
6558 Plist := List_Containing (N);
6559 Parent_Node := Parent (Plist);
6561 if Parent_Node = Empty then
6564 -- Case of pragma appearing after a compilation unit. In this case
6565 -- it must have an argument with the corresponding name and must
6566 -- be part of the following pragmas of its parent.
6568 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6569 if Plist /= Pragmas_After (Parent_Node) then
6572 elsif Arg_Count = 0 then
6574 ("argument required if outside compilation unit");
6577 Check_No_Identifiers;
6578 Check_Arg_Count (1);
6579 Unit_Node := Unit (Parent (Parent_Node));
6580 Unit_Kind := Nkind (Unit_Node);
6582 Analyze (Get_Pragma_Arg (Arg1));
6584 if Unit_Kind = N_Generic_Subprogram_Declaration
6585 or else Unit_Kind = N_Subprogram_Declaration
6587 Unit_Name := Defining_Entity (Unit_Node);
6589 elsif Unit_Kind in N_Generic_Instantiation then
6590 Unit_Name := Defining_Entity (Unit_Node);
6593 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6596 if Chars (Unit_Name) /=
6597 Chars (Entity (Get_Pragma_Arg (Arg1)))
6600 ("pragma% argument is not current unit name", Arg1);
6603 if Ekind (Unit_Name) = E_Package
6604 and then Present (Renamed_Entity (Unit_Name))
6606 Error_Pragma ("pragma% not allowed for renamed package");
6610 -- Pragma appears other than after a compilation unit
6613 -- Here we check for the generic instantiation case and also
6614 -- for the case of processing a generic formal package. We
6615 -- detect these cases by noting that the Sloc on the node
6616 -- does not belong to the current compilation unit.
6618 Sindex := Source_Index (Current_Sem_Unit);
6620 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6621 Rewrite (N, Make_Null_Statement (Loc));
6624 -- If before first declaration, the pragma applies to the
6625 -- enclosing unit, and the name if present must be this name.
6627 elsif Is_Before_First_Decl (N, Plist) then
6628 Unit_Node := Unit_Declaration_Node (Current_Scope);
6629 Unit_Kind := Nkind (Unit_Node);
6631 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6634 elsif Unit_Kind = N_Subprogram_Body
6635 and then not Acts_As_Spec (Unit_Node)
6639 elsif Nkind (Parent_Node) = N_Package_Body then
6642 elsif Nkind (Parent_Node) = N_Package_Specification
6643 and then Plist = Private_Declarations (Parent_Node)
6647 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6648 or else Nkind (Parent_Node) =
6649 N_Generic_Subprogram_Declaration)
6650 and then Plist = Generic_Formal_Declarations (Parent_Node)
6654 elsif Arg_Count > 0 then
6655 Analyze (Get_Pragma_Arg (Arg1));
6657 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6659 ("name in pragma% must be enclosing unit", Arg1);
6662 -- It is legal to have no argument in this context
6668 -- Error if not before first declaration. This is because a
6669 -- library unit pragma argument must be the name of a library
6670 -- unit (RM 10.1.5(7)), but the only names permitted in this
6671 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6672 -- generic subprogram declarations or generic instantiations.
6676 ("pragma% misplaced, must be before first declaration");
6680 end Check_Valid_Library_Unit_Pragma;
6686 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6687 Clist : constant Node_Id := Component_List (Variant);
6691 Comp := First_Non_Pragma (Component_Items (Clist));
6692 while Present (Comp) loop
6693 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6694 Next_Non_Pragma (Comp);
6698 ---------------------------
6699 -- Ensure_Aggregate_Form --
6700 ---------------------------
6702 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6703 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6704 Expr : constant Node_Id := Expression (Arg);
6705 Loc : constant Source_Ptr := Sloc (Expr);
6706 Comps : List_Id := No_List;
6707 Exprs : List_Id := No_List;
6708 Nam : Name_Id := No_Name;
6709 Nam_Loc : Source_Ptr;
6712 -- The pragma argument is in positional form:
6714 -- pragma Depends (Nam => ...)
6718 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6719 -- argument association.
6721 if Nkind (Arg) = N_Pragma_Argument_Association then
6723 Nam_Loc := Sloc (Arg);
6725 -- Remove the pragma argument name as this will be captured in the
6728 Set_Chars (Arg, No_Name);
6731 -- The argument is already in aggregate form, but the presence of a
6732 -- name causes this to be interpreted as named association which in
6733 -- turn must be converted into an aggregate.
6735 -- pragma Global (In_Out => (A, B, C))
6739 -- pragma Global ((In_Out => (A, B, C)))
6741 -- aggregate aggregate
6743 if Nkind (Expr) = N_Aggregate then
6744 if Nam = No_Name then
6748 -- Do not transform a null argument into an aggregate as N_Null has
6749 -- special meaning in formal verification pragmas.
6751 elsif Nkind (Expr) = N_Null then
6755 -- Everything comes from source if the original comes from source
6757 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6759 -- Positional argument is transformed into an aggregate with an
6760 -- Expressions list.
6762 if Nam = No_Name then
6763 Exprs := New_List (Relocate_Node (Expr));
6765 -- An associative argument is transformed into an aggregate with
6766 -- Component_Associations.
6770 Make_Component_Association (Loc,
6771 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6772 Expression => Relocate_Node (Expr)));
6775 Set_Expression (Arg,
6776 Make_Aggregate (Loc,
6777 Component_Associations => Comps,
6778 Expressions => Exprs));
6780 -- Restore Comes_From_Source default
6782 Set_Comes_From_Source_Default (CFSD);
6783 end Ensure_Aggregate_Form;
6789 procedure Error_Pragma (Msg : String) is
6791 Error_Msg_Name_1 := Pname;
6792 Error_Msg_N (Fix_Error (Msg), N);
6796 ----------------------
6797 -- Error_Pragma_Arg --
6798 ----------------------
6800 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6802 Error_Msg_Name_1 := Pname;
6803 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6805 end Error_Pragma_Arg;
6807 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6809 Error_Msg_Name_1 := Pname;
6810 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6811 Error_Pragma_Arg (Msg2, Arg);
6812 end Error_Pragma_Arg;
6814 ----------------------------
6815 -- Error_Pragma_Arg_Ident --
6816 ----------------------------
6818 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6820 Error_Msg_Name_1 := Pname;
6821 Error_Msg_N (Fix_Error (Msg), Arg);
6823 end Error_Pragma_Arg_Ident;
6825 ----------------------
6826 -- Error_Pragma_Ref --
6827 ----------------------
6829 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6831 Error_Msg_Name_1 := Pname;
6832 Error_Msg_Sloc := Sloc (Ref);
6833 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6835 end Error_Pragma_Ref;
6837 ------------------------
6838 -- Find_Lib_Unit_Name --
6839 ------------------------
6841 function Find_Lib_Unit_Name return Entity_Id is
6843 -- Return inner compilation unit entity, for case of nested
6844 -- categorization pragmas. This happens in generic unit.
6846 if Nkind (Parent (N)) = N_Package_Specification
6847 and then Defining_Entity (Parent (N)) /= Current_Scope
6849 return Defining_Entity (Parent (N));
6851 return Current_Scope;
6853 end Find_Lib_Unit_Name;
6855 ----------------------------
6856 -- Find_Program_Unit_Name --
6857 ----------------------------
6859 procedure Find_Program_Unit_Name (Id : Node_Id) is
6860 Unit_Name : Entity_Id;
6861 Unit_Kind : Node_Kind;
6862 P : constant Node_Id := Parent (N);
6865 if Nkind (P) = N_Compilation_Unit then
6866 Unit_Kind := Nkind (Unit (P));
6868 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6869 N_Package_Declaration)
6870 or else Unit_Kind in N_Generic_Declaration
6872 Unit_Name := Defining_Entity (Unit (P));
6874 if Chars (Id) = Chars (Unit_Name) then
6875 Set_Entity (Id, Unit_Name);
6876 Set_Etype (Id, Etype (Unit_Name));
6878 Set_Etype (Id, Any_Type);
6880 ("cannot find program unit referenced by pragma%");
6884 Set_Etype (Id, Any_Type);
6885 Error_Pragma ("pragma% inapplicable to this unit");
6891 end Find_Program_Unit_Name;
6893 -----------------------------------------
6894 -- Find_Unique_Parameterless_Procedure --
6895 -----------------------------------------
6897 function Find_Unique_Parameterless_Procedure
6899 Arg : Node_Id) return Entity_Id
6901 Proc : Entity_Id := Empty;
6904 -- The body of this procedure needs some comments ???
6906 if not Is_Entity_Name (Name) then
6908 ("argument of pragma% must be entity name", Arg);
6910 elsif not Is_Overloaded (Name) then
6911 Proc := Entity (Name);
6913 if Ekind (Proc) /= E_Procedure
6914 or else Present (First_Formal (Proc))
6917 ("argument of pragma% must be parameterless procedure", Arg);
6922 Found : Boolean := False;
6924 Index : Interp_Index;
6927 Get_First_Interp (Name, Index, It);
6928 while Present (It.Nam) loop
6931 if Ekind (Proc) = E_Procedure
6932 and then No (First_Formal (Proc))
6936 Set_Entity (Name, Proc);
6937 Set_Is_Overloaded (Name, False);
6940 ("ambiguous handler name for pragma% ", Arg);
6944 Get_Next_Interp (Index, It);
6949 ("argument of pragma% must be parameterless procedure",
6952 Proc := Entity (Name);
6958 end Find_Unique_Parameterless_Procedure;
6964 function Fix_Error (Msg : String) return String is
6965 Res : String (Msg'Range) := Msg;
6966 Res_Last : Natural := Msg'Last;
6970 -- If we have a rewriting of another pragma, go to that pragma
6972 if Is_Rewrite_Substitution (N)
6973 and then Nkind (Original_Node (N)) = N_Pragma
6975 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6978 -- Case where pragma comes from an aspect specification
6980 if From_Aspect_Specification (N) then
6982 -- Change appearence of "pragma" in message to "aspect"
6985 while J <= Res_Last - 5 loop
6986 if Res (J .. J + 5) = "pragma" then
6987 Res (J .. J + 5) := "aspect";
6995 -- Change "argument of" at start of message to "entity for"
6998 and then Res (Res'First .. Res'First + 10) = "argument of"
7000 Res (Res'First .. Res'First + 9) := "entity for";
7001 Res (Res'First + 10 .. Res_Last - 1) :=
7002 Res (Res'First + 11 .. Res_Last);
7003 Res_Last := Res_Last - 1;
7006 -- Change "argument" at start of message to "entity"
7009 and then Res (Res'First .. Res'First + 7) = "argument"
7011 Res (Res'First .. Res'First + 5) := "entity";
7012 Res (Res'First + 6 .. Res_Last - 2) :=
7013 Res (Res'First + 8 .. Res_Last);
7014 Res_Last := Res_Last - 2;
7017 -- Get name from corresponding aspect
7019 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
7022 -- Return possibly modified message
7024 return Res (Res'First .. Res_Last);
7027 -------------------------
7028 -- Gather_Associations --
7029 -------------------------
7031 procedure Gather_Associations
7033 Args : out Args_List)
7038 -- Initialize all parameters to Empty
7040 for J in Args'Range loop
7044 -- That's all we have to do if there are no argument associations
7046 if No (Pragma_Argument_Associations (N)) then
7050 -- Otherwise first deal with any positional parameters present
7052 Arg := First (Pragma_Argument_Associations (N));
7053 for Index in Args'Range loop
7054 exit when No (Arg) or else Chars (Arg) /= No_Name;
7055 Args (Index) := Get_Pragma_Arg (Arg);
7059 -- Positional parameters all processed, if any left, then we
7060 -- have too many positional parameters.
7062 if Present (Arg) and then Chars (Arg) = No_Name then
7064 ("too many positional associations for pragma%", Arg);
7067 -- Process named parameters if any are present
7069 while Present (Arg) loop
7070 if Chars (Arg) = No_Name then
7072 ("positional association cannot follow named association",
7076 for Index in Names'Range loop
7077 if Names (Index) = Chars (Arg) then
7078 if Present (Args (Index)) then
7080 ("duplicate argument association for pragma%", Arg);
7082 Args (Index) := Get_Pragma_Arg (Arg);
7087 if Index = Names'Last then
7088 Error_Msg_Name_1 := Pname;
7089 Error_Msg_N ("pragma% does not allow & argument", Arg);
7091 -- Check for possible misspelling
7093 for Index1 in Names'Range loop
7094 if Is_Bad_Spelling_Of
7095 (Chars (Arg), Names (Index1))
7097 Error_Msg_Name_1 := Names (Index1);
7098 Error_Msg_N -- CODEFIX
7099 ("\possible misspelling of%", Arg);
7111 end Gather_Associations;
7117 procedure GNAT_Pragma is
7119 -- We need to check the No_Implementation_Pragmas restriction for
7120 -- the case of a pragma from source. Note that the case of aspects
7121 -- generating corresponding pragmas marks these pragmas as not being
7122 -- from source, so this test also catches that case.
7124 if Comes_From_Source (N) then
7125 Check_Restriction (No_Implementation_Pragmas, N);
7129 --------------------------
7130 -- Is_Before_First_Decl --
7131 --------------------------
7133 function Is_Before_First_Decl
7134 (Pragma_Node : Node_Id;
7135 Decls : List_Id) return Boolean
7137 Item : Node_Id := First (Decls);
7140 -- Only other pragmas can come before this pragma
7143 if No (Item) or else Nkind (Item) /= N_Pragma then
7146 elsif Item = Pragma_Node then
7152 end Is_Before_First_Decl;
7154 -----------------------------
7155 -- Is_Configuration_Pragma --
7156 -----------------------------
7158 -- A configuration pragma must appear in the context clause of a
7159 -- compilation unit, and only other pragmas may precede it. Note that
7160 -- the test below also permits use in a configuration pragma file.
7162 function Is_Configuration_Pragma return Boolean is
7163 Lis : constant List_Id := List_Containing (N);
7164 Par : constant Node_Id := Parent (N);
7168 -- If no parent, then we are in the configuration pragma file,
7169 -- so the placement is definitely appropriate.
7174 -- Otherwise we must be in the context clause of a compilation unit
7175 -- and the only thing allowed before us in the context list is more
7176 -- configuration pragmas.
7178 elsif Nkind (Par) = N_Compilation_Unit
7179 and then Context_Items (Par) = Lis
7186 elsif Nkind (Prg) /= N_Pragma then
7196 end Is_Configuration_Pragma;
7198 --------------------------
7199 -- Is_In_Context_Clause --
7200 --------------------------
7202 function Is_In_Context_Clause return Boolean is
7204 Parent_Node : Node_Id;
7207 if not Is_List_Member (N) then
7211 Plist := List_Containing (N);
7212 Parent_Node := Parent (Plist);
7214 if Parent_Node = Empty
7215 or else Nkind (Parent_Node) /= N_Compilation_Unit
7216 or else Context_Items (Parent_Node) /= Plist
7223 end Is_In_Context_Clause;
7225 ---------------------------------
7226 -- Is_Static_String_Expression --
7227 ---------------------------------
7229 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
7230 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
7231 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
7234 Analyze_And_Resolve (Argx);
7236 -- Special case Ada 83, where the expression will never be static,
7237 -- but we will return true if we had a string literal to start with.
7239 if Ada_Version = Ada_83 then
7242 -- Normal case, true only if we end up with a string literal that
7243 -- is marked as being the result of evaluating a static expression.
7246 return Is_OK_Static_Expression (Argx)
7247 and then Nkind (Argx) = N_String_Literal;
7250 end Is_Static_String_Expression;
7252 ----------------------
7253 -- Pragma_Misplaced --
7254 ----------------------
7256 procedure Pragma_Misplaced is
7258 Error_Pragma ("incorrect placement of pragma%");
7259 end Pragma_Misplaced;
7261 ------------------------------------------------
7262 -- Process_Atomic_Independent_Shared_Volatile --
7263 ------------------------------------------------
7265 procedure Process_Atomic_Independent_Shared_Volatile is
7266 procedure Check_VFA_Conflicts (Ent : Entity_Id);
7267 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7269 procedure Mark_Component_Or_Object (Ent : Entity_Id);
7270 -- Appropriately set flags on the given entity (either an array or
7271 -- record component, or an object declaration) according to the
7274 procedure Set_Atomic_VFA (Ent : Entity_Id);
7275 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7276 -- no explicit alignment was given, set alignment to unknown, since
7277 -- back end knows what the alignment requirements are for atomic and
7278 -- full access arrays. Note: this is necessary for derived types.
7280 -------------------------
7281 -- Check_VFA_Conflicts --
7282 -------------------------
7284 procedure Check_VFA_Conflicts (Ent : Entity_Id) is
7288 VFA_And_Atomic : Boolean := False;
7289 -- Set True if atomic component present
7291 VFA_And_Aliased : Boolean := False;
7292 -- Set True if aliased component present
7295 -- Fetch the type in case we are dealing with an object or
7298 if Is_Type (Ent) then
7301 pragma Assert (Is_Object (Ent)
7303 Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
7308 -- Check Atomic and VFA used together
7310 if Prag_Id = Pragma_Volatile_Full_Access
7311 or else Is_Volatile_Full_Access (Ent)
7313 if Prag_Id = Pragma_Atomic
7314 or else Prag_Id = Pragma_Shared
7315 or else Is_Atomic (Ent)
7317 VFA_And_Atomic := True;
7319 elsif Is_Array_Type (Typ) then
7320 VFA_And_Atomic := Has_Atomic_Components (Typ);
7322 -- Note: Has_Atomic_Components is not used below, as this flag
7323 -- represents the pragma of the same name, Atomic_Components,
7324 -- which only applies to arrays.
7326 elsif Is_Record_Type (Typ) then
7327 -- Attributes cannot be applied to discriminants, only
7328 -- regular record components.
7330 Comp := First_Component (Typ);
7331 while Present (Comp) loop
7333 or else Is_Atomic (Typ)
7335 VFA_And_Atomic := True;
7340 Next_Component (Comp);
7344 if VFA_And_Atomic then
7346 ("cannot have Volatile_Full_Access and Atomic for same "
7351 -- Check for the application of VFA to an entity that has aliased
7354 if Prag_Id = Pragma_Volatile_Full_Access then
7355 if Is_Array_Type (Typ)
7356 and then Has_Aliased_Components (Typ)
7358 VFA_And_Aliased := True;
7360 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7361 -- and Has_Independent_Components, applies only to arrays.
7362 -- However, this flag does not have a corresponding pragma, so
7363 -- perhaps it should be possible to apply it to record types as
7364 -- well. Should this be done ???
7366 elsif Is_Record_Type (Typ) then
7367 -- It is possible to have an aliased discriminant, so they
7368 -- must be checked along with normal components.
7370 Comp := First_Component_Or_Discriminant (Typ);
7371 while Present (Comp) loop
7372 if Is_Aliased (Comp)
7373 or else Is_Aliased (Etype (Comp))
7375 VFA_And_Aliased := True;
7376 Check_SPARK_05_Restriction
7377 ("aliased is not allowed", Comp);
7382 Next_Component_Or_Discriminant (Comp);
7386 if VFA_And_Aliased then
7388 ("cannot apply Volatile_Full_Access (aliased component "
7392 end Check_VFA_Conflicts;
7394 ------------------------------
7395 -- Mark_Component_Or_Object --
7396 ------------------------------
7398 procedure Mark_Component_Or_Object (Ent : Entity_Id) is
7400 if Prag_Id = Pragma_Atomic
7401 or else Prag_Id = Pragma_Shared
7402 or else Prag_Id = Pragma_Volatile_Full_Access
7404 if Prag_Id = Pragma_Volatile_Full_Access then
7405 Set_Is_Volatile_Full_Access (Ent);
7407 Set_Is_Atomic (Ent);
7410 -- If the object declaration has an explicit initialization, a
7411 -- temporary may have to be created to hold the expression, to
7412 -- ensure that access to the object remains atomic.
7414 if Nkind (Parent (Ent)) = N_Object_Declaration
7415 and then Present (Expression (Parent (Ent)))
7417 Set_Has_Delayed_Freeze (Ent);
7421 -- Atomic/Shared/Volatile_Full_Access imply Independent
7423 if Prag_Id /= Pragma_Volatile then
7424 Set_Is_Independent (Ent);
7426 if Prag_Id = Pragma_Independent then
7427 Record_Independence_Check (N, Ent);
7431 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7433 if Prag_Id /= Pragma_Independent then
7434 Set_Is_Volatile (Ent);
7435 Set_Treat_As_Volatile (Ent);
7437 end Mark_Component_Or_Object;
7439 --------------------
7440 -- Set_Atomic_VFA --
7441 --------------------
7443 procedure Set_Atomic_VFA (Ent : Entity_Id) is
7445 if Prag_Id = Pragma_Volatile_Full_Access then
7446 Set_Is_Volatile_Full_Access (Ent);
7448 Set_Is_Atomic (Ent);
7451 if not Has_Alignment_Clause (Ent) then
7452 Set_Alignment (Ent, Uint_0);
7462 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7465 Check_Ada_83_Warning;
7466 Check_No_Identifiers;
7467 Check_Arg_Count (1);
7468 Check_Arg_Is_Local_Name (Arg1);
7469 E_Arg := Get_Pragma_Arg (Arg1);
7471 if Etype (E_Arg) = Any_Type then
7475 E := Entity (E_Arg);
7477 -- A pragma that applies to a Ghost entity becomes Ghost for the
7478 -- purposes of legality checks and removal of ignored Ghost code.
7480 Mark_Ghost_Pragma (N, E);
7482 -- Check duplicate before we chain ourselves
7484 Check_Duplicate_Pragma (E);
7486 -- Check appropriateness of the entity
7488 Decl := Declaration_Node (E);
7490 -- Deal with the case where the pragma/attribute is applied to a type
7493 if Rep_Item_Too_Early (E, N)
7494 or else Rep_Item_Too_Late (E, N)
7498 Check_First_Subtype (Arg1);
7501 -- Attribute belongs on the base type. If the view of the type is
7502 -- currently private, it also belongs on the underlying type.
7504 if Prag_Id = Pragma_Atomic
7505 or else Prag_Id = Pragma_Shared
7506 or else Prag_Id = Pragma_Volatile_Full_Access
7509 Set_Atomic_VFA (Base_Type (E));
7510 Set_Atomic_VFA (Underlying_Type (E));
7513 -- Atomic/Shared/Volatile_Full_Access imply Independent
7515 if Prag_Id /= Pragma_Volatile then
7516 Set_Is_Independent (E);
7517 Set_Is_Independent (Base_Type (E));
7518 Set_Is_Independent (Underlying_Type (E));
7520 if Prag_Id = Pragma_Independent then
7521 Record_Independence_Check (N, Base_Type (E));
7525 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7527 if Prag_Id /= Pragma_Independent then
7528 Set_Is_Volatile (E);
7529 Set_Is_Volatile (Base_Type (E));
7530 Set_Is_Volatile (Underlying_Type (E));
7532 Set_Treat_As_Volatile (E);
7533 Set_Treat_As_Volatile (Underlying_Type (E));
7536 -- Apply Volatile to the composite type's individual components,
7539 if Prag_Id = Pragma_Volatile
7540 and then Is_Record_Type (Etype (E))
7545 Comp := First_Component (E);
7546 while Present (Comp) loop
7547 Mark_Component_Or_Object (Comp);
7549 Next_Component (Comp);
7554 -- Deal with the case where the pragma/attribute applies to a
7555 -- component or object declaration.
7557 elsif Nkind (Decl) = N_Object_Declaration
7558 or else (Nkind (Decl) = N_Component_Declaration
7559 and then Original_Record_Component (E) = E)
7561 if Rep_Item_Too_Late (E, N) then
7565 Mark_Component_Or_Object (E);
7567 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
7570 -- Perform the checks needed to assure the proper use of the GNAT
7571 -- pragma Volatile_Full_Access.
7573 Check_VFA_Conflicts (E);
7575 -- The following check is only relevant when SPARK_Mode is on as
7576 -- this is not a standard Ada legality rule. Pragma Volatile can
7577 -- only apply to a full type declaration or an object declaration
7578 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7579 -- untagged derived types that are rewritten as subtypes of their
7580 -- respective root types.
7583 and then Prag_Id = Pragma_Volatile
7584 and then not Nkind_In (Original_Node (Decl),
7585 N_Full_Type_Declaration,
7586 N_Object_Declaration,
7587 N_Single_Protected_Declaration,
7588 N_Single_Task_Declaration)
7591 ("argument of pragma % must denote a full type or object "
7592 & "declaration", Arg1);
7594 end Process_Atomic_Independent_Shared_Volatile;
7596 -------------------------------------------
7597 -- Process_Compile_Time_Warning_Or_Error --
7598 -------------------------------------------
7600 procedure Process_Compile_Time_Warning_Or_Error is
7601 Validation_Needed : Boolean := False;
7603 function Check_Node (N : Node_Id) return Traverse_Result;
7604 -- Tree visitor that checks if N is an attribute reference that can
7605 -- be statically computed by the back end. Validation_Needed is set
7606 -- to True if found.
7612 function Check_Node (N : Node_Id) return Traverse_Result is
7614 if Nkind (N) = N_Attribute_Reference
7615 and then Is_Entity_Name (Prefix (N))
7616 and then not Is_Generic_Unit (Scope (Entity (Prefix (N))))
7619 Attr_Id : constant Attribute_Id :=
7620 Get_Attribute_Id (Attribute_Name (N));
7622 if Attr_Id = Attribute_Alignment
7623 or else Attr_Id = Attribute_Size
7625 Validation_Needed := True;
7633 procedure Check_Expression is new Traverse_Proc (Check_Node);
7637 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7639 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7642 -- In GNATprove mode, pragmas Compile_Time_Error and
7643 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7644 -- same information as the compiler (in particular regarding size of
7645 -- objects decided in gigi) so it makes no sense to issue an error or
7646 -- warning in GNATprove.
7648 if GNATprove_Mode then
7649 Rewrite (N, Make_Null_Statement (Loc));
7653 Check_Arg_Count (2);
7654 Check_No_Identifiers;
7655 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7656 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7658 if Compile_Time_Known_Value (Arg1x) then
7659 Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
7661 -- Register the expression for its validation after the back end has
7662 -- been called if it has occurrences of attributes Size or Alignment
7663 -- (because they may be statically computed by the back end and hence
7664 -- the whole expression needs to be reevaluated).
7667 Check_Expression (Arg1x);
7669 if Validation_Needed then
7670 Validate_Compile_Time_Warning_Error (N);
7673 end Process_Compile_Time_Warning_Or_Error;
7675 ------------------------
7676 -- Process_Convention --
7677 ------------------------
7679 procedure Process_Convention
7680 (C : out Convention_Id;
7681 Ent : out Entity_Id)
7685 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7686 -- Called if we have more than one Export/Import/Convention pragma.
7687 -- This is generally illegal, but we have a special case of allowing
7688 -- Import and Interface to coexist if they specify the convention in
7689 -- a consistent manner. We are allowed to do this, since Interface is
7690 -- an implementation defined pragma, and we choose to do it since we
7691 -- know Rational allows this combination. S is the entity id of the
7692 -- subprogram in question. This procedure also sets the special flag
7693 -- Import_Interface_Present in both pragmas in the case where we do
7694 -- have matching Import and Interface pragmas.
7696 procedure Set_Convention_From_Pragma (E : Entity_Id);
7697 -- Set convention in entity E, and also flag that the entity has a
7698 -- convention pragma. If entity is for a private or incomplete type,
7699 -- also set convention and flag on underlying type. This procedure
7700 -- also deals with the special case of C_Pass_By_Copy convention,
7701 -- and error checks for inappropriate convention specification.
7703 -------------------------------
7704 -- Diagnose_Multiple_Pragmas --
7705 -------------------------------
7707 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7708 Pdec : constant Node_Id := Declaration_Node (S);
7712 function Same_Convention (Decl : Node_Id) return Boolean;
7713 -- Decl is a pragma node. This function returns True if this
7714 -- pragma has a first argument that is an identifier with a
7715 -- Chars field corresponding to the Convention_Id C.
7717 function Same_Name (Decl : Node_Id) return Boolean;
7718 -- Decl is a pragma node. This function returns True if this
7719 -- pragma has a second argument that is an identifier with a
7720 -- Chars field that matches the Chars of the current subprogram.
7722 ---------------------
7723 -- Same_Convention --
7724 ---------------------
7726 function Same_Convention (Decl : Node_Id) return Boolean is
7727 Arg1 : constant Node_Id :=
7728 First (Pragma_Argument_Associations (Decl));
7731 if Present (Arg1) then
7733 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7735 if Nkind (Arg) = N_Identifier
7736 and then Is_Convention_Name (Chars (Arg))
7737 and then Get_Convention_Id (Chars (Arg)) = C
7745 end Same_Convention;
7751 function Same_Name (Decl : Node_Id) return Boolean is
7752 Arg1 : constant Node_Id :=
7753 First (Pragma_Argument_Associations (Decl));
7761 Arg2 := Next (Arg1);
7768 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7770 if Nkind (Arg) = N_Identifier
7771 and then Chars (Arg) = Chars (S)
7780 -- Start of processing for Diagnose_Multiple_Pragmas
7785 -- Definitely give message if we have Convention/Export here
7787 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7790 -- If we have an Import or Export, scan back from pragma to
7791 -- find any previous pragma applying to the same procedure.
7792 -- The scan will be terminated by the start of the list, or
7793 -- hitting the subprogram declaration. This won't allow one
7794 -- pragma to appear in the public part and one in the private
7795 -- part, but that seems very unlikely in practice.
7799 while Present (Decl) and then Decl /= Pdec loop
7801 -- Look for pragma with same name as us
7803 if Nkind (Decl) = N_Pragma
7804 and then Same_Name (Decl)
7806 -- Give error if same as our pragma or Export/Convention
7808 if Nam_In (Pragma_Name_Unmapped (Decl),
7811 Pragma_Name_Unmapped (N))
7815 -- Case of Import/Interface or the other way round
7817 elsif Nam_In (Pragma_Name_Unmapped (Decl),
7818 Name_Interface, Name_Import)
7820 -- Here we know that we have Import and Interface. It
7821 -- doesn't matter which way round they are. See if
7822 -- they specify the same convention. If so, all OK,
7823 -- and set special flags to stop other messages
7825 if Same_Convention (Decl) then
7826 Set_Import_Interface_Present (N);
7827 Set_Import_Interface_Present (Decl);
7830 -- If different conventions, special message
7833 Error_Msg_Sloc := Sloc (Decl);
7835 ("convention differs from that given#", Arg1);
7845 -- Give message if needed if we fall through those tests
7846 -- except on Relaxed_RM_Semantics where we let go: either this
7847 -- is a case accepted/ignored by other Ada compilers (e.g.
7848 -- a mix of Convention and Import), or another error will be
7849 -- generated later (e.g. using both Import and Export).
7851 if Err and not Relaxed_RM_Semantics then
7853 ("at most one Convention/Export/Import pragma is allowed",
7856 end Diagnose_Multiple_Pragmas;
7858 --------------------------------
7859 -- Set_Convention_From_Pragma --
7860 --------------------------------
7862 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7864 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7865 -- for an overridden dispatching operation. Technically this is
7866 -- an amendment and should only be done in Ada 2005 mode. However,
7867 -- this is clearly a mistake, since the problem that is addressed
7868 -- by this AI is that there is a clear gap in the RM.
7870 if Is_Dispatching_Operation (E)
7871 and then Present (Overridden_Operation (E))
7872 and then C /= Convention (Overridden_Operation (E))
7875 ("cannot change convention for overridden dispatching "
7876 & "operation", Arg1);
7879 -- Special checks for Convention_Stdcall
7881 if C = Convention_Stdcall then
7883 -- A dispatching call is not allowed. A dispatching subprogram
7884 -- cannot be used to interface to the Win32 API, so in fact
7885 -- this check does not impose any effective restriction.
7887 if Is_Dispatching_Operation (E) then
7888 Error_Msg_Sloc := Sloc (E);
7890 -- Note: make this unconditional so that if there is more
7891 -- than one call to which the pragma applies, we get a
7892 -- message for each call. Also don't use Error_Pragma,
7893 -- so that we get multiple messages.
7896 ("dispatching subprogram# cannot use Stdcall convention!",
7899 -- Several allowed cases
7901 elsif Is_Subprogram_Or_Generic_Subprogram (E)
7905 or else Ekind (E) = E_Variable
7907 -- A component as well. The entity does not have its Ekind
7908 -- set until the enclosing record declaration is fully
7911 or else Nkind (Parent (E)) = N_Component_Declaration
7913 -- An access to subprogram is also allowed
7917 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7919 -- Allow internal call to set convention of subprogram type
7921 or else Ekind (E) = E_Subprogram_Type
7927 ("second argument of pragma% must be subprogram (type)",
7932 -- Set the convention
7934 Set_Convention (E, C);
7935 Set_Has_Convention_Pragma (E);
7937 -- For the case of a record base type, also set the convention of
7938 -- any anonymous access types declared in the record which do not
7939 -- currently have a specified convention.
7941 if Is_Record_Type (E) and then Is_Base_Type (E) then
7946 Comp := First_Component (E);
7947 while Present (Comp) loop
7948 if Present (Etype (Comp))
7949 and then Ekind_In (Etype (Comp),
7950 E_Anonymous_Access_Type,
7951 E_Anonymous_Access_Subprogram_Type)
7952 and then not Has_Convention_Pragma (Comp)
7954 Set_Convention (Comp, C);
7957 Next_Component (Comp);
7962 -- Deal with incomplete/private type case, where underlying type
7963 -- is available, so set convention of that underlying type.
7965 if Is_Incomplete_Or_Private_Type (E)
7966 and then Present (Underlying_Type (E))
7968 Set_Convention (Underlying_Type (E), C);
7969 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7972 -- A class-wide type should inherit the convention of the specific
7973 -- root type (although this isn't specified clearly by the RM).
7975 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7976 Set_Convention (Class_Wide_Type (E), C);
7979 -- If the entity is a record type, then check for special case of
7980 -- C_Pass_By_Copy, which is treated the same as C except that the
7981 -- special record flag is set. This convention is only permitted
7982 -- on record types (see AI95-00131).
7984 if Cname = Name_C_Pass_By_Copy then
7985 if Is_Record_Type (E) then
7986 Set_C_Pass_By_Copy (Base_Type (E));
7987 elsif Is_Incomplete_Or_Private_Type (E)
7988 and then Is_Record_Type (Underlying_Type (E))
7990 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7993 ("C_Pass_By_Copy convention allowed only for record type",
7998 -- If the entity is a derived boolean type, check for the special
7999 -- case of convention C, C++, or Fortran, where we consider any
8000 -- nonzero value to represent true.
8002 if Is_Discrete_Type (E)
8003 and then Root_Type (Etype (E)) = Standard_Boolean
8009 C = Convention_Fortran)
8011 Set_Nonzero_Is_True (Base_Type (E));
8013 end Set_Convention_From_Pragma;
8017 Comp_Unit : Unit_Number_Type;
8022 -- Start of processing for Process_Convention
8025 Check_At_Least_N_Arguments (2);
8026 Check_Optional_Identifier (Arg1, Name_Convention);
8027 Check_Arg_Is_Identifier (Arg1);
8028 Cname := Chars (Get_Pragma_Arg (Arg1));
8030 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8031 -- tested again below to set the critical flag).
8033 if Cname = Name_C_Pass_By_Copy then
8036 -- Otherwise we must have something in the standard convention list
8038 elsif Is_Convention_Name (Cname) then
8039 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
8041 -- Otherwise warn on unrecognized convention
8044 if Warn_On_Export_Import then
8046 ("??unrecognized convention name, C assumed",
8047 Get_Pragma_Arg (Arg1));
8053 Check_Optional_Identifier (Arg2, Name_Entity);
8054 Check_Arg_Is_Local_Name (Arg2);
8056 Id := Get_Pragma_Arg (Arg2);
8059 if not Is_Entity_Name (Id) then
8060 Error_Pragma_Arg ("entity name required", Arg2);
8065 -- Set entity to return
8069 -- Ada_Pass_By_Copy special checking
8071 if C = Convention_Ada_Pass_By_Copy then
8072 if not Is_First_Subtype (E) then
8074 ("convention `Ada_Pass_By_Copy` only allowed for types",
8078 if Is_By_Reference_Type (E) then
8080 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8084 -- Ada_Pass_By_Reference special checking
8086 elsif C = Convention_Ada_Pass_By_Reference then
8087 if not Is_First_Subtype (E) then
8089 ("convention `Ada_Pass_By_Reference` only allowed for types",
8093 if Is_By_Copy_Type (E) then
8095 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8100 -- Go to renamed subprogram if present, since convention applies to
8101 -- the actual renamed entity, not to the renaming entity. If the
8102 -- subprogram is inherited, go to parent subprogram.
8104 if Is_Subprogram (E)
8105 and then Present (Alias (E))
8107 if Nkind (Parent (Declaration_Node (E))) =
8108 N_Subprogram_Renaming_Declaration
8110 if Scope (E) /= Scope (Alias (E)) then
8112 ("cannot apply pragma% to non-local entity&#", E);
8117 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
8118 N_Private_Extension_Declaration)
8119 and then Scope (E) = Scope (Alias (E))
8123 -- Return the parent subprogram the entity was inherited from
8129 -- Check that we are not applying this to a specless body. Relax this
8130 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8132 if Is_Subprogram (E)
8133 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
8134 and then not Relaxed_RM_Semantics
8137 ("pragma% requires separate spec and must come before body");
8140 -- Check that we are not applying this to a named constant
8142 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
8143 Error_Msg_Name_1 := Pname;
8145 ("cannot apply pragma% to named constant!",
8146 Get_Pragma_Arg (Arg2));
8148 ("\supply appropriate type for&!", Arg2);
8151 if Ekind (E) = E_Enumeration_Literal then
8152 Error_Pragma ("enumeration literal not allowed for pragma%");
8155 -- Check for rep item appearing too early or too late
8157 if Etype (E) = Any_Type
8158 or else Rep_Item_Too_Early (E, N)
8162 elsif Present (Underlying_Type (E)) then
8163 E := Underlying_Type (E);
8166 if Rep_Item_Too_Late (E, N) then
8170 if Has_Convention_Pragma (E) then
8171 Diagnose_Multiple_Pragmas (E);
8173 elsif Convention (E) = Convention_Protected
8174 or else Ekind (Scope (E)) = E_Protected_Type
8177 ("a protected operation cannot be given a different convention",
8181 -- For Intrinsic, a subprogram is required
8183 if C = Convention_Intrinsic
8184 and then not Is_Subprogram_Or_Generic_Subprogram (E)
8186 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8188 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
8190 ("second argument of pragma% must be a subprogram", Arg2);
8194 -- Deal with non-subprogram cases
8196 if not Is_Subprogram_Or_Generic_Subprogram (E) then
8197 Set_Convention_From_Pragma (E);
8201 -- The pragma must apply to a first subtype, but it can also
8202 -- apply to a generic type in a generic formal part, in which
8203 -- case it will also appear in the corresponding instance.
8205 if Is_Generic_Type (E) or else In_Instance then
8208 Check_First_Subtype (Arg2);
8211 Set_Convention_From_Pragma (Base_Type (E));
8213 -- For access subprograms, we must set the convention on the
8214 -- internally generated directly designated type as well.
8216 if Ekind (E) = E_Access_Subprogram_Type then
8217 Set_Convention_From_Pragma (Directly_Designated_Type (E));
8221 -- For the subprogram case, set proper convention for all homonyms
8222 -- in same scope and the same declarative part, i.e. the same
8223 -- compilation unit.
8226 Comp_Unit := Get_Source_Unit (E);
8227 Set_Convention_From_Pragma (E);
8229 -- Treat a pragma Import as an implicit body, and pragma import
8230 -- as implicit reference (for navigation in GPS).
8232 if Prag_Id = Pragma_Import then
8233 Generate_Reference (E, Id, 'b');
8235 -- For exported entities we restrict the generation of references
8236 -- to entities exported to foreign languages since entities
8237 -- exported to Ada do not provide further information to GPS and
8238 -- add undesired references to the output of the gnatxref tool.
8240 elsif Prag_Id = Pragma_Export
8241 and then Convention (E) /= Convention_Ada
8243 Generate_Reference (E, Id, 'i');
8246 -- If the pragma comes from an aspect, it only applies to the
8247 -- given entity, not its homonyms.
8249 if From_Aspect_Specification (N) then
8250 if C = Convention_Intrinsic
8251 and then Nkind (Ent) = N_Defining_Operator_Symbol
8253 if Is_Fixed_Point_Type (Etype (Ent))
8254 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
8255 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
8258 ("no intrinsic operator available for this fixed-point "
8261 ("\use expression functions with the desired "
8262 & "conversions made explicit", N);
8269 -- Otherwise Loop through the homonyms of the pragma argument's
8270 -- entity, an apply convention to those in the current scope.
8276 exit when No (E1) or else Scope (E1) /= Current_Scope;
8278 -- Ignore entry for which convention is already set
8280 if Has_Convention_Pragma (E1) then
8284 if Is_Subprogram (E1)
8285 and then Nkind (Parent (Declaration_Node (E1))) =
8287 and then not Relaxed_RM_Semantics
8289 Set_Has_Completion (E); -- to prevent cascaded error
8291 ("pragma% requires separate spec and must come before "
8295 -- Do not set the pragma on inherited operations or on formal
8298 if Comes_From_Source (E1)
8299 and then Comp_Unit = Get_Source_Unit (E1)
8300 and then not Is_Formal_Subprogram (E1)
8301 and then Nkind (Original_Node (Parent (E1))) /=
8302 N_Full_Type_Declaration
8304 if Present (Alias (E1))
8305 and then Scope (E1) /= Scope (Alias (E1))
8308 ("cannot apply pragma% to non-local entity& declared#",
8312 Set_Convention_From_Pragma (E1);
8314 if Prag_Id = Pragma_Import then
8315 Generate_Reference (E1, Id, 'b');
8323 end Process_Convention;
8325 ----------------------------------------
8326 -- Process_Disable_Enable_Atomic_Sync --
8327 ----------------------------------------
8329 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
8331 Check_No_Identifiers;
8332 Check_At_Most_N_Arguments (1);
8334 -- Modeled internally as
8335 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8340 Pragma_Argument_Associations => New_List (
8341 Make_Pragma_Argument_Association (Loc,
8343 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
8345 if Present (Arg1) then
8346 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
8350 end Process_Disable_Enable_Atomic_Sync;
8352 -------------------------------------------------
8353 -- Process_Extended_Import_Export_Internal_Arg --
8354 -------------------------------------------------
8356 procedure Process_Extended_Import_Export_Internal_Arg
8357 (Arg_Internal : Node_Id := Empty)
8360 if No (Arg_Internal) then
8361 Error_Pragma ("Internal parameter required for pragma%");
8364 if Nkind (Arg_Internal) = N_Identifier then
8367 elsif Nkind (Arg_Internal) = N_Operator_Symbol
8368 and then (Prag_Id = Pragma_Import_Function
8370 Prag_Id = Pragma_Export_Function)
8376 ("wrong form for Internal parameter for pragma%", Arg_Internal);
8379 Check_Arg_Is_Local_Name (Arg_Internal);
8380 end Process_Extended_Import_Export_Internal_Arg;
8382 --------------------------------------------------
8383 -- Process_Extended_Import_Export_Object_Pragma --
8384 --------------------------------------------------
8386 procedure Process_Extended_Import_Export_Object_Pragma
8387 (Arg_Internal : Node_Id;
8388 Arg_External : Node_Id;
8394 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8395 Def_Id := Entity (Arg_Internal);
8397 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
8399 ("pragma% must designate an object", Arg_Internal);
8402 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8404 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8407 ("previous Common/Psect_Object applies, pragma % not permitted",
8411 if Rep_Item_Too_Late (Def_Id, N) then
8415 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
8417 if Present (Arg_Size) then
8418 Check_Arg_Is_External_Name (Arg_Size);
8421 -- Export_Object case
8423 if Prag_Id = Pragma_Export_Object then
8424 if not Is_Library_Level_Entity (Def_Id) then
8426 ("argument for pragma% must be library level entity",
8430 if Ekind (Current_Scope) = E_Generic_Package then
8431 Error_Pragma ("pragma& cannot appear in a generic unit");
8434 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
8436 ("exported object must have compile time known size",
8440 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
8441 Error_Msg_N ("??duplicate Export_Object pragma", N);
8443 Set_Exported (Def_Id, Arg_Internal);
8446 -- Import_Object case
8449 if Is_Concurrent_Type (Etype (Def_Id)) then
8451 ("cannot use pragma% for task/protected object",
8455 if Ekind (Def_Id) = E_Constant then
8457 ("cannot import a constant", Arg_Internal);
8460 if Warn_On_Export_Import
8461 and then Has_Discriminants (Etype (Def_Id))
8464 ("imported value must be initialized??", Arg_Internal);
8467 if Warn_On_Export_Import
8468 and then Is_Access_Type (Etype (Def_Id))
8471 ("cannot import object of an access type??", Arg_Internal);
8474 if Warn_On_Export_Import
8475 and then Is_Imported (Def_Id)
8477 Error_Msg_N ("??duplicate Import_Object pragma", N);
8479 -- Check for explicit initialization present. Note that an
8480 -- initialization generated by the code generator, e.g. for an
8481 -- access type, does not count here.
8483 elsif Present (Expression (Parent (Def_Id)))
8486 (Original_Node (Expression (Parent (Def_Id))))
8488 Error_Msg_Sloc := Sloc (Def_Id);
8490 ("imported entities cannot be initialized (RM B.1(24))",
8491 "\no initialization allowed for & declared#", Arg1);
8493 Set_Imported (Def_Id);
8494 Note_Possible_Modification (Arg_Internal, Sure => False);
8497 end Process_Extended_Import_Export_Object_Pragma;
8499 ------------------------------------------------------
8500 -- Process_Extended_Import_Export_Subprogram_Pragma --
8501 ------------------------------------------------------
8503 procedure Process_Extended_Import_Export_Subprogram_Pragma
8504 (Arg_Internal : Node_Id;
8505 Arg_External : Node_Id;
8506 Arg_Parameter_Types : Node_Id;
8507 Arg_Result_Type : Node_Id := Empty;
8508 Arg_Mechanism : Node_Id;
8509 Arg_Result_Mechanism : Node_Id := Empty)
8515 Ambiguous : Boolean;
8518 function Same_Base_Type
8520 Formal : Entity_Id) return Boolean;
8521 -- Determines if Ptype references the type of Formal. Note that only
8522 -- the base types need to match according to the spec. Ptype here is
8523 -- the argument from the pragma, which is either a type name, or an
8524 -- access attribute.
8526 --------------------
8527 -- Same_Base_Type --
8528 --------------------
8530 function Same_Base_Type
8532 Formal : Entity_Id) return Boolean
8534 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
8538 -- Case where pragma argument is typ'Access
8540 if Nkind (Ptype) = N_Attribute_Reference
8541 and then Attribute_Name (Ptype) = Name_Access
8543 Pref := Prefix (Ptype);
8546 if not Is_Entity_Name (Pref)
8547 or else Entity (Pref) = Any_Type
8552 -- We have a match if the corresponding argument is of an
8553 -- anonymous access type, and its designated type matches the
8554 -- type of the prefix of the access attribute
8556 return Ekind (Ftyp) = E_Anonymous_Access_Type
8557 and then Base_Type (Entity (Pref)) =
8558 Base_Type (Etype (Designated_Type (Ftyp)));
8560 -- Case where pragma argument is a type name
8565 if not Is_Entity_Name (Ptype)
8566 or else Entity (Ptype) = Any_Type
8571 -- We have a match if the corresponding argument is of the type
8572 -- given in the pragma (comparing base types)
8574 return Base_Type (Entity (Ptype)) = Ftyp;
8578 -- Start of processing for
8579 -- Process_Extended_Import_Export_Subprogram_Pragma
8582 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
8586 -- Loop through homonyms (overloadings) of the entity
8588 Hom_Id := Entity (Arg_Internal);
8589 while Present (Hom_Id) loop
8590 Def_Id := Get_Base_Subprogram (Hom_Id);
8592 -- We need a subprogram in the current scope
8594 if not Is_Subprogram (Def_Id)
8595 or else Scope (Def_Id) /= Current_Scope
8602 -- Pragma cannot apply to subprogram body
8604 if Is_Subprogram (Def_Id)
8605 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8609 ("pragma% requires separate spec and must come before "
8613 -- Test result type if given, note that the result type
8614 -- parameter can only be present for the function cases.
8616 if Present (Arg_Result_Type)
8617 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8621 elsif Etype (Def_Id) /= Standard_Void_Type
8622 and then Nam_In (Pname, Name_Export_Procedure,
8623 Name_Import_Procedure)
8627 -- Test parameter types if given. Note that this parameter has
8628 -- not been analyzed (and must not be, since it is semantic
8629 -- nonsense), so we get it as the parser left it.
8631 elsif Present (Arg_Parameter_Types) then
8632 Check_Matching_Types : declare
8637 Formal := First_Formal (Def_Id);
8639 if Nkind (Arg_Parameter_Types) = N_Null then
8640 if Present (Formal) then
8644 -- A list of one type, e.g. (List) is parsed as a
8645 -- parenthesized expression.
8647 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8648 and then Paren_Count (Arg_Parameter_Types) = 1
8651 or else Present (Next_Formal (Formal))
8656 Same_Base_Type (Arg_Parameter_Types, Formal);
8659 -- A list of more than one type is parsed as a aggregate
8661 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8662 and then Paren_Count (Arg_Parameter_Types) = 0
8664 Ptype := First (Expressions (Arg_Parameter_Types));
8665 while Present (Ptype) or else Present (Formal) loop
8668 or else not Same_Base_Type (Ptype, Formal)
8673 Next_Formal (Formal);
8678 -- Anything else is of the wrong form
8682 ("wrong form for Parameter_Types parameter",
8683 Arg_Parameter_Types);
8685 end Check_Matching_Types;
8688 -- Match is now False if the entry we found did not match
8689 -- either a supplied Parameter_Types or Result_Types argument
8695 -- Ambiguous case, the flag Ambiguous shows if we already
8696 -- detected this and output the initial messages.
8699 if not Ambiguous then
8701 Error_Msg_Name_1 := Pname;
8703 ("pragma% does not uniquely identify subprogram!",
8705 Error_Msg_Sloc := Sloc (Ent);
8706 Error_Msg_N ("matching subprogram #!", N);
8710 Error_Msg_Sloc := Sloc (Def_Id);
8711 Error_Msg_N ("matching subprogram #!", N);
8716 Hom_Id := Homonym (Hom_Id);
8719 -- See if we found an entry
8722 if not Ambiguous then
8723 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8725 ("pragma% cannot be given for generic subprogram");
8728 ("pragma% does not identify local subprogram");
8735 -- Import pragmas must be for imported entities
8737 if Prag_Id = Pragma_Import_Function
8739 Prag_Id = Pragma_Import_Procedure
8741 Prag_Id = Pragma_Import_Valued_Procedure
8743 if not Is_Imported (Ent) then
8745 ("pragma Import or Interface must precede pragma%");
8748 -- Here we have the Export case which can set the entity as exported
8750 -- But does not do so if the specified external name is null, since
8751 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8752 -- compatible) to request no external name.
8754 elsif Nkind (Arg_External) = N_String_Literal
8755 and then String_Length (Strval (Arg_External)) = 0
8759 -- In all other cases, set entity as exported
8762 Set_Exported (Ent, Arg_Internal);
8765 -- Special processing for Valued_Procedure cases
8767 if Prag_Id = Pragma_Import_Valued_Procedure
8769 Prag_Id = Pragma_Export_Valued_Procedure
8771 Formal := First_Formal (Ent);
8774 Error_Pragma ("at least one parameter required for pragma%");
8776 elsif Ekind (Formal) /= E_Out_Parameter then
8777 Error_Pragma ("first parameter must have mode out for pragma%");
8780 Set_Is_Valued_Procedure (Ent);
8784 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8786 -- Process Result_Mechanism argument if present. We have already
8787 -- checked that this is only allowed for the function case.
8789 if Present (Arg_Result_Mechanism) then
8790 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8793 -- Process Mechanism parameter if present. Note that this parameter
8794 -- is not analyzed, and must not be analyzed since it is semantic
8795 -- nonsense, so we get it in exactly as the parser left it.
8797 if Present (Arg_Mechanism) then
8805 -- A single mechanism association without a formal parameter
8806 -- name is parsed as a parenthesized expression. All other
8807 -- cases are parsed as aggregates, so we rewrite the single
8808 -- parameter case as an aggregate for consistency.
8810 if Nkind (Arg_Mechanism) /= N_Aggregate
8811 and then Paren_Count (Arg_Mechanism) = 1
8813 Rewrite (Arg_Mechanism,
8814 Make_Aggregate (Sloc (Arg_Mechanism),
8815 Expressions => New_List (
8816 Relocate_Node (Arg_Mechanism))));
8819 -- Case of only mechanism name given, applies to all formals
8821 if Nkind (Arg_Mechanism) /= N_Aggregate then
8822 Formal := First_Formal (Ent);
8823 while Present (Formal) loop
8824 Set_Mechanism_Value (Formal, Arg_Mechanism);
8825 Next_Formal (Formal);
8828 -- Case of list of mechanism associations given
8831 if Null_Record_Present (Arg_Mechanism) then
8833 ("inappropriate form for Mechanism parameter",
8837 -- Deal with positional ones first
8839 Formal := First_Formal (Ent);
8841 if Present (Expressions (Arg_Mechanism)) then
8842 Mname := First (Expressions (Arg_Mechanism));
8843 while Present (Mname) loop
8846 ("too many mechanism associations", Mname);
8849 Set_Mechanism_Value (Formal, Mname);
8850 Next_Formal (Formal);
8855 -- Deal with named entries
8857 if Present (Component_Associations (Arg_Mechanism)) then
8858 Massoc := First (Component_Associations (Arg_Mechanism));
8859 while Present (Massoc) loop
8860 Choice := First (Choices (Massoc));
8862 if Nkind (Choice) /= N_Identifier
8863 or else Present (Next (Choice))
8866 ("incorrect form for mechanism association",
8870 Formal := First_Formal (Ent);
8874 ("parameter name & not present", Choice);
8877 if Chars (Choice) = Chars (Formal) then
8879 (Formal, Expression (Massoc));
8881 -- Set entity on identifier (needed by ASIS)
8883 Set_Entity (Choice, Formal);
8888 Next_Formal (Formal);
8897 end Process_Extended_Import_Export_Subprogram_Pragma;
8899 --------------------------
8900 -- Process_Generic_List --
8901 --------------------------
8903 procedure Process_Generic_List is
8908 Check_No_Identifiers;
8909 Check_At_Least_N_Arguments (1);
8911 -- Check all arguments are names of generic units or instances
8914 while Present (Arg) loop
8915 Exp := Get_Pragma_Arg (Arg);
8918 if not Is_Entity_Name (Exp)
8920 (not Is_Generic_Instance (Entity (Exp))
8922 not Is_Generic_Unit (Entity (Exp)))
8925 ("pragma% argument must be name of generic unit/instance",
8931 end Process_Generic_List;
8933 ------------------------------------
8934 -- Process_Import_Predefined_Type --
8935 ------------------------------------
8937 procedure Process_Import_Predefined_Type is
8938 Loc : constant Source_Ptr := Sloc (N);
8940 Ftyp : Node_Id := Empty;
8946 Nam := String_To_Name (Strval (Expression (Arg3)));
8948 Elmt := First_Elmt (Predefined_Float_Types);
8949 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8953 Ftyp := Node (Elmt);
8955 if Present (Ftyp) then
8957 -- Don't build a derived type declaration, because predefined C
8958 -- types have no declaration anywhere, so cannot really be named.
8959 -- Instead build a full type declaration, starting with an
8960 -- appropriate type definition is built
8962 if Is_Floating_Point_Type (Ftyp) then
8963 Def := Make_Floating_Point_Definition (Loc,
8964 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8965 Make_Real_Range_Specification (Loc,
8966 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8967 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8969 -- Should never have a predefined type we cannot handle
8972 raise Program_Error;
8975 -- Build and insert a Full_Type_Declaration, which will be
8976 -- analyzed as soon as this list entry has been analyzed.
8978 Decl := Make_Full_Type_Declaration (Loc,
8979 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8980 Type_Definition => Def);
8982 Insert_After (N, Decl);
8983 Mark_Rewrite_Insertion (Decl);
8986 Error_Pragma_Arg ("no matching type found for pragma%", Arg2);
8988 end Process_Import_Predefined_Type;
8990 ---------------------------------
8991 -- Process_Import_Or_Interface --
8992 ---------------------------------
8994 procedure Process_Import_Or_Interface is
9000 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9001 -- pragma Import (Entity, "external name");
9003 if Relaxed_RM_Semantics
9004 and then Arg_Count = 2
9005 and then Prag_Id = Pragma_Import
9006 and then Nkind (Expression (Arg2)) = N_String_Literal
9009 Def_Id := Get_Pragma_Arg (Arg1);
9012 if not Is_Entity_Name (Def_Id) then
9013 Error_Pragma_Arg ("entity name required", Arg1);
9016 Def_Id := Entity (Def_Id);
9017 Kill_Size_Check_Code (Def_Id);
9018 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
9021 Process_Convention (C, Def_Id);
9023 -- A pragma that applies to a Ghost entity becomes Ghost for the
9024 -- purposes of legality checks and removal of ignored Ghost code.
9026 Mark_Ghost_Pragma (N, Def_Id);
9027 Kill_Size_Check_Code (Def_Id);
9028 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
9031 -- Various error checks
9033 if Ekind_In (Def_Id, E_Variable, E_Constant) then
9035 -- We do not permit Import to apply to a renaming declaration
9037 if Present (Renamed_Object (Def_Id)) then
9039 ("pragma% not allowed for object renaming", Arg2);
9041 -- User initialization is not allowed for imported object, but
9042 -- the object declaration may contain a default initialization,
9043 -- that will be discarded. Note that an explicit initialization
9044 -- only counts if it comes from source, otherwise it is simply
9045 -- the code generator making an implicit initialization explicit.
9047 elsif Present (Expression (Parent (Def_Id)))
9048 and then Comes_From_Source
9049 (Original_Node (Expression (Parent (Def_Id))))
9051 -- Set imported flag to prevent cascaded errors
9053 Set_Is_Imported (Def_Id);
9055 Error_Msg_Sloc := Sloc (Def_Id);
9057 ("no initialization allowed for declaration of& #",
9058 "\imported entities cannot be initialized (RM B.1(24))",
9062 -- If the pragma comes from an aspect specification the
9063 -- Is_Imported flag has already been set.
9065 if not From_Aspect_Specification (N) then
9066 Set_Imported (Def_Id);
9069 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9071 -- Note that we do not set Is_Public here. That's because we
9072 -- only want to set it if there is no address clause, and we
9073 -- don't know that yet, so we delay that processing till
9076 -- pragma Import completes deferred constants
9078 if Ekind (Def_Id) = E_Constant then
9079 Set_Has_Completion (Def_Id);
9082 -- It is not possible to import a constant of an unconstrained
9083 -- array type (e.g. string) because there is no simple way to
9084 -- write a meaningful subtype for it.
9086 if Is_Array_Type (Etype (Def_Id))
9087 and then not Is_Constrained (Etype (Def_Id))
9090 ("imported constant& must have a constrained subtype",
9095 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9097 -- If the name is overloaded, pragma applies to all of the denoted
9098 -- entities in the same declarative part, unless the pragma comes
9099 -- from an aspect specification or was generated by the compiler
9100 -- (such as for pragma Provide_Shift_Operators).
9103 while Present (Hom_Id) loop
9105 Def_Id := Get_Base_Subprogram (Hom_Id);
9107 -- Ignore inherited subprograms because the pragma will apply
9108 -- to the parent operation, which is the one called.
9110 if Is_Overloadable (Def_Id)
9111 and then Present (Alias (Def_Id))
9115 -- If it is not a subprogram, it must be in an outer scope and
9116 -- pragma does not apply.
9118 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
9121 -- The pragma does not apply to primitives of interfaces
9123 elsif Is_Dispatching_Operation (Def_Id)
9124 and then Present (Find_Dispatching_Type (Def_Id))
9125 and then Is_Interface (Find_Dispatching_Type (Def_Id))
9129 -- Verify that the homonym is in the same declarative part (not
9130 -- just the same scope). If the pragma comes from an aspect
9131 -- specification we know that it is part of the declaration.
9133 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
9134 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9135 and then not From_Aspect_Specification (N)
9140 -- If the pragma comes from an aspect specification the
9141 -- Is_Imported flag has already been set.
9143 if not From_Aspect_Specification (N) then
9144 Set_Imported (Def_Id);
9147 -- Reject an Import applied to an abstract subprogram
9149 if Is_Subprogram (Def_Id)
9150 and then Is_Abstract_Subprogram (Def_Id)
9152 Error_Msg_Sloc := Sloc (Def_Id);
9154 ("cannot import abstract subprogram& declared#",
9158 -- Special processing for Convention_Intrinsic
9160 if C = Convention_Intrinsic then
9162 -- Link_Name argument not allowed for intrinsic
9166 Set_Is_Intrinsic_Subprogram (Def_Id);
9168 -- If no external name is present, then check that this
9169 -- is a valid intrinsic subprogram. If an external name
9170 -- is present, then this is handled by the back end.
9173 Check_Intrinsic_Subprogram
9174 (Def_Id, Get_Pragma_Arg (Arg2));
9178 -- Verify that the subprogram does not have a completion
9179 -- through a renaming declaration. For other completions the
9180 -- pragma appears as a too late representation.
9183 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
9187 and then Nkind (Decl) = N_Subprogram_Declaration
9188 and then Present (Corresponding_Body (Decl))
9189 and then Nkind (Unit_Declaration_Node
9190 (Corresponding_Body (Decl))) =
9191 N_Subprogram_Renaming_Declaration
9193 Error_Msg_Sloc := Sloc (Def_Id);
9195 ("cannot import&, renaming already provided for "
9196 & "declaration #", N, Def_Id);
9200 -- If the pragma comes from an aspect specification, there
9201 -- must be an Import aspect specified as well. In the rare
9202 -- case where Import is set to False, the suprogram needs to
9203 -- have a local completion.
9206 Imp_Aspect : constant Node_Id :=
9207 Find_Aspect (Def_Id, Aspect_Import);
9211 if Present (Imp_Aspect)
9212 and then Present (Expression (Imp_Aspect))
9214 Expr := Expression (Imp_Aspect);
9215 Analyze_And_Resolve (Expr, Standard_Boolean);
9217 if Is_Entity_Name (Expr)
9218 and then Entity (Expr) = Standard_True
9220 Set_Has_Completion (Def_Id);
9223 -- If there is no expression, the default is True, as for
9224 -- all boolean aspects. Same for the older pragma.
9227 Set_Has_Completion (Def_Id);
9231 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
9234 if Is_Compilation_Unit (Hom_Id) then
9236 -- Its possible homonyms are not affected by the pragma.
9237 -- Such homonyms might be present in the context of other
9238 -- units being compiled.
9242 elsif From_Aspect_Specification (N) then
9245 -- If the pragma was created by the compiler, then we don't
9246 -- want it to apply to other homonyms. This kind of case can
9247 -- occur when using pragma Provide_Shift_Operators, which
9248 -- generates implicit shift and rotate operators with Import
9249 -- pragmas that might apply to earlier explicit or implicit
9250 -- declarations marked with Import (for example, coming from
9251 -- an earlier pragma Provide_Shift_Operators for another type),
9252 -- and we don't generally want other homonyms being treated
9253 -- as imported or the pragma flagged as an illegal duplicate.
9255 elsif not Comes_From_Source (N) then
9259 Hom_Id := Homonym (Hom_Id);
9263 -- Import a CPP class
9265 elsif C = Convention_CPP
9266 and then (Is_Record_Type (Def_Id)
9267 or else Ekind (Def_Id) = E_Incomplete_Type)
9269 if Ekind (Def_Id) = E_Incomplete_Type then
9270 if Present (Full_View (Def_Id)) then
9271 Def_Id := Full_View (Def_Id);
9275 ("cannot import 'C'P'P type before full declaration seen",
9276 Get_Pragma_Arg (Arg2));
9278 -- Although we have reported the error we decorate it as
9279 -- CPP_Class to avoid reporting spurious errors
9281 Set_Is_CPP_Class (Def_Id);
9286 -- Types treated as CPP classes must be declared limited (note:
9287 -- this used to be a warning but there is no real benefit to it
9288 -- since we did effectively intend to treat the type as limited
9291 if not Is_Limited_Type (Def_Id) then
9293 ("imported 'C'P'P type must be limited",
9294 Get_Pragma_Arg (Arg2));
9297 if Etype (Def_Id) /= Def_Id
9298 and then not Is_CPP_Class (Root_Type (Def_Id))
9300 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
9303 Set_Is_CPP_Class (Def_Id);
9305 -- Imported CPP types must not have discriminants (because C++
9306 -- classes do not have discriminants).
9308 if Has_Discriminants (Def_Id) then
9310 ("imported 'C'P'P type cannot have discriminants",
9311 First (Discriminant_Specifications
9312 (Declaration_Node (Def_Id))));
9315 -- Check that components of imported CPP types do not have default
9316 -- expressions. For private types this check is performed when the
9317 -- full view is analyzed (see Process_Full_View).
9319 if not Is_Private_Type (Def_Id) then
9320 Check_CPP_Type_Has_No_Defaults (Def_Id);
9323 -- Import a CPP exception
9325 elsif C = Convention_CPP
9326 and then Ekind (Def_Id) = E_Exception
9330 ("'External_'Name arguments is required for 'Cpp exception",
9333 -- As only a string is allowed, Check_Arg_Is_External_Name
9336 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9339 if Present (Arg4) then
9341 ("Link_Name argument not allowed for imported Cpp exception",
9345 -- Do not call Set_Interface_Name as the name of the exception
9346 -- shouldn't be modified (and in particular it shouldn't be
9347 -- the External_Name). For exceptions, the External_Name is the
9348 -- name of the RTTI structure.
9350 -- ??? Emit an error if pragma Import/Export_Exception is present
9352 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
9354 Check_Arg_Count (3);
9355 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
9357 Process_Import_Predefined_Type;
9361 ("second argument of pragma% must be object, subprogram "
9362 & "or incomplete type",
9366 -- If this pragma applies to a compilation unit, then the unit, which
9367 -- is a subprogram, does not require (or allow) a body. We also do
9368 -- not need to elaborate imported procedures.
9370 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9372 Cunit : constant Node_Id := Parent (Parent (N));
9374 Set_Body_Required (Cunit, False);
9377 end Process_Import_Or_Interface;
9379 --------------------
9380 -- Process_Inline --
9381 --------------------
9383 procedure Process_Inline (Status : Inline_Status) is
9390 Ghost_Error_Posted : Boolean := False;
9391 -- Flag set when an error concerning the illegal mix of Ghost and
9392 -- non-Ghost subprograms is emitted.
9394 Ghost_Id : Entity_Id := Empty;
9395 -- The entity of the first Ghost subprogram encountered while
9396 -- processing the arguments of the pragma.
9398 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id);
9399 -- Verify the placement of pragma Inline_Always with respect to the
9400 -- initial declaration of subprogram Spec_Id.
9402 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
9403 -- Returns True if it can be determined at this stage that inlining
9404 -- is not possible, for example if the body is available and contains
9405 -- exception handlers, we prevent inlining, since otherwise we can
9406 -- get undefined symbols at link time. This function also emits a
9407 -- warning if the pragma appears too late.
9409 -- ??? is business with link symbols still valid, or does it relate
9410 -- to front end ZCX which is being phased out ???
9412 procedure Make_Inline (Subp : Entity_Id);
9413 -- Subp is the defining unit name of the subprogram declaration. If
9414 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9415 -- the corresponding body, if there is one present.
9417 procedure Set_Inline_Flags (Subp : Entity_Id);
9418 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9419 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9421 -----------------------------------
9422 -- Check_Inline_Always_Placement --
9423 -----------------------------------
9425 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is
9426 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9428 function Compilation_Unit_OK return Boolean;
9429 pragma Inline (Compilation_Unit_OK);
9430 -- Determine whether pragma Inline_Always applies to a compatible
9431 -- compilation unit denoted by Spec_Id.
9433 function Declarative_List_OK return Boolean;
9434 pragma Inline (Declarative_List_OK);
9435 -- Determine whether the initial declaration of subprogram Spec_Id
9436 -- and the pragma appear in compatible declarative lists.
9438 function Subprogram_Body_OK return Boolean;
9439 pragma Inline (Subprogram_Body_OK);
9440 -- Determine whether pragma Inline_Always applies to a compatible
9441 -- subprogram body denoted by Spec_Id.
9443 -------------------------
9444 -- Compilation_Unit_OK --
9445 -------------------------
9447 function Compilation_Unit_OK return Boolean is
9448 Comp_Unit : constant Node_Id := Parent (Spec_Decl);
9451 -- The pragma appears after the initial declaration of a
9452 -- compilation unit.
9454 -- procedure Comp_Unit;
9455 -- pragma Inline_Always (Comp_Unit);
9457 -- Note that for compatibility reasons, the following case is
9460 -- procedure Stand_Alone_Body_Comp_Unit is
9462 -- end Stand_Alone_Body_Comp_Unit;
9463 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9466 Nkind (Comp_Unit) = N_Compilation_Unit
9467 and then Present (Aux_Decls_Node (Comp_Unit))
9468 and then Is_List_Member (N)
9469 and then List_Containing (N) =
9470 Pragmas_After (Aux_Decls_Node (Comp_Unit));
9471 end Compilation_Unit_OK;
9473 -------------------------
9474 -- Declarative_List_OK --
9475 -------------------------
9477 function Declarative_List_OK return Boolean is
9478 Context : constant Node_Id := Parent (Spec_Decl);
9480 Init_Decl : Node_Id;
9481 Init_List : List_Id;
9482 Prag_List : List_Id;
9485 -- Determine the proper initial declaration. In general this is
9486 -- the declaration node of the subprogram except when the input
9487 -- denotes a generic instantiation.
9489 -- procedure Inst is new Gen;
9490 -- pragma Inline_Always (Inst);
9492 -- In this case the original subprogram is moved inside an
9493 -- anonymous package while pragma Inline_Always remains at the
9494 -- level of the anonymous package. Use the declaration of the
9495 -- package because it reflects the placement of the original
9498 -- package Anon_Pack is
9499 -- procedure Inst is ... end Inst; -- original
9502 -- procedure Inst renames Anon_Pack.Inst;
9503 -- pragma Inline_Always (Inst);
9505 if Is_Generic_Instance (Spec_Id) then
9506 Init_Decl := Parent (Parent (Spec_Decl));
9507 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration);
9509 Init_Decl := Spec_Decl;
9512 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then
9513 Init_List := List_Containing (Init_Decl);
9514 Prag_List := List_Containing (N);
9516 -- The pragma and then initial declaration appear within the
9517 -- same declarative list.
9519 if Init_List = Prag_List then
9522 -- A special case of the above is when both the pragma and
9523 -- the initial declaration appear in different lists of a
9524 -- package spec, protected definition, or a task definition.
9529 -- pragma Inline_Always (Proc);
9532 elsif Nkind_In (Context, N_Package_Specification,
9533 N_Protected_Definition,
9535 and then Init_List = Visible_Declarations (Context)
9536 and then Prag_List = Private_Declarations (Context)
9543 end Declarative_List_OK;
9545 ------------------------
9546 -- Subprogram_Body_OK --
9547 ------------------------
9549 function Subprogram_Body_OK return Boolean is
9550 Body_Decl : Node_Id;
9553 -- The pragma appears within the declarative list of a stand-
9554 -- alone subprogram body.
9556 -- procedure Stand_Alone_Body is
9557 -- pragma Inline_Always (Stand_Alone_Body);
9560 -- end Stand_Alone_Body;
9562 -- The compiler creates a dummy spec in this case, however the
9563 -- pragma remains within the declarative list of the body.
9565 if Nkind (Spec_Decl) = N_Subprogram_Declaration
9566 and then not Comes_From_Source (Spec_Decl)
9567 and then Present (Corresponding_Body (Spec_Decl))
9570 Unit_Declaration_Node (Corresponding_Body (Spec_Decl));
9572 if Present (Declarations (Body_Decl))
9573 and then Is_List_Member (N)
9574 and then List_Containing (N) = Declarations (Body_Decl)
9581 end Subprogram_Body_OK;
9583 -- Start of processing for Check_Inline_Always_Placement
9586 -- This check is relevant only for pragma Inline_Always
9588 if Pname /= Name_Inline_Always then
9591 -- Nothing to do when the pragma is internally generated on the
9592 -- assumption that it is properly placed.
9594 elsif not Comes_From_Source (N) then
9597 -- Nothing to do for internally generated subprograms that act
9598 -- as accidental homonyms of a source subprogram being inlined.
9600 elsif not Comes_From_Source (Spec_Id) then
9603 -- Nothing to do for generic formal subprograms that act as
9604 -- homonyms of another source subprogram being inlined.
9606 elsif Is_Formal_Subprogram (Spec_Id) then
9609 elsif Compilation_Unit_OK
9610 or else Declarative_List_OK
9611 or else Subprogram_Body_OK
9616 -- At this point it is known that the pragma applies to or appears
9617 -- within a completing body, a completing stub, or a subunit.
9619 Error_Msg_Name_1 := Pname;
9620 Error_Msg_Name_2 := Chars (Spec_Id);
9621 Error_Msg_Sloc := Sloc (Spec_Id);
9624 ("pragma % must appear on initial declaration of subprogram "
9625 & "% defined #", N);
9626 end Check_Inline_Always_Placement;
9628 ---------------------------
9629 -- Inlining_Not_Possible --
9630 ---------------------------
9632 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
9633 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
9637 if Nkind (Decl) = N_Subprogram_Body then
9638 Stats := Handled_Statement_Sequence (Decl);
9639 return Present (Exception_Handlers (Stats))
9640 or else Present (At_End_Proc (Stats));
9642 elsif Nkind (Decl) = N_Subprogram_Declaration
9643 and then Present (Corresponding_Body (Decl))
9645 if Analyzed (Corresponding_Body (Decl)) then
9646 Error_Msg_N ("pragma appears too late, ignored??", N);
9649 -- If the subprogram is a renaming as body, the body is just a
9650 -- call to the renamed subprogram, and inlining is trivially
9654 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
9655 N_Subprogram_Renaming_Declaration
9661 Handled_Statement_Sequence
9662 (Unit_Declaration_Node (Corresponding_Body (Decl)));
9665 Present (Exception_Handlers (Stats))
9666 or else Present (At_End_Proc (Stats));
9670 -- If body is not available, assume the best, the check is
9671 -- performed again when compiling enclosing package bodies.
9675 end Inlining_Not_Possible;
9681 procedure Make_Inline (Subp : Entity_Id) is
9682 Kind : constant Entity_Kind := Ekind (Subp);
9683 Inner_Subp : Entity_Id := Subp;
9686 -- Ignore if bad type, avoid cascaded error
9688 if Etype (Subp) = Any_Type then
9692 -- If inlining is not possible, for now do not treat as an error
9694 elsif Status /= Suppressed
9695 and then Front_End_Inlining
9696 and then Inlining_Not_Possible (Subp)
9701 -- Here we have a candidate for inlining, but we must exclude
9702 -- derived operations. Otherwise we would end up trying to inline
9703 -- a phantom declaration, and the result would be to drag in a
9704 -- body which has no direct inlining associated with it. That
9705 -- would not only be inefficient but would also result in the
9706 -- backend doing cross-unit inlining in cases where it was
9707 -- definitely inappropriate to do so.
9709 -- However, a simple Comes_From_Source test is insufficient, since
9710 -- we do want to allow inlining of generic instances which also do
9711 -- not come from source. We also need to recognize specs generated
9712 -- by the front-end for bodies that carry the pragma. Finally,
9713 -- predefined operators do not come from source but are not
9714 -- inlineable either.
9716 elsif Is_Generic_Instance (Subp)
9717 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
9721 elsif not Comes_From_Source (Subp)
9722 and then Scope (Subp) /= Standard_Standard
9728 -- The referenced entity must either be the enclosing entity, or
9729 -- an entity declared within the current open scope.
9731 if Present (Scope (Subp))
9732 and then Scope (Subp) /= Current_Scope
9733 and then Subp /= Current_Scope
9736 ("argument of% must be entity in current scope", Assoc);
9740 -- Processing for procedure, operator or function. If subprogram
9741 -- is aliased (as for an instance) indicate that the renamed
9742 -- entity (if declared in the same unit) is inlined.
9743 -- If this is the anonymous subprogram created for a subprogram
9744 -- instance, the inlining applies to it directly. Otherwise we
9745 -- retrieve it as the alias of the visible subprogram instance.
9747 if Is_Subprogram (Subp) then
9749 -- Ensure that pragma Inline_Always is associated with the
9750 -- initial declaration of the subprogram.
9752 Check_Inline_Always_Placement (Subp);
9754 if Is_Wrapper_Package (Scope (Subp)) then
9757 Inner_Subp := Ultimate_Alias (Inner_Subp);
9760 if In_Same_Source_Unit (Subp, Inner_Subp) then
9761 Set_Inline_Flags (Inner_Subp);
9763 Decl := Parent (Parent (Inner_Subp));
9765 if Nkind (Decl) = N_Subprogram_Declaration
9766 and then Present (Corresponding_Body (Decl))
9768 Set_Inline_Flags (Corresponding_Body (Decl));
9770 elsif Is_Generic_Instance (Subp)
9771 and then Comes_From_Source (Subp)
9773 -- Indicate that the body needs to be created for
9774 -- inlining subsequent calls. The instantiation node
9775 -- follows the declaration of the wrapper package
9776 -- created for it. The subprogram that requires the
9777 -- body is the anonymous one in the wrapper package.
9779 if Scope (Subp) /= Standard_Standard
9781 Need_Subprogram_Instance_Body
9782 (Next (Unit_Declaration_Node
9783 (Scope (Alias (Subp)))), Subp)
9788 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9789 -- appear in a formal part to apply to a formal subprogram.
9790 -- Do not apply check within an instance or a formal package
9791 -- the test will have been applied to the original generic.
9793 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
9794 and then List_Containing (Decl) = List_Containing (N)
9795 and then not In_Instance
9798 ("Inline cannot apply to a formal subprogram", N);
9800 -- If Subp is a renaming, it is the renamed entity that
9801 -- will appear in any call, and be inlined. However, for
9802 -- ASIS uses it is convenient to indicate that the renaming
9803 -- itself is an inlined subprogram, so that some gnatcheck
9804 -- rules can be applied in the absence of expansion.
9806 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
9807 Set_Inline_Flags (Subp);
9813 -- For a generic subprogram set flag as well, for use at the point
9814 -- of instantiation, to determine whether the body should be
9817 elsif Is_Generic_Subprogram (Subp) then
9818 Set_Inline_Flags (Subp);
9821 -- Literals are by definition inlined
9823 elsif Kind = E_Enumeration_Literal then
9826 -- Anything else is an error
9830 ("expect subprogram name for pragma%", Assoc);
9834 ----------------------
9835 -- Set_Inline_Flags --
9836 ----------------------
9838 procedure Set_Inline_Flags (Subp : Entity_Id) is
9840 -- First set the Has_Pragma_XXX flags and issue the appropriate
9841 -- errors and warnings for suspicious combinations.
9843 if Prag_Id = Pragma_No_Inline then
9844 if Has_Pragma_Inline_Always (Subp) then
9846 ("Inline_Always and No_Inline are mutually exclusive", N);
9847 elsif Has_Pragma_Inline (Subp) then
9849 ("Inline and No_Inline both specified for& ??",
9850 N, Entity (Subp_Id));
9853 Set_Has_Pragma_No_Inline (Subp);
9855 if Prag_Id = Pragma_Inline_Always then
9856 if Has_Pragma_No_Inline (Subp) then
9858 ("Inline_Always and No_Inline are mutually exclusive",
9862 Set_Has_Pragma_Inline_Always (Subp);
9864 if Has_Pragma_No_Inline (Subp) then
9866 ("Inline and No_Inline both specified for& ??",
9867 N, Entity (Subp_Id));
9871 Set_Has_Pragma_Inline (Subp);
9874 -- Then adjust the Is_Inlined flag. It can never be set if the
9875 -- subprogram is subject to pragma No_Inline.
9879 Set_Is_Inlined (Subp, False);
9885 if not Has_Pragma_No_Inline (Subp) then
9886 Set_Is_Inlined (Subp, True);
9890 -- A pragma that applies to a Ghost entity becomes Ghost for the
9891 -- purposes of legality checks and removal of ignored Ghost code.
9893 Mark_Ghost_Pragma (N, Subp);
9895 -- Capture the entity of the first Ghost subprogram being
9896 -- processed for error detection purposes.
9898 if Is_Ghost_Entity (Subp) then
9899 if No (Ghost_Id) then
9903 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9904 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9906 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9907 Ghost_Error_Posted := True;
9909 Error_Msg_Name_1 := Pname;
9911 ("pragma % cannot mention ghost and non-ghost subprograms",
9914 Error_Msg_Sloc := Sloc (Ghost_Id);
9915 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9917 Error_Msg_Sloc := Sloc (Subp);
9918 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9920 end Set_Inline_Flags;
9922 -- Start of processing for Process_Inline
9925 -- An inlined subprogram may grant access to its private enclosing
9926 -- context depending on the placement of its body. From elaboration
9927 -- point of view, the flow of execution may enter this private
9928 -- context, and then reach an external unit, thus producing a
9929 -- dependency on that external unit. For such a path to be properly
9930 -- discovered and encoded in the ALI file of the main unit, let the
9931 -- ABE mechanism process the body of the main unit, and encode all
9932 -- relevant invocation constructs and the relations between them.
9934 Mark_Save_Invocation_Graph_Of_Body;
9936 Check_No_Identifiers;
9937 Check_At_Least_N_Arguments (1);
9939 if Status = Enabled then
9940 Inline_Processing_Required := True;
9944 while Present (Assoc) loop
9945 Subp_Id := Get_Pragma_Arg (Assoc);
9949 if Is_Entity_Name (Subp_Id) then
9950 Subp := Entity (Subp_Id);
9952 if Subp = Any_Id then
9954 -- If previous error, avoid cascaded errors
9956 Check_Error_Detected;
9962 -- For the pragma case, climb homonym chain. This is
9963 -- what implements allowing the pragma in the renaming
9964 -- case, with the result applying to the ancestors, and
9965 -- also allows Inline to apply to all previous homonyms.
9967 if not From_Aspect_Specification (N) then
9968 while Present (Homonym (Subp))
9969 and then Scope (Homonym (Subp)) = Current_Scope
9971 Make_Inline (Homonym (Subp));
9972 Subp := Homonym (Subp);
9979 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9985 -- If the context is a package declaration, the pragma indicates
9986 -- that inlining will require the presence of the corresponding
9987 -- body. (this may be further refined).
9990 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9991 N_Package_Declaration
9993 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit));
9997 ----------------------------
9998 -- Process_Interface_Name --
9999 ----------------------------
10001 procedure Process_Interface_Name
10002 (Subprogram_Def : Entity_Id;
10004 Link_Arg : Node_Id;
10008 Link_Nam : Node_Id;
10009 String_Val : String_Id;
10011 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
10012 -- SN is a string literal node for an interface name. This routine
10013 -- performs some minimal checks that the name is reasonable. In
10014 -- particular that no spaces or other obviously incorrect characters
10015 -- appear. This is only a warning, since any characters are allowed.
10017 ----------------------------------
10018 -- Check_Form_Of_Interface_Name --
10019 ----------------------------------
10021 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
10022 S : constant String_Id := Strval (Expr_Value_S (SN));
10023 SL : constant Nat := String_Length (S);
10028 Error_Msg_N ("interface name cannot be null string", SN);
10031 for J in 1 .. SL loop
10032 C := Get_String_Char (S, J);
10034 -- Look for dubious character and issue unconditional warning.
10035 -- Definitely dubious if not in character range.
10037 if not In_Character_Range (C)
10039 -- Commas, spaces and (back)slashes are dubious
10041 or else Get_Character (C) = ','
10042 or else Get_Character (C) = '\'
10043 or else Get_Character (C) = ' '
10044 or else Get_Character (C) = '/'
10047 ("??interface name contains illegal character",
10048 Sloc (SN) + Source_Ptr (J));
10051 end Check_Form_Of_Interface_Name;
10053 -- Start of processing for Process_Interface_Name
10056 -- If we are looking at a pragma that comes from an aspect then it
10057 -- needs to have its corresponding aspect argument expressions
10058 -- analyzed in addition to the generated pragma so that aspects
10059 -- within generic units get properly resolved.
10061 if Present (Prag) and then From_Aspect_Specification (Prag) then
10063 Asp : constant Node_Id := Corresponding_Aspect (Prag);
10071 -- Obtain all interfacing aspects used to construct the pragma
10073 Get_Interfacing_Aspects
10074 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN);
10076 -- Analyze the expression of aspect External_Name
10078 if Present (EN) then
10079 Analyze (Expression (EN));
10082 -- Analyze the expressio of aspect Link_Name
10084 if Present (LN) then
10085 Analyze (Expression (LN));
10090 if No (Link_Arg) then
10091 if No (Ext_Arg) then
10094 elsif Chars (Ext_Arg) = Name_Link_Name then
10096 Link_Nam := Expression (Ext_Arg);
10099 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10100 Ext_Nam := Expression (Ext_Arg);
10105 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
10106 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
10107 Ext_Nam := Expression (Ext_Arg);
10108 Link_Nam := Expression (Link_Arg);
10111 -- Check expressions for external name and link name are static
10113 if Present (Ext_Nam) then
10114 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
10115 Check_Form_Of_Interface_Name (Ext_Nam);
10117 -- Verify that external name is not the name of a local entity,
10118 -- which would hide the imported one and could lead to run-time
10119 -- surprises. The problem can only arise for entities declared in
10120 -- a package body (otherwise the external name is fully qualified
10121 -- and will not conflict).
10129 if Prag_Id = Pragma_Import then
10130 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam)));
10131 E := Entity_Id (Get_Name_Table_Int (Nam));
10133 if Nam /= Chars (Subprogram_Def)
10134 and then Present (E)
10135 and then not Is_Overloadable (E)
10136 and then Is_Immediately_Visible (E)
10137 and then not Is_Imported (E)
10138 and then Ekind (Scope (E)) = E_Package
10141 while Present (Par) loop
10142 if Nkind (Par) = N_Package_Body then
10143 Error_Msg_Sloc := Sloc (E);
10145 ("imported entity is hidden by & declared#",
10150 Par := Parent (Par);
10157 if Present (Link_Nam) then
10158 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
10159 Check_Form_Of_Interface_Name (Link_Nam);
10162 -- If there is no link name, just set the external name
10164 if No (Link_Nam) then
10165 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
10167 -- For the Link_Name case, the given literal is preceded by an
10168 -- asterisk, which indicates to GCC that the given name should be
10169 -- taken literally, and in particular that no prepending of
10170 -- underlines should occur, even in systems where this is the
10175 Store_String_Char (Get_Char_Code ('*'));
10176 String_Val := Strval (Expr_Value_S (Link_Nam));
10177 Store_String_Chars (String_Val);
10179 Make_String_Literal (Sloc (Link_Nam),
10180 Strval => End_String);
10183 -- Set the interface name. If the entity is a generic instance, use
10184 -- its alias, which is the callable entity.
10186 if Is_Generic_Instance (Subprogram_Def) then
10187 Set_Encoded_Interface_Name
10188 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
10190 Set_Encoded_Interface_Name
10191 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
10194 Check_Duplicated_Export_Name (Link_Nam);
10195 end Process_Interface_Name;
10197 -----------------------------------------
10198 -- Process_Interrupt_Or_Attach_Handler --
10199 -----------------------------------------
10201 procedure Process_Interrupt_Or_Attach_Handler is
10202 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
10203 Prot_Typ : constant Entity_Id := Scope (Handler);
10206 -- A pragma that applies to a Ghost entity becomes Ghost for the
10207 -- purposes of legality checks and removal of ignored Ghost code.
10209 Mark_Ghost_Pragma (N, Handler);
10210 Set_Is_Interrupt_Handler (Handler);
10212 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
10214 Record_Rep_Item (Prot_Typ, N);
10216 -- Chain the pragma on the contract for completeness
10218 Add_Contract_Item (N, Handler);
10219 end Process_Interrupt_Or_Attach_Handler;
10221 --------------------------------------------------
10222 -- Process_Restrictions_Or_Restriction_Warnings --
10223 --------------------------------------------------
10225 -- Note: some of the simple identifier cases were handled in par-prag,
10226 -- but it is harmless (and more straightforward) to simply handle all
10227 -- cases here, even if it means we repeat a bit of work in some cases.
10229 procedure Process_Restrictions_Or_Restriction_Warnings
10233 R_Id : Restriction_Id;
10239 -- Ignore all Restrictions pragmas in CodePeer mode
10241 if CodePeer_Mode then
10245 Check_Ada_83_Warning;
10246 Check_At_Least_N_Arguments (1);
10247 Check_Valid_Configuration_Pragma;
10250 while Present (Arg) loop
10252 Expr := Get_Pragma_Arg (Arg);
10254 -- Case of no restriction identifier present
10256 if Id = No_Name then
10257 if Nkind (Expr) /= N_Identifier then
10259 ("invalid form for restriction", Arg);
10264 (Process_Restriction_Synonyms (Expr));
10266 if R_Id not in All_Boolean_Restrictions then
10267 Error_Msg_Name_1 := Pname;
10269 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
10271 -- Check for possible misspelling
10273 for J in Restriction_Id loop
10275 Rnm : constant String := Restriction_Id'Image (J);
10278 Name_Buffer (1 .. Rnm'Length) := Rnm;
10279 Name_Len := Rnm'Length;
10280 Set_Casing (All_Lower_Case);
10282 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
10285 (Source_Index (Current_Sem_Unit)));
10286 Error_Msg_String (1 .. Rnm'Length) :=
10287 Name_Buffer (1 .. Name_Len);
10288 Error_Msg_Strlen := Rnm'Length;
10289 Error_Msg_N -- CODEFIX
10290 ("\possible misspelling of ""~""",
10291 Get_Pragma_Arg (Arg));
10300 if Implementation_Restriction (R_Id) then
10301 Check_Restriction (No_Implementation_Restrictions, Arg);
10304 -- Special processing for No_Elaboration_Code restriction
10306 if R_Id = No_Elaboration_Code then
10308 -- Restriction is only recognized within a configuration
10309 -- pragma file, or within a unit of the main extended
10310 -- program. Note: the test for Main_Unit is needed to
10311 -- properly include the case of configuration pragma files.
10313 if not (Current_Sem_Unit = Main_Unit
10314 or else In_Extended_Main_Source_Unit (N))
10318 -- Don't allow in a subunit unless already specified in
10321 elsif Nkind (Parent (N)) = N_Compilation_Unit
10322 and then Nkind (Unit (Parent (N))) = N_Subunit
10323 and then not Restriction_Active (No_Elaboration_Code)
10326 ("invalid specification of ""No_Elaboration_Code""",
10329 ("\restriction cannot be specified in a subunit", N);
10331 ("\unless also specified in body or spec", N);
10334 -- If we accept a No_Elaboration_Code restriction, then it
10335 -- needs to be added to the configuration restriction set so
10336 -- that we get proper application to other units in the main
10337 -- extended source as required.
10340 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
10344 -- If this is a warning, then set the warning unless we already
10345 -- have a real restriction active (we never want a warning to
10346 -- override a real restriction).
10349 if not Restriction_Active (R_Id) then
10350 Set_Restriction (R_Id, N);
10351 Restriction_Warnings (R_Id) := True;
10354 -- If real restriction case, then set it and make sure that the
10355 -- restriction warning flag is off, since a real restriction
10356 -- always overrides a warning.
10359 Set_Restriction (R_Id, N);
10360 Restriction_Warnings (R_Id) := False;
10363 -- Check for obsolescent restrictions in Ada 2005 mode
10366 and then Ada_Version >= Ada_2005
10367 and then (R_Id = No_Asynchronous_Control
10369 R_Id = No_Unchecked_Deallocation
10371 R_Id = No_Unchecked_Conversion)
10373 Check_Restriction (No_Obsolescent_Features, N);
10376 -- A very special case that must be processed here: pragma
10377 -- Restrictions (No_Exceptions) turns off all run-time
10378 -- checking. This is a bit dubious in terms of the formal
10379 -- language definition, but it is what is intended by RM
10380 -- H.4(12). Restriction_Warnings never affects generated code
10381 -- so this is done only in the real restriction case.
10383 -- Atomic_Synchronization is not a real check, so it is not
10384 -- affected by this processing).
10386 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10387 -- run-time checks in CodePeer and GNATprove modes: we want to
10388 -- generate checks for analysis purposes, as set respectively
10389 -- by -gnatC and -gnatd.F
10392 and then not (CodePeer_Mode or GNATprove_Mode)
10393 and then R_Id = No_Exceptions
10395 for J in Scope_Suppress.Suppress'Range loop
10396 if J /= Atomic_Synchronization then
10397 Scope_Suppress.Suppress (J) := True;
10402 -- Case of No_Dependence => unit-name. Note that the parser
10403 -- already made the necessary entry in the No_Dependence table.
10405 elsif Id = Name_No_Dependence then
10406 if not OK_No_Dependence_Unit_Name (Expr) then
10410 -- Case of No_Specification_Of_Aspect => aspect-identifier
10412 elsif Id = Name_No_Specification_Of_Aspect then
10417 if Nkind (Expr) /= N_Identifier then
10420 A_Id := Get_Aspect_Id (Chars (Expr));
10423 if A_Id = No_Aspect then
10424 Error_Pragma_Arg ("invalid restriction name", Arg);
10426 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
10430 -- Case of No_Use_Of_Attribute => attribute-identifier
10432 elsif Id = Name_No_Use_Of_Attribute then
10433 if Nkind (Expr) /= N_Identifier
10434 or else not Is_Attribute_Name (Chars (Expr))
10436 Error_Msg_N ("unknown attribute name??", Expr);
10439 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
10442 -- Case of No_Use_Of_Entity => fully-qualified-name
10444 elsif Id = Name_No_Use_Of_Entity then
10446 -- Restriction is only recognized within a configuration
10447 -- pragma file, or within a unit of the main extended
10448 -- program. Note: the test for Main_Unit is needed to
10449 -- properly include the case of configuration pragma files.
10451 if Current_Sem_Unit = Main_Unit
10452 or else In_Extended_Main_Source_Unit (N)
10454 if not OK_No_Dependence_Unit_Name (Expr) then
10455 Error_Msg_N ("wrong form for entity name", Expr);
10457 Set_Restriction_No_Use_Of_Entity
10458 (Expr, Warn, No_Profile);
10462 -- Case of No_Use_Of_Pragma => pragma-identifier
10464 elsif Id = Name_No_Use_Of_Pragma then
10465 if Nkind (Expr) /= N_Identifier
10466 or else not Is_Pragma_Name (Chars (Expr))
10468 Error_Msg_N ("unknown pragma name??", Expr);
10470 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
10473 -- All other cases of restriction identifier present
10476 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
10477 Analyze_And_Resolve (Expr, Any_Integer);
10479 if R_Id not in All_Parameter_Restrictions then
10481 ("invalid restriction parameter identifier", Arg);
10483 elsif not Is_OK_Static_Expression (Expr) then
10484 Flag_Non_Static_Expr
10485 ("value must be static expression!", Expr);
10488 elsif not Is_Integer_Type (Etype (Expr))
10489 or else Expr_Value (Expr) < 0
10492 ("value must be non-negative integer", Arg);
10495 -- Restriction pragma is active
10497 Val := Expr_Value (Expr);
10499 if not UI_Is_In_Int_Range (Val) then
10501 ("pragma ignored, value too large??", Arg);
10504 -- Warning case. If the real restriction is active, then we
10505 -- ignore the request, since warning never overrides a real
10506 -- restriction. Otherwise we set the proper warning. Note that
10507 -- this circuit sets the warning again if it is already set,
10508 -- which is what we want, since the constant may have changed.
10511 if not Restriction_Active (R_Id) then
10513 (R_Id, N, Integer (UI_To_Int (Val)));
10514 Restriction_Warnings (R_Id) := True;
10517 -- Real restriction case, set restriction and make sure warning
10518 -- flag is off since real restriction always overrides warning.
10521 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
10522 Restriction_Warnings (R_Id) := False;
10528 end Process_Restrictions_Or_Restriction_Warnings;
10530 ---------------------------------
10531 -- Process_Suppress_Unsuppress --
10532 ---------------------------------
10534 -- Note: this procedure makes entries in the check suppress data
10535 -- structures managed by Sem. See spec of package Sem for full
10536 -- details on how we handle recording of check suppression.
10538 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
10543 In_Package_Spec : constant Boolean :=
10544 Is_Package_Or_Generic_Package (Current_Scope)
10545 and then not In_Package_Body (Current_Scope);
10547 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
10548 -- Used to suppress a single check on the given entity
10550 --------------------------------
10551 -- Suppress_Unsuppress_Echeck --
10552 --------------------------------
10554 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
10556 -- Check for error of trying to set atomic synchronization for
10557 -- a non-atomic variable.
10559 if C = Atomic_Synchronization
10560 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
10563 ("pragma & requires atomic type or variable",
10564 Pragma_Identifier (Original_Node (N)));
10567 Set_Checks_May_Be_Suppressed (E);
10569 if In_Package_Spec then
10570 Push_Global_Suppress_Stack_Entry
10573 Suppress => Suppress_Case);
10575 Push_Local_Suppress_Stack_Entry
10578 Suppress => Suppress_Case);
10581 -- If this is a first subtype, and the base type is distinct,
10582 -- then also set the suppress flags on the base type.
10584 if Is_First_Subtype (E) and then Etype (E) /= E then
10585 Suppress_Unsuppress_Echeck (Etype (E), C);
10587 end Suppress_Unsuppress_Echeck;
10589 -- Start of processing for Process_Suppress_Unsuppress
10592 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10593 -- on user code: we want to generate checks for analysis purposes, as
10594 -- set respectively by -gnatC and -gnatd.F
10596 if Comes_From_Source (N)
10597 and then (CodePeer_Mode or GNATprove_Mode)
10602 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10603 -- declarative part or a package spec (RM 11.5(5)).
10605 if not Is_Configuration_Pragma then
10606 Check_Is_In_Decl_Part_Or_Package_Spec;
10609 Check_At_Least_N_Arguments (1);
10610 Check_At_Most_N_Arguments (2);
10611 Check_No_Identifier (Arg1);
10612 Check_Arg_Is_Identifier (Arg1);
10614 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
10616 if C = No_Check_Id then
10618 ("argument of pragma% is not valid check name", Arg1);
10621 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10623 if C = Elaboration_Check and then SPARK_Mode = On then
10625 ("Suppress of Elaboration_Check ignored in SPARK??",
10626 "\elaboration checking rules are statically enforced "
10627 & "(SPARK RM 7.7)", Arg1);
10630 -- One-argument case
10632 if Arg_Count = 1 then
10634 -- Make an entry in the local scope suppress table. This is the
10635 -- table that directly shows the current value of the scope
10636 -- suppress check for any check id value.
10638 if C = All_Checks then
10640 -- For All_Checks, we set all specific predefined checks with
10641 -- the exception of Elaboration_Check, which is handled
10642 -- specially because of not wanting All_Checks to have the
10643 -- effect of deactivating static elaboration order processing.
10644 -- Atomic_Synchronization is also not affected, since this is
10645 -- not a real check.
10647 for J in Scope_Suppress.Suppress'Range loop
10648 if J /= Elaboration_Check
10650 J /= Atomic_Synchronization
10652 Scope_Suppress.Suppress (J) := Suppress_Case;
10656 -- If not All_Checks, and predefined check, then set appropriate
10657 -- scope entry. Note that we will set Elaboration_Check if this
10658 -- is explicitly specified. Atomic_Synchronization is allowed
10659 -- only if internally generated and entity is atomic.
10661 elsif C in Predefined_Check_Id
10662 and then (not Comes_From_Source (N)
10663 or else C /= Atomic_Synchronization)
10665 Scope_Suppress.Suppress (C) := Suppress_Case;
10668 -- Also make an entry in the Local_Entity_Suppress table
10670 Push_Local_Suppress_Stack_Entry
10673 Suppress => Suppress_Case);
10675 -- Case of two arguments present, where the check is suppressed for
10676 -- a specified entity (given as the second argument of the pragma)
10679 -- This is obsolescent in Ada 2005 mode
10681 if Ada_Version >= Ada_2005 then
10682 Check_Restriction (No_Obsolescent_Features, Arg2);
10685 Check_Optional_Identifier (Arg2, Name_On);
10686 E_Id := Get_Pragma_Arg (Arg2);
10689 if not Is_Entity_Name (E_Id) then
10691 ("second argument of pragma% must be entity name", Arg2);
10694 E := Entity (E_Id);
10700 -- A pragma that applies to a Ghost entity becomes Ghost for the
10701 -- purposes of legality checks and removal of ignored Ghost code.
10703 Mark_Ghost_Pragma (N, E);
10705 -- Enforce RM 11.5(7) which requires that for a pragma that
10706 -- appears within a package spec, the named entity must be
10707 -- within the package spec. We allow the package name itself
10708 -- to be mentioned since that makes sense, although it is not
10709 -- strictly allowed by 11.5(7).
10712 and then E /= Current_Scope
10713 and then Scope (E) /= Current_Scope
10716 ("entity in pragma% is not in package spec (RM 11.5(7))",
10720 -- Loop through homonyms. As noted below, in the case of a package
10721 -- spec, only homonyms within the package spec are considered.
10724 Suppress_Unsuppress_Echeck (E, C);
10726 if Is_Generic_Instance (E)
10727 and then Is_Subprogram (E)
10728 and then Present (Alias (E))
10730 Suppress_Unsuppress_Echeck (Alias (E), C);
10733 -- Move to next homonym if not aspect spec case
10735 exit when From_Aspect_Specification (N);
10739 -- If we are within a package specification, the pragma only
10740 -- applies to homonyms in the same scope.
10742 exit when In_Package_Spec
10743 and then Scope (E) /= Current_Scope;
10746 end Process_Suppress_Unsuppress;
10748 -------------------------------
10749 -- Record_Independence_Check --
10750 -------------------------------
10752 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
10753 pragma Unreferenced (N, E);
10755 -- For GCC back ends the validation is done a priori
10756 -- ??? This code is dead, might be useful in the future
10758 -- if not AAMP_On_Target then
10762 -- Independence_Checks.Append ((N, E));
10765 end Record_Independence_Check;
10771 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
10773 if Is_Imported (E) then
10775 ("cannot export entity& that was previously imported", Arg);
10777 elsif Present (Address_Clause (E))
10778 and then not Relaxed_RM_Semantics
10781 ("cannot export entity& that has an address clause", Arg);
10784 Set_Is_Exported (E);
10786 -- Generate a reference for entity explicitly, because the
10787 -- identifier may be overloaded and name resolution will not
10790 Generate_Reference (E, Arg);
10792 -- Deal with exporting non-library level entity
10794 if not Is_Library_Level_Entity (E) then
10796 -- Not allowed at all for subprograms
10798 if Is_Subprogram (E) then
10799 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
10801 -- Otherwise set public and statically allocated
10805 Set_Is_Statically_Allocated (E);
10807 -- Warn if the corresponding W flag is set
10809 if Warn_On_Export_Import
10811 -- Only do this for something that was in the source. Not
10812 -- clear if this can be False now (there used for sure to be
10813 -- cases on some systems where it was False), but anyway the
10814 -- test is harmless if not needed, so it is retained.
10816 and then Comes_From_Source (Arg)
10819 ("?x?& has been made static as a result of Export",
10822 ("\?x?this usage is non-standard and non-portable",
10828 if Warn_On_Export_Import and then Is_Type (E) then
10829 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
10832 if Warn_On_Export_Import and Inside_A_Generic then
10834 ("all instances of& will have the same external name?x?",
10839 ----------------------------------------------
10840 -- Set_Extended_Import_Export_External_Name --
10841 ----------------------------------------------
10843 procedure Set_Extended_Import_Export_External_Name
10844 (Internal_Ent : Entity_Id;
10845 Arg_External : Node_Id)
10847 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
10848 New_Name : Node_Id;
10851 if No (Arg_External) then
10855 Check_Arg_Is_External_Name (Arg_External);
10857 if Nkind (Arg_External) = N_String_Literal then
10858 if String_Length (Strval (Arg_External)) = 0 then
10861 New_Name := Adjust_External_Name_Case (Arg_External);
10864 elsif Nkind (Arg_External) = N_Identifier then
10865 New_Name := Get_Default_External_Name (Arg_External);
10867 -- Check_Arg_Is_External_Name should let through only identifiers and
10868 -- string literals or static string expressions (which are folded to
10869 -- string literals).
10872 raise Program_Error;
10875 -- If we already have an external name set (by a prior normal Import
10876 -- or Export pragma), then the external names must match
10878 if Present (Interface_Name (Internal_Ent)) then
10880 -- Ignore mismatching names in CodePeer mode, to support some
10881 -- old compilers which would export the same procedure under
10882 -- different names, e.g:
10884 -- pragma Export_Procedure (P, "a");
10885 -- pragma Export_Procedure (P, "b");
10887 if CodePeer_Mode then
10891 Check_Matching_Internal_Names : declare
10892 S1 : constant String_Id := Strval (Old_Name);
10893 S2 : constant String_Id := Strval (New_Name);
10895 procedure Mismatch;
10896 pragma No_Return (Mismatch);
10897 -- Called if names do not match
10903 procedure Mismatch is
10905 Error_Msg_Sloc := Sloc (Old_Name);
10907 ("external name does not match that given #",
10911 -- Start of processing for Check_Matching_Internal_Names
10914 if String_Length (S1) /= String_Length (S2) then
10918 for J in 1 .. String_Length (S1) loop
10919 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10924 end Check_Matching_Internal_Names;
10926 -- Otherwise set the given name
10929 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10930 Check_Duplicated_Export_Name (New_Name);
10932 end Set_Extended_Import_Export_External_Name;
10938 procedure Set_Imported (E : Entity_Id) is
10940 -- Error message if already imported or exported
10942 if Is_Exported (E) or else Is_Imported (E) then
10944 -- Error if being set Exported twice
10946 if Is_Exported (E) then
10947 Error_Msg_NE ("entity& was previously exported", N, E);
10949 -- Ignore error in CodePeer mode where we treat all imported
10950 -- subprograms as unknown.
10952 elsif CodePeer_Mode then
10955 -- OK if Import/Interface case
10957 elsif Import_Interface_Present (N) then
10960 -- Error if being set Imported twice
10963 Error_Msg_NE ("entity& was previously imported", N, E);
10966 Error_Msg_Name_1 := Pname;
10968 ("\(pragma% applies to all previous entities)", N);
10970 Error_Msg_Sloc := Sloc (E);
10971 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10973 -- Here if not previously imported or exported, OK to import
10976 Set_Is_Imported (E);
10978 -- For subprogram, set Import_Pragma field
10980 if Is_Subprogram (E) then
10981 Set_Import_Pragma (E, N);
10984 -- If the entity is an object that is not at the library level,
10985 -- then it is statically allocated. We do not worry about objects
10986 -- with address clauses in this context since they are not really
10987 -- imported in the linker sense.
10990 and then not Is_Library_Level_Entity (E)
10991 and then No (Address_Clause (E))
10993 Set_Is_Statically_Allocated (E);
11000 -------------------------
11001 -- Set_Mechanism_Value --
11002 -------------------------
11004 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11005 -- analyzed, since it is semantic nonsense), so we get it in the exact
11006 -- form created by the parser.
11008 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
11009 procedure Bad_Mechanism;
11010 pragma No_Return (Bad_Mechanism);
11011 -- Signal bad mechanism name
11013 -------------------
11014 -- Bad_Mechanism --
11015 -------------------
11017 procedure Bad_Mechanism is
11019 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
11022 -- Start of processing for Set_Mechanism_Value
11025 if Mechanism (Ent) /= Default_Mechanism then
11027 ("mechanism for & has already been set", Mech_Name, Ent);
11030 -- MECHANISM_NAME ::= value | reference
11032 if Nkind (Mech_Name) = N_Identifier then
11033 if Chars (Mech_Name) = Name_Value then
11034 Set_Mechanism (Ent, By_Copy);
11037 elsif Chars (Mech_Name) = Name_Reference then
11038 Set_Mechanism (Ent, By_Reference);
11041 elsif Chars (Mech_Name) = Name_Copy then
11043 ("bad mechanism name, Value assumed", Mech_Name);
11052 end Set_Mechanism_Value;
11054 --------------------------
11055 -- Set_Rational_Profile --
11056 --------------------------
11058 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11059 -- extension to the semantics of renaming declarations.
11061 procedure Set_Rational_Profile is
11063 Implicit_Packing := True;
11064 Overriding_Renamings := True;
11065 Use_VADS_Size := True;
11066 end Set_Rational_Profile;
11068 ---------------------------
11069 -- Set_Ravenscar_Profile --
11070 ---------------------------
11072 -- The tasks to be done here are
11074 -- Set required policies
11076 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11077 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11078 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11079 -- (For GNAT_Ravenscar_EDF profile)
11080 -- pragma Locking_Policy (Ceiling_Locking)
11082 -- Set Detect_Blocking mode
11084 -- Set required restrictions (see System.Rident for detailed list)
11086 -- Set the No_Dependence rules
11087 -- No_Dependence => Ada.Asynchronous_Task_Control
11088 -- No_Dependence => Ada.Calendar
11089 -- No_Dependence => Ada.Execution_Time.Group_Budget
11090 -- No_Dependence => Ada.Execution_Time.Timers
11091 -- No_Dependence => Ada.Task_Attributes
11092 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11094 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
11095 procedure Set_Error_Msg_To_Profile_Name;
11096 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11099 -----------------------------------
11100 -- Set_Error_Msg_To_Profile_Name --
11101 -----------------------------------
11103 procedure Set_Error_Msg_To_Profile_Name is
11104 Prof_Nam : constant Node_Id :=
11106 (First (Pragma_Argument_Associations (N)));
11109 Get_Name_String (Chars (Prof_Nam));
11110 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
11111 Error_Msg_Strlen := Name_Len;
11112 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
11113 end Set_Error_Msg_To_Profile_Name;
11122 Profile_Dispatching_Policy : Character;
11124 -- Start of processing for Set_Ravenscar_Profile
11127 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11129 if Profile = GNAT_Ravenscar_EDF then
11130 Profile_Dispatching_Policy := 'E';
11132 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11135 Profile_Dispatching_Policy := 'F';
11138 if Task_Dispatching_Policy /= ' '
11139 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy
11141 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11142 Set_Error_Msg_To_Profile_Name;
11143 Error_Pragma ("Profile (~) incompatible with policy#");
11145 -- Set the FIFO_Within_Priorities policy, but always preserve
11146 -- System_Location since we like the error message with the run time
11150 Task_Dispatching_Policy := Profile_Dispatching_Policy;
11152 if Task_Dispatching_Policy_Sloc /= System_Location then
11153 Task_Dispatching_Policy_Sloc := Loc;
11157 -- pragma Locking_Policy (Ceiling_Locking)
11159 if Locking_Policy /= ' '
11160 and then Locking_Policy /= 'C'
11162 Error_Msg_Sloc := Locking_Policy_Sloc;
11163 Set_Error_Msg_To_Profile_Name;
11164 Error_Pragma ("Profile (~) incompatible with policy#");
11166 -- Set the Ceiling_Locking policy, but preserve System_Location since
11167 -- we like the error message with the run time name.
11170 Locking_Policy := 'C';
11172 if Locking_Policy_Sloc /= System_Location then
11173 Locking_Policy_Sloc := Loc;
11177 -- pragma Detect_Blocking
11179 Detect_Blocking := True;
11181 -- Set the corresponding restrictions
11183 Set_Profile_Restrictions
11184 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
11186 -- Set the No_Dependence restrictions
11188 -- The following No_Dependence restrictions:
11189 -- No_Dependence => Ada.Asynchronous_Task_Control
11190 -- No_Dependence => Ada.Calendar
11191 -- No_Dependence => Ada.Task_Attributes
11192 -- are already set by previous call to Set_Profile_Restrictions.
11194 -- Set the following restrictions which were added to Ada 2005:
11195 -- No_Dependence => Ada.Execution_Time.Group_Budget
11196 -- No_Dependence => Ada.Execution_Time.Timers
11198 if Ada_Version >= Ada_2005 then
11199 Pref_Id := Make_Identifier (Loc, Name_Find ("ada"));
11200 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time"));
11203 Make_Selected_Component
11206 Selector_Name => Sel_Id);
11208 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets"));
11211 Make_Selected_Component
11214 Selector_Name => Sel_Id);
11216 Set_Restriction_No_Dependence
11218 Warn => Treat_Restrictions_As_Warnings,
11219 Profile => Ravenscar);
11221 Sel_Id := Make_Identifier (Loc, Name_Find ("timers"));
11224 Make_Selected_Component
11227 Selector_Name => Sel_Id);
11229 Set_Restriction_No_Dependence
11231 Warn => Treat_Restrictions_As_Warnings,
11232 Profile => Ravenscar);
11235 -- Set the following restriction which was added to Ada 2012 (see
11237 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11239 if Ada_Version >= Ada_2012 then
11240 Pref_Id := Make_Identifier (Loc, Name_Find ("system"));
11241 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors"));
11244 Make_Selected_Component
11247 Selector_Name => Sel_Id);
11249 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains"));
11252 Make_Selected_Component
11255 Selector_Name => Sel_Id);
11257 Set_Restriction_No_Dependence
11259 Warn => Treat_Restrictions_As_Warnings,
11260 Profile => Ravenscar);
11262 end Set_Ravenscar_Profile;
11264 -----------------------------------
11265 -- Validate_Acc_Condition_Clause --
11266 -----------------------------------
11268 procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is
11270 Analyze_And_Resolve (Clause);
11272 if not Is_Boolean_Type (Etype (Clause)) then
11273 Error_Pragma ("expected a boolean");
11275 end Validate_Acc_Condition_Clause;
11277 ------------------------------
11278 -- Validate_Acc_Data_Clause --
11279 ------------------------------
11281 procedure Validate_Acc_Data_Clause (Clause : Node_Id) is
11285 Expr := Acc_First (Clause);
11286 while Present (Expr) loop
11287 if Nkind (Expr) /= N_Identifier then
11288 Error_Pragma ("expected an identifer");
11291 Analyze_And_Resolve (Expr);
11293 Expr := Acc_Next (Expr);
11295 end Validate_Acc_Data_Clause;
11297 ----------------------------------
11298 -- Validate_Acc_Int_Expr_Clause --
11299 ----------------------------------
11301 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is
11303 Analyze_And_Resolve (Clause);
11305 if not Is_Integer_Type (Etype (Clause)) then
11306 Error_Pragma_Arg ("expected an integer", Clause);
11308 end Validate_Acc_Int_Expr_Clause;
11310 ---------------------------------------
11311 -- Validate_Acc_Int_Expr_List_Clause --
11312 ---------------------------------------
11314 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is
11318 Expr := Acc_First (Clause);
11319 while Present (Expr) loop
11320 Analyze_And_Resolve (Expr);
11322 if not Is_Integer_Type (Etype (Expr)) then
11323 Error_Pragma ("expected an integer");
11326 Expr := Acc_Next (Expr);
11328 end Validate_Acc_Int_Expr_List_Clause;
11330 --------------------------------
11331 -- Validate_Acc_Loop_Collapse --
11332 --------------------------------
11334 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is
11336 Par_Loop : Node_Id;
11340 -- Make sure the argument is a positive integer
11342 Analyze_And_Resolve (Clause);
11344 Count := Static_Integer (Clause);
11345 if Count = No_Uint or else Count < 1 then
11346 Error_Pragma_Arg ("expected a positive integer", Clause);
11349 -- Then, make sure we have at least Count-1 tightly-nested loops
11350 -- (i.e. loops with no statements in between).
11352 Par_Loop := Parent (Parent (Parent (Clause)));
11353 Stmt := First (Statements (Par_Loop));
11355 -- Skip first pragmas in the parent loop
11357 while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop
11361 if not Present (Next (Stmt)) then
11362 while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop
11363 Stmt := First (Statements (Stmt));
11364 exit when Present (Next (Stmt));
11366 Count := Count - 1;
11372 ("Collapse argument too high or loops not tightly nested",
11375 end Validate_Acc_Loop_Collapse;
11377 ----------------------------
11378 -- Validate_Acc_Loop_Gang --
11379 ----------------------------
11381 procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is
11383 Error_Pragma_Arg ("Loop_Gang not implemented", Clause);
11384 end Validate_Acc_Loop_Gang;
11386 ------------------------------
11387 -- Validate_Acc_Loop_Vector --
11388 ------------------------------
11390 procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is
11392 Error_Pragma_Arg ("Loop_Vector not implemented", Clause);
11393 end Validate_Acc_Loop_Vector;
11395 -------------------------------
11396 -- Validate_Acc_Loop_Worker --
11397 -------------------------------
11399 procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is
11401 Error_Pragma_Arg ("Loop_Worker not implemented", Clause);
11402 end Validate_Acc_Loop_Worker;
11404 ---------------------------------
11405 -- Validate_Acc_Name_Reduction --
11406 ---------------------------------
11408 procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is
11410 -- ??? On top of the following operations, the OpenAcc spec adds the
11411 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11412 -- ".neqv" for Fortran. Can we, should we and how do we support them
11415 type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op);
11417 function To_Reduction_Op (Op : String) return Reduction_Op;
11418 -- Convert operator Op described by a String into its corresponding
11419 -- enumeration value.
11421 ---------------------
11422 -- To_Reduction_Op --
11423 ---------------------
11425 function To_Reduction_Op (Op : String) return Reduction_Op is
11430 elsif Op = "*" then
11433 elsif Op = "max" then
11436 elsif Op = "min" then
11439 elsif Op = "and" then
11442 elsif Op = "or" then
11446 Error_Pragma ("unsuported reduction operation");
11448 end To_Reduction_Op;
11452 Seen : constant Elist_Id := New_Elmt_List;
11455 Reduc_Op : Node_Id;
11456 Reduc_Var : Node_Id;
11458 -- Start of processing for Validate_Acc_Name_Reduction
11461 -- Reduction operations appear in the following form:
11462 -- ("+" => (a, b), "*" => c)
11464 Expr := First (Component_Associations (Clause));
11465 while Present (Expr) loop
11466 Reduc_Op := First (Choices (Expr));
11467 String_To_Name_Buffer (Strval (Reduc_Op));
11469 case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is
11475 Reduc_Var := Acc_First (Expression (Expr));
11476 while Present (Reduc_Var) loop
11477 Analyze_And_Resolve (Reduc_Var);
11479 if Contains (Seen, Entity (Reduc_Var)) then
11480 Error_Pragma ("variable used in multiple reductions");
11483 if Nkind (Reduc_Var) /= N_Identifier
11484 or not Is_Numeric_Type (Etype (Reduc_Var))
11487 ("expected an identifier for a Numeric");
11490 Append_Elmt (Entity (Reduc_Var), Seen);
11493 Reduc_Var := Acc_Next (Reduc_Var);
11499 Reduc_Var := Acc_First (Expression (Expr));
11500 while Present (Reduc_Var) loop
11501 Analyze_And_Resolve (Reduc_Var);
11503 if Contains (Seen, Entity (Reduc_Var)) then
11504 Error_Pragma ("variable used in multiple reductions");
11507 if Nkind (Reduc_Var) /= N_Identifier
11508 or not Is_Boolean_Type (Etype (Reduc_Var))
11511 ("expected a variable of type boolean");
11514 Append_Elmt (Entity (Reduc_Var), Seen);
11517 Reduc_Var := Acc_Next (Reduc_Var);
11523 end Validate_Acc_Name_Reduction;
11525 -----------------------------------
11526 -- Validate_Acc_Size_Expressions --
11527 -----------------------------------
11529 procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is
11530 function Validate_Size_Expr (Expr : Node_Id) return Boolean;
11531 -- A size expr is either an integer expression or "*"
11533 ------------------------
11534 -- Validate_Size_Expr --
11535 ------------------------
11537 function Validate_Size_Expr (Expr : Node_Id) return Boolean is
11539 if Nkind (Expr) = N_Operator_Symbol then
11540 return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*');
11543 Analyze_And_Resolve (Expr);
11545 return Is_Integer_Type (Etype (Expr));
11546 end Validate_Size_Expr;
11552 -- Start of processing for Validate_Acc_Size_Expressions
11555 Expr := Acc_First (Clause);
11556 while Present (Expr) loop
11557 if not Validate_Size_Expr (Expr) then
11559 ("Size expressions should be either integers or '*'");
11562 Expr := Acc_Next (Expr);
11564 end Validate_Acc_Size_Expressions;
11566 -- Start of processing for Analyze_Pragma
11569 -- The following code is a defense against recursion. Not clear that
11570 -- this can happen legitimately, but perhaps some error situations can
11571 -- cause it, and we did see this recursion during testing.
11573 if Analyzed (N) then
11579 Check_Restriction_No_Use_Of_Pragma (N);
11581 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11582 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11584 if Should_Ignore_Pragma_Sem (N)
11585 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
11586 and then Ignore_Rep_Clauses)
11591 -- Deal with unrecognized pragma
11593 if not Is_Pragma_Name (Pname) then
11594 if Warn_On_Unrecognized_Pragma then
11595 Error_Msg_Name_1 := Pname;
11596 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
11598 for PN in First_Pragma_Name .. Last_Pragma_Name loop
11599 if Is_Bad_Spelling_Of (Pname, PN) then
11600 Error_Msg_Name_1 := PN;
11601 Error_Msg_N -- CODEFIX
11602 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
11611 -- Here to start processing for recognized pragma
11613 Pname := Original_Aspect_Pragma_Name (N);
11615 -- Capture setting of Opt.Uneval_Old
11617 case Opt.Uneval_Old is
11619 Set_Uneval_Old_Accept (N);
11625 Set_Uneval_Old_Warn (N);
11628 raise Program_Error;
11631 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11632 -- is already set, indicating that we have already checked the policy
11633 -- at the right point. This happens for example in the case of a pragma
11634 -- that is derived from an Aspect.
11636 if Is_Ignored (N) or else Is_Checked (N) then
11639 -- For a pragma that is a rewriting of another pragma, copy the
11640 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11642 elsif Is_Rewrite_Substitution (N)
11643 and then Nkind (Original_Node (N)) = N_Pragma
11645 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
11646 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
11648 -- Otherwise query the applicable policy at this point
11651 Check_Applicable_Policy (N);
11653 -- If pragma is disabled, rewrite as NULL and skip analysis
11655 if Is_Disabled (N) then
11656 Rewrite (N, Make_Null_Statement (Loc));
11662 -- Preset arguments
11670 if Present (Pragma_Argument_Associations (N)) then
11671 Arg_Count := List_Length (Pragma_Argument_Associations (N));
11672 Arg1 := First (Pragma_Argument_Associations (N));
11674 if Present (Arg1) then
11675 Arg2 := Next (Arg1);
11677 if Present (Arg2) then
11678 Arg3 := Next (Arg2);
11680 if Present (Arg3) then
11681 Arg4 := Next (Arg3);
11687 -- An enumeration type defines the pragmas that are supported by the
11688 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11689 -- into the corresponding enumeration value for the following case.
11697 -- pragma Abort_Defer;
11699 when Pragma_Abort_Defer =>
11701 Check_Arg_Count (0);
11703 -- The only required semantic processing is to check the
11704 -- placement. This pragma must appear at the start of the
11705 -- statement sequence of a handled sequence of statements.
11707 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
11708 or else N /= First (Statements (Parent (N)))
11713 --------------------
11714 -- Abstract_State --
11715 --------------------
11717 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11719 -- ABSTRACT_STATE_LIST ::=
11721 -- | STATE_NAME_WITH_OPTIONS
11722 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11724 -- STATE_NAME_WITH_OPTIONS ::=
11726 -- | (STATE_NAME with OPTION_LIST)
11728 -- OPTION_LIST ::= OPTION {, OPTION}
11732 -- | NAME_VALUE_OPTION
11734 -- SIMPLE_OPTION ::= Ghost | Synchronous
11736 -- NAME_VALUE_OPTION ::=
11737 -- Part_Of => ABSTRACT_STATE
11738 -- | External [=> EXTERNAL_PROPERTY_LIST]
11740 -- EXTERNAL_PROPERTY_LIST ::=
11741 -- EXTERNAL_PROPERTY
11742 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11744 -- EXTERNAL_PROPERTY ::=
11745 -- Async_Readers [=> boolean_EXPRESSION]
11746 -- | Async_Writers [=> boolean_EXPRESSION]
11747 -- | Effective_Reads [=> boolean_EXPRESSION]
11748 -- | Effective_Writes [=> boolean_EXPRESSION]
11749 -- others => boolean_EXPRESSION
11751 -- STATE_NAME ::= defining_identifier
11753 -- ABSTRACT_STATE ::= name
11755 -- Characteristics:
11757 -- * Analysis - The annotation is fully analyzed immediately upon
11758 -- elaboration as it cannot forward reference entities.
11760 -- * Expansion - None.
11762 -- * Template - The annotation utilizes the generic template of the
11763 -- related package declaration.
11765 -- * Globals - The annotation cannot reference global entities.
11767 -- * Instance - The annotation is instantiated automatically when
11768 -- the related generic package is instantiated.
11770 when Pragma_Abstract_State => Abstract_State : declare
11771 Missing_Parentheses : Boolean := False;
11772 -- Flag set when a state declaration with options is not properly
11775 -- Flags used to verify the consistency of states
11777 Non_Null_Seen : Boolean := False;
11778 Null_Seen : Boolean := False;
11780 procedure Analyze_Abstract_State
11782 Pack_Id : Entity_Id);
11783 -- Verify the legality of a single state declaration. Create and
11784 -- decorate a state abstraction entity and introduce it into the
11785 -- visibility chain. Pack_Id denotes the entity or the related
11786 -- package where pragma Abstract_State appears.
11788 procedure Malformed_State_Error (State : Node_Id);
11789 -- Emit an error concerning the illegal declaration of abstract
11790 -- state State. This routine diagnoses syntax errors that lead to
11791 -- a different parse tree. The error is issued regardless of the
11792 -- SPARK mode in effect.
11794 ----------------------------
11795 -- Analyze_Abstract_State --
11796 ----------------------------
11798 procedure Analyze_Abstract_State
11800 Pack_Id : Entity_Id)
11802 -- Flags used to verify the consistency of options
11804 AR_Seen : Boolean := False;
11805 AW_Seen : Boolean := False;
11806 ER_Seen : Boolean := False;
11807 EW_Seen : Boolean := False;
11808 External_Seen : Boolean := False;
11809 Ghost_Seen : Boolean := False;
11810 Others_Seen : Boolean := False;
11811 Part_Of_Seen : Boolean := False;
11812 Synchronous_Seen : Boolean := False;
11814 -- Flags used to store the static value of all external states'
11817 AR_Val : Boolean := False;
11818 AW_Val : Boolean := False;
11819 ER_Val : Boolean := False;
11820 EW_Val : Boolean := False;
11822 State_Id : Entity_Id := Empty;
11823 -- The entity to be generated for the current state declaration
11825 procedure Analyze_External_Option (Opt : Node_Id);
11826 -- Verify the legality of option External
11828 procedure Analyze_External_Property
11830 Expr : Node_Id := Empty);
11831 -- Verify the legailty of a single external property. Prop
11832 -- denotes the external property. Expr is the expression used
11833 -- to set the property.
11835 procedure Analyze_Part_Of_Option (Opt : Node_Id);
11836 -- Verify the legality of option Part_Of
11838 procedure Check_Duplicate_Option
11840 Status : in out Boolean);
11841 -- Flag Status denotes whether a particular option has been
11842 -- seen while processing a state. This routine verifies that
11843 -- Opt is not a duplicate option and sets the flag Status
11844 -- (SPARK RM 7.1.4(1)).
11846 procedure Check_Duplicate_Property
11848 Status : in out Boolean);
11849 -- Flag Status denotes whether a particular property has been
11850 -- seen while processing option External. This routine verifies
11851 -- that Prop is not a duplicate property and sets flag Status.
11852 -- Opt is not a duplicate property and sets the flag Status.
11853 -- (SPARK RM 7.1.4(2))
11855 procedure Check_Ghost_Synchronous;
11856 -- Ensure that the abstract state is not subject to both Ghost
11857 -- and Synchronous simple options. Emit an error if this is the
11860 procedure Create_Abstract_State
11864 Is_Null : Boolean);
11865 -- Generate an abstract state entity with name Nam and enter it
11866 -- into visibility. Decl is the "declaration" of the state as
11867 -- it appears in pragma Abstract_State. Loc is the location of
11868 -- the related state "declaration". Flag Is_Null should be set
11869 -- when the associated Abstract_State pragma defines a null
11872 -----------------------------
11873 -- Analyze_External_Option --
11874 -----------------------------
11876 procedure Analyze_External_Option (Opt : Node_Id) is
11877 Errors : constant Nat := Serious_Errors_Detected;
11879 Props : Node_Id := Empty;
11882 if Nkind (Opt) = N_Component_Association then
11883 Props := Expression (Opt);
11886 -- External state with properties
11888 if Present (Props) then
11890 -- Multiple properties appear as an aggregate
11892 if Nkind (Props) = N_Aggregate then
11894 -- Simple property form
11896 Prop := First (Expressions (Props));
11897 while Present (Prop) loop
11898 Analyze_External_Property (Prop);
11902 -- Property with expression form
11904 Prop := First (Component_Associations (Props));
11905 while Present (Prop) loop
11906 Analyze_External_Property
11907 (Prop => First (Choices (Prop)),
11908 Expr => Expression (Prop));
11916 Analyze_External_Property (Props);
11919 -- An external state defined without any properties defaults
11920 -- all properties to True.
11929 -- Once all external properties have been processed, verify
11930 -- their mutual interaction. Do not perform the check when
11931 -- at least one of the properties is illegal as this will
11932 -- produce a bogus error.
11934 if Errors = Serious_Errors_Detected then
11935 Check_External_Properties
11936 (State, AR_Val, AW_Val, ER_Val, EW_Val);
11938 end Analyze_External_Option;
11940 -------------------------------
11941 -- Analyze_External_Property --
11942 -------------------------------
11944 procedure Analyze_External_Property
11946 Expr : Node_Id := Empty)
11948 Expr_Val : Boolean;
11951 -- Check the placement of "others" (if available)
11953 if Nkind (Prop) = N_Others_Choice then
11954 if Others_Seen then
11956 ("only one others choice allowed in option External",
11959 Others_Seen := True;
11962 elsif Others_Seen then
11964 ("others must be the last property in option External",
11967 -- The only remaining legal options are the four predefined
11968 -- external properties.
11970 elsif Nkind (Prop) = N_Identifier
11971 and then Nam_In (Chars (Prop), Name_Async_Readers,
11972 Name_Async_Writers,
11973 Name_Effective_Reads,
11974 Name_Effective_Writes)
11978 -- Otherwise the construct is not a valid property
11981 SPARK_Msg_N ("invalid external state property", Prop);
11985 -- Ensure that the expression of the external state property
11986 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11988 if Present (Expr) then
11989 Analyze_And_Resolve (Expr, Standard_Boolean);
11991 if Is_OK_Static_Expression (Expr) then
11992 Expr_Val := Is_True (Expr_Value (Expr));
11995 ("expression of external state property must be "
12000 -- The lack of expression defaults the property to True
12006 -- Named properties
12008 if Nkind (Prop) = N_Identifier then
12009 if Chars (Prop) = Name_Async_Readers then
12010 Check_Duplicate_Property (Prop, AR_Seen);
12011 AR_Val := Expr_Val;
12013 elsif Chars (Prop) = Name_Async_Writers then
12014 Check_Duplicate_Property (Prop, AW_Seen);
12015 AW_Val := Expr_Val;
12017 elsif Chars (Prop) = Name_Effective_Reads then
12018 Check_Duplicate_Property (Prop, ER_Seen);
12019 ER_Val := Expr_Val;
12022 Check_Duplicate_Property (Prop, EW_Seen);
12023 EW_Val := Expr_Val;
12026 -- The handling of property "others" must take into account
12027 -- all other named properties that have been encountered so
12028 -- far. Only those that have not been seen are affected by
12032 if not AR_Seen then
12033 AR_Val := Expr_Val;
12036 if not AW_Seen then
12037 AW_Val := Expr_Val;
12040 if not ER_Seen then
12041 ER_Val := Expr_Val;
12044 if not EW_Seen then
12045 EW_Val := Expr_Val;
12048 end Analyze_External_Property;
12050 ----------------------------
12051 -- Analyze_Part_Of_Option --
12052 ----------------------------
12054 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
12055 Encap : constant Node_Id := Expression (Opt);
12056 Constits : Elist_Id;
12057 Encap_Id : Entity_Id;
12061 Check_Duplicate_Option (Opt, Part_Of_Seen);
12064 (Indic => First (Choices (Opt)),
12065 Item_Id => State_Id,
12067 Encap_Id => Encap_Id,
12070 -- The Part_Of indicator transforms the abstract state into
12071 -- a constituent of the encapsulating state or single
12072 -- concurrent type.
12075 pragma Assert (Present (Encap_Id));
12076 Constits := Part_Of_Constituents (Encap_Id);
12078 if No (Constits) then
12079 Constits := New_Elmt_List;
12080 Set_Part_Of_Constituents (Encap_Id, Constits);
12083 Append_Elmt (State_Id, Constits);
12084 Set_Encapsulating_State (State_Id, Encap_Id);
12086 end Analyze_Part_Of_Option;
12088 ----------------------------
12089 -- Check_Duplicate_Option --
12090 ----------------------------
12092 procedure Check_Duplicate_Option
12094 Status : in out Boolean)
12098 SPARK_Msg_N ("duplicate state option", Opt);
12102 end Check_Duplicate_Option;
12104 ------------------------------
12105 -- Check_Duplicate_Property --
12106 ------------------------------
12108 procedure Check_Duplicate_Property
12110 Status : in out Boolean)
12114 SPARK_Msg_N ("duplicate external property", Prop);
12118 end Check_Duplicate_Property;
12120 -----------------------------
12121 -- Check_Ghost_Synchronous --
12122 -----------------------------
12124 procedure Check_Ghost_Synchronous is
12126 -- A synchronized abstract state cannot be Ghost and vice
12127 -- versa (SPARK RM 6.9(19)).
12129 if Ghost_Seen and Synchronous_Seen then
12130 SPARK_Msg_N ("synchronized state cannot be ghost", State);
12132 end Check_Ghost_Synchronous;
12134 ---------------------------
12135 -- Create_Abstract_State --
12136 ---------------------------
12138 procedure Create_Abstract_State
12145 -- The abstract state may be semi-declared when the related
12146 -- package was withed through a limited with clause. In that
12147 -- case reuse the entity to fully declare the state.
12149 if Present (Decl) and then Present (Entity (Decl)) then
12150 State_Id := Entity (Decl);
12152 -- Otherwise the elaboration of pragma Abstract_State
12153 -- declares the state.
12156 State_Id := Make_Defining_Identifier (Loc, Nam);
12158 if Present (Decl) then
12159 Set_Entity (Decl, State_Id);
12163 -- Null states never come from source
12165 Set_Comes_From_Source (State_Id, not Is_Null);
12166 Set_Parent (State_Id, State);
12167 Set_Ekind (State_Id, E_Abstract_State);
12168 Set_Etype (State_Id, Standard_Void_Type);
12169 Set_Encapsulating_State (State_Id, Empty);
12171 -- Set the SPARK mode from the current context
12173 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma);
12174 Set_SPARK_Pragma_Inherited (State_Id);
12176 -- An abstract state declared within a Ghost region becomes
12177 -- Ghost (SPARK RM 6.9(2)).
12179 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
12180 Set_Is_Ghost_Entity (State_Id);
12183 -- Establish a link between the state declaration and the
12184 -- abstract state entity. Note that a null state remains as
12185 -- N_Null and does not carry any linkages.
12187 if not Is_Null then
12188 if Present (Decl) then
12189 Set_Entity (Decl, State_Id);
12190 Set_Etype (Decl, Standard_Void_Type);
12193 -- Every non-null state must be defined, nameable and
12196 Push_Scope (Pack_Id);
12197 Generate_Definition (State_Id);
12198 Enter_Name (State_Id);
12201 end Create_Abstract_State;
12208 -- Start of processing for Analyze_Abstract_State
12211 -- A package with a null abstract state is not allowed to
12212 -- declare additional states.
12216 ("package & has null abstract state", State, Pack_Id);
12218 -- Null states appear as internally generated entities
12220 elsif Nkind (State) = N_Null then
12221 Create_Abstract_State
12222 (Nam => New_Internal_Name ('S'),
12224 Loc => Sloc (State),
12228 -- Catch a case where a null state appears in a list of
12229 -- non-null states.
12231 if Non_Null_Seen then
12233 ("package & has non-null abstract state",
12237 -- Simple state declaration
12239 elsif Nkind (State) = N_Identifier then
12240 Create_Abstract_State
12241 (Nam => Chars (State),
12243 Loc => Sloc (State),
12245 Non_Null_Seen := True;
12247 -- State declaration with various options. This construct
12248 -- appears as an extension aggregate in the tree.
12250 elsif Nkind (State) = N_Extension_Aggregate then
12251 if Nkind (Ancestor_Part (State)) = N_Identifier then
12252 Create_Abstract_State
12253 (Nam => Chars (Ancestor_Part (State)),
12254 Decl => Ancestor_Part (State),
12255 Loc => Sloc (Ancestor_Part (State)),
12257 Non_Null_Seen := True;
12260 ("state name must be an identifier",
12261 Ancestor_Part (State));
12264 -- Options External, Ghost and Synchronous appear as
12267 Opt := First (Expressions (State));
12268 while Present (Opt) loop
12269 if Nkind (Opt) = N_Identifier then
12273 if Chars (Opt) = Name_External then
12274 Check_Duplicate_Option (Opt, External_Seen);
12275 Analyze_External_Option (Opt);
12279 elsif Chars (Opt) = Name_Ghost then
12280 Check_Duplicate_Option (Opt, Ghost_Seen);
12281 Check_Ghost_Synchronous;
12283 if Present (State_Id) then
12284 Set_Is_Ghost_Entity (State_Id);
12289 elsif Chars (Opt) = Name_Synchronous then
12290 Check_Duplicate_Option (Opt, Synchronous_Seen);
12291 Check_Ghost_Synchronous;
12293 -- Option Part_Of without an encapsulating state is
12294 -- illegal (SPARK RM 7.1.4(8)).
12296 elsif Chars (Opt) = Name_Part_Of then
12298 ("indicator Part_Of must denote abstract state, "
12299 & "single protected type or single task type",
12302 -- Do not emit an error message when a previous state
12303 -- declaration with options was not parenthesized as
12304 -- the option is actually another state declaration.
12306 -- with Abstract_State
12307 -- (State_1 with ..., -- missing parentheses
12308 -- (State_2 with ...),
12309 -- State_3) -- ok state declaration
12311 elsif Missing_Parentheses then
12314 -- Otherwise the option is not allowed. Note that it
12315 -- is not possible to distinguish between an option
12316 -- and a state declaration when a previous state with
12317 -- options not properly parentheses.
12319 -- with Abstract_State
12320 -- (State_1 with ..., -- missing parentheses
12321 -- State_2); -- could be an option
12325 ("simple option not allowed in state declaration",
12329 -- Catch a case where missing parentheses around a state
12330 -- declaration with options cause a subsequent state
12331 -- declaration with options to be treated as an option.
12333 -- with Abstract_State
12334 -- (State_1 with ..., -- missing parentheses
12335 -- (State_2 with ...))
12337 elsif Nkind (Opt) = N_Extension_Aggregate then
12338 Missing_Parentheses := True;
12340 ("state declaration must be parenthesized",
12341 Ancestor_Part (State));
12343 -- Otherwise the option is malformed
12346 SPARK_Msg_N ("malformed option", Opt);
12352 -- Options External and Part_Of appear as component
12355 Opt := First (Component_Associations (State));
12356 while Present (Opt) loop
12357 Opt_Nam := First (Choices (Opt));
12359 if Nkind (Opt_Nam) = N_Identifier then
12360 if Chars (Opt_Nam) = Name_External then
12361 Analyze_External_Option (Opt);
12363 elsif Chars (Opt_Nam) = Name_Part_Of then
12364 Analyze_Part_Of_Option (Opt);
12367 SPARK_Msg_N ("invalid state option", Opt);
12370 SPARK_Msg_N ("invalid state option", Opt);
12376 -- Any other attempt to declare a state is illegal
12379 Malformed_State_Error (State);
12383 -- Guard against a junk state. In such cases no entity is
12384 -- generated and the subsequent checks cannot be applied.
12386 if Present (State_Id) then
12388 -- Verify whether the state does not introduce an illegal
12389 -- hidden state within a package subject to a null abstract
12392 Check_No_Hidden_State (State_Id);
12394 -- Check whether the lack of option Part_Of agrees with the
12395 -- placement of the abstract state with respect to the state
12398 if not Part_Of_Seen then
12399 Check_Missing_Part_Of (State_Id);
12402 -- Associate the state with its related package
12404 if No (Abstract_States (Pack_Id)) then
12405 Set_Abstract_States (Pack_Id, New_Elmt_List);
12408 Append_Elmt (State_Id, Abstract_States (Pack_Id));
12410 end Analyze_Abstract_State;
12412 ---------------------------
12413 -- Malformed_State_Error --
12414 ---------------------------
12416 procedure Malformed_State_Error (State : Node_Id) is
12418 Error_Msg_N ("malformed abstract state declaration", State);
12420 -- An abstract state with a simple option is being declared
12421 -- with "=>" rather than the legal "with". The state appears
12422 -- as a component association.
12424 if Nkind (State) = N_Component_Association then
12425 Error_Msg_N ("\use WITH to specify simple option", State);
12427 end Malformed_State_Error;
12431 Pack_Decl : Node_Id;
12432 Pack_Id : Entity_Id;
12436 -- Start of processing for Abstract_State
12440 Check_No_Identifiers;
12441 Check_Arg_Count (1);
12443 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
12445 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
12446 N_Package_Declaration)
12452 Pack_Id := Defining_Entity (Pack_Decl);
12454 -- A pragma that applies to a Ghost entity becomes Ghost for the
12455 -- purposes of legality checks and removal of ignored Ghost code.
12457 Mark_Ghost_Pragma (N, Pack_Id);
12458 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
12460 -- Chain the pragma on the contract for completeness
12462 Add_Contract_Item (N, Pack_Id);
12464 -- The legality checks of pragmas Abstract_State, Initializes, and
12465 -- Initial_Condition are affected by the SPARK mode in effect. In
12466 -- addition, these three pragmas are subject to an inherent order:
12468 -- 1) Abstract_State
12470 -- 3) Initial_Condition
12472 -- Analyze all these pragmas in the order outlined above
12474 Analyze_If_Present (Pragma_SPARK_Mode);
12475 States := Expression (Get_Argument (N, Pack_Id));
12477 -- Multiple non-null abstract states appear as an aggregate
12479 if Nkind (States) = N_Aggregate then
12480 State := First (Expressions (States));
12481 while Present (State) loop
12482 Analyze_Abstract_State (State, Pack_Id);
12486 -- An abstract state with a simple option is being illegaly
12487 -- declared with "=>" rather than "with". In this case the
12488 -- state declaration appears as a component association.
12490 if Present (Component_Associations (States)) then
12491 State := First (Component_Associations (States));
12492 while Present (State) loop
12493 Malformed_State_Error (State);
12498 -- Various forms of a single abstract state. Note that these may
12499 -- include malformed state declarations.
12502 Analyze_Abstract_State (States, Pack_Id);
12505 Analyze_If_Present (Pragma_Initializes);
12506 Analyze_If_Present (Pragma_Initial_Condition);
12507 end Abstract_State;
12513 when Pragma_Acc_Data => Acc_Data : declare
12514 Clause_Names : constant Name_List :=
12527 Clauses : Args_List (Clause_Names'Range);
12530 if not OpenAcc_Enabled then
12536 if Nkind (Parent (N)) /= N_Loop_Statement then
12538 ("Acc_Data pragma should be placed in loop or block "
12542 Gather_Associations (Clause_Names, Clauses);
12544 for Id in Clause_Names'First .. Clause_Names'Last loop
12545 Clause := Clauses (Id);
12547 if Present (Clause) then
12548 case Clause_Names (Id) is
12556 Validate_Acc_Data_Clause (Clause);
12563 Error_Pragma ("unsupported pragma clause");
12566 raise Program_Error;
12571 Set_Is_OpenAcc_Environment (Parent (N));
12578 when Pragma_Acc_Loop => Acc_Loop : declare
12579 Clause_Names : constant Name_List :=
12592 Clauses : Args_List (Clause_Names'Range);
12596 if not OpenAcc_Enabled then
12602 -- Make sure the pragma is in an openacc construct
12604 Check_Loop_Pragma_Placement;
12607 while Present (Par)
12608 and then (Nkind (Par) /= N_Loop_Statement
12609 or else not Is_OpenAcc_Environment (Par))
12611 Par := Parent (Par);
12614 if not Is_OpenAcc_Environment (Par) then
12616 ("Acc_Loop directive must be associated with an OpenAcc "
12617 & "construct region");
12620 Gather_Associations (Clause_Names, Clauses);
12622 for Id in Clause_Names'First .. Clause_Names'Last loop
12623 Clause := Clauses (Id);
12625 if Present (Clause) then
12626 case Clause_Names (Id) is
12633 when Name_Collapse =>
12634 Validate_Acc_Loop_Collapse (Clause);
12637 Validate_Acc_Loop_Gang (Clause);
12639 when Name_Acc_Private =>
12640 Validate_Acc_Data_Clause (Clause);
12642 when Name_Reduction =>
12643 Validate_Acc_Name_Reduction (Clause);
12646 Validate_Acc_Size_Expressions (Clause);
12648 when Name_Vector =>
12649 Validate_Acc_Loop_Vector (Clause);
12651 when Name_Worker =>
12652 Validate_Acc_Loop_Worker (Clause);
12655 raise Program_Error;
12660 Set_Is_OpenAcc_Loop (Parent (N));
12663 ----------------------------------
12664 -- Acc_Parallel and Acc_Kernels --
12665 ----------------------------------
12667 when Pragma_Acc_Parallel
12668 | Pragma_Acc_Kernels
12670 Acc_Kernels_Or_Parallel : declare
12671 Clause_Names : constant Name_List :=
12684 Name_Vector_Length,
12690 Name_First_Private,
12699 Clauses : Args_List (Clause_Names'Range);
12702 if not OpenAcc_Enabled then
12707 Check_Loop_Pragma_Placement;
12709 if Nkind (Parent (N)) /= N_Loop_Statement then
12711 ("pragma should be placed in loop or block statements");
12714 Gather_Associations (Clause_Names, Clauses);
12716 for Id in Clause_Names'First .. Clause_Names'Last loop
12717 Clause := Clauses (Id);
12719 if Present (Clause) then
12720 if Chars (Parent (Clause)) = No_Name then
12721 Error_Pragma ("all arguments should be associations");
12723 case Clause_Names (Id) is
12725 -- Note: According to the OpenAcc Standard v2.6,
12726 -- Async's argument should be optional. Because this
12727 -- complicates parsing the clause, the argument is
12728 -- made mandatory. The standard defines two negative
12729 -- values, acc_async_noval and acc_async_sync. When
12730 -- given acc_async_noval as value, the clause should
12731 -- behave as if no argument was given. According to
12732 -- the standard, acc_async_noval is defined in header
12733 -- files for C and Fortran, thus this value should
12734 -- probably be defined in the OpenAcc Ada library once
12735 -- it is implemented.
12740 | Name_Vector_Length
12742 Validate_Acc_Int_Expr_Clause (Clause);
12744 when Name_Acc_If =>
12745 Validate_Acc_Condition_Clause (Clause);
12747 -- Unsupported by GCC
12752 Error_Pragma ("unsupported clause");
12754 when Name_Acc_Private
12755 | Name_First_Private
12757 if Prag_Id /= Pragma_Acc_Parallel then
12759 ("argument is only available for 'Parallel' "
12762 Validate_Acc_Data_Clause (Clause);
12772 Validate_Acc_Data_Clause (Clause);
12774 when Name_Reduction =>
12775 if Prag_Id /= Pragma_Acc_Parallel then
12777 ("argument is only available for 'Parallel' "
12780 Validate_Acc_Name_Reduction (Clause);
12783 when Name_Default =>
12784 if Chars (Clause) /= Name_None then
12785 Error_Pragma ("expected none");
12788 when Name_Device_Type =>
12789 Error_Pragma ("unsupported pragma clause");
12791 -- Similar to Name_Async, Name_Wait's arguments should
12792 -- be optional. However, this can be simulated using
12793 -- acc_async_noval, hence, we do not bother making the
12794 -- argument optional for now.
12797 Validate_Acc_Int_Expr_List_Clause (Clause);
12800 raise Program_Error;
12806 Set_Is_OpenAcc_Environment (Parent (N));
12807 end Acc_Kernels_Or_Parallel;
12815 -- Note: this pragma also has some specific processing in Par.Prag
12816 -- because we want to set the Ada version mode during parsing.
12818 when Pragma_Ada_83 =>
12820 Check_Arg_Count (0);
12822 -- We really should check unconditionally for proper configuration
12823 -- pragma placement, since we really don't want mixed Ada modes
12824 -- within a single unit, and the GNAT reference manual has always
12825 -- said this was a configuration pragma, but we did not check and
12826 -- are hesitant to add the check now.
12828 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12829 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12830 -- or Ada 2012 mode.
12832 if Ada_Version >= Ada_2005 then
12833 Check_Valid_Configuration_Pragma;
12836 -- Now set Ada 83 mode
12838 if Latest_Ada_Only then
12839 Error_Pragma ("??pragma% ignored");
12841 Ada_Version := Ada_83;
12842 Ada_Version_Explicit := Ada_83;
12843 Ada_Version_Pragma := N;
12852 -- Note: this pragma also has some specific processing in Par.Prag
12853 -- because we want to set the Ada 83 version mode during parsing.
12855 when Pragma_Ada_95 =>
12857 Check_Arg_Count (0);
12859 -- We really should check unconditionally for proper configuration
12860 -- pragma placement, since we really don't want mixed Ada modes
12861 -- within a single unit, and the GNAT reference manual has always
12862 -- said this was a configuration pragma, but we did not check and
12863 -- are hesitant to add the check now.
12865 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12866 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12868 if Ada_Version >= Ada_2005 then
12869 Check_Valid_Configuration_Pragma;
12872 -- Now set Ada 95 mode
12874 if Latest_Ada_Only then
12875 Error_Pragma ("??pragma% ignored");
12877 Ada_Version := Ada_95;
12878 Ada_Version_Explicit := Ada_95;
12879 Ada_Version_Pragma := N;
12882 ---------------------
12883 -- Ada_05/Ada_2005 --
12884 ---------------------
12887 -- pragma Ada_05 (LOCAL_NAME);
12889 -- pragma Ada_2005;
12890 -- pragma Ada_2005 (LOCAL_NAME):
12892 -- Note: these pragmas also have some specific processing in Par.Prag
12893 -- because we want to set the Ada 2005 version mode during parsing.
12895 -- The one argument form is used for managing the transition from
12896 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12897 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12898 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12899 -- mode, a preference rule is established which does not choose
12900 -- such an entity unless it is unambiguously specified. This avoids
12901 -- extra subprograms marked this way from generating ambiguities in
12902 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12903 -- intended for exclusive use in the GNAT run-time library.
12914 if Arg_Count = 1 then
12915 Check_Arg_Is_Local_Name (Arg1);
12916 E_Id := Get_Pragma_Arg (Arg1);
12918 if Etype (E_Id) = Any_Type then
12922 Set_Is_Ada_2005_Only (Entity (E_Id));
12923 Record_Rep_Item (Entity (E_Id), N);
12926 Check_Arg_Count (0);
12928 -- For Ada_2005 we unconditionally enforce the documented
12929 -- configuration pragma placement, since we do not want to
12930 -- tolerate mixed modes in a unit involving Ada 2005. That
12931 -- would cause real difficulties for those cases where there
12932 -- are incompatibilities between Ada 95 and Ada 2005.
12934 Check_Valid_Configuration_Pragma;
12936 -- Now set appropriate Ada mode
12938 if Latest_Ada_Only then
12939 Error_Pragma ("??pragma% ignored");
12941 Ada_Version := Ada_2005;
12942 Ada_Version_Explicit := Ada_2005;
12943 Ada_Version_Pragma := N;
12948 ---------------------
12949 -- Ada_12/Ada_2012 --
12950 ---------------------
12953 -- pragma Ada_12 (LOCAL_NAME);
12955 -- pragma Ada_2012;
12956 -- pragma Ada_2012 (LOCAL_NAME):
12958 -- Note: these pragmas also have some specific processing in Par.Prag
12959 -- because we want to set the Ada 2012 version mode during parsing.
12961 -- The one argument form is used for managing the transition from Ada
12962 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12963 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12964 -- mode will generate a warning. In addition, in any pre-Ada_2012
12965 -- mode, a preference rule is established which does not choose
12966 -- such an entity unless it is unambiguously specified. This avoids
12967 -- extra subprograms marked this way from generating ambiguities in
12968 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12969 -- intended for exclusive use in the GNAT run-time library.
12980 if Arg_Count = 1 then
12981 Check_Arg_Is_Local_Name (Arg1);
12982 E_Id := Get_Pragma_Arg (Arg1);
12984 if Etype (E_Id) = Any_Type then
12988 Set_Is_Ada_2012_Only (Entity (E_Id));
12989 Record_Rep_Item (Entity (E_Id), N);
12992 Check_Arg_Count (0);
12994 -- For Ada_2012 we unconditionally enforce the documented
12995 -- configuration pragma placement, since we do not want to
12996 -- tolerate mixed modes in a unit involving Ada 2012. That
12997 -- would cause real difficulties for those cases where there
12998 -- are incompatibilities between Ada 95 and Ada 2012. We could
12999 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
13001 Check_Valid_Configuration_Pragma;
13003 -- Now set appropriate Ada mode
13005 Ada_Version := Ada_2012;
13006 Ada_Version_Explicit := Ada_2012;
13007 Ada_Version_Pragma := N;
13015 -- pragma Ada_2020;
13017 -- Note: this pragma also has some specific processing in Par.Prag
13018 -- because we want to set the Ada 2020 version mode during parsing.
13020 when Pragma_Ada_2020 =>
13023 Check_Arg_Count (0);
13025 Check_Valid_Configuration_Pragma;
13027 -- Now set appropriate Ada mode
13029 Ada_Version := Ada_2020;
13030 Ada_Version_Explicit := Ada_2020;
13031 Ada_Version_Pragma := N;
13033 ----------------------
13034 -- All_Calls_Remote --
13035 ----------------------
13037 -- pragma All_Calls_Remote [(library_package_NAME)];
13039 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
13040 Lib_Entity : Entity_Id;
13043 Check_Ada_83_Warning;
13044 Check_Valid_Library_Unit_Pragma;
13046 if Nkind (N) = N_Null_Statement then
13050 Lib_Entity := Find_Lib_Unit_Name;
13052 -- A pragma that applies to a Ghost entity becomes Ghost for the
13053 -- purposes of legality checks and removal of ignored Ghost code.
13055 Mark_Ghost_Pragma (N, Lib_Entity);
13057 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13059 if Present (Lib_Entity) and then not Debug_Flag_U then
13060 if not Is_Remote_Call_Interface (Lib_Entity) then
13061 Error_Pragma ("pragma% only apply to rci unit");
13063 -- Set flag for entity of the library unit
13066 Set_Has_All_Calls_Remote (Lib_Entity);
13069 end All_Calls_Remote;
13071 ---------------------------
13072 -- Allow_Integer_Address --
13073 ---------------------------
13075 -- pragma Allow_Integer_Address;
13077 when Pragma_Allow_Integer_Address =>
13079 Check_Valid_Configuration_Pragma;
13080 Check_Arg_Count (0);
13082 -- If Address is a private type, then set the flag to allow
13083 -- integer address values. If Address is not private, then this
13084 -- pragma has no purpose, so it is simply ignored. Not clear if
13085 -- there are any such targets now.
13087 if Opt.Address_Is_Private then
13088 Opt.Allow_Integer_Address := True;
13096 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13097 -- ARG ::= NAME | EXPRESSION
13099 -- The first two arguments are by convention intended to refer to an
13100 -- external tool and a tool-specific function. These arguments are
13103 when Pragma_Annotate => Annotate : declare
13110 Check_At_Least_N_Arguments (1);
13112 Nam_Arg := Last (Pragma_Argument_Associations (N));
13114 -- Determine whether the last argument is "Entity => local_NAME"
13115 -- and if it is, perform the required semantic checks. Remove the
13116 -- argument from further processing.
13118 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
13119 and then Chars (Nam_Arg) = Name_Entity
13121 Check_Arg_Is_Local_Name (Nam_Arg);
13122 Arg_Count := Arg_Count - 1;
13124 -- A pragma that applies to a Ghost entity becomes Ghost for
13125 -- the purposes of legality checks and removal of ignored Ghost
13128 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
13129 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
13131 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
13134 -- Not allowed in compiler units (bootstrap issues)
13136 Check_Compiler_Unit ("Entity for pragma Annotate", N);
13139 -- Continue the processing with last argument removed for now
13141 Check_Arg_Is_Identifier (Arg1);
13142 Check_No_Identifiers;
13145 -- The second parameter is optional, it is never analyzed
13150 -- Otherwise there is a second parameter
13153 -- The second parameter must be an identifier
13155 Check_Arg_Is_Identifier (Arg2);
13157 -- Process the remaining parameters (if any)
13159 Arg := Next (Arg2);
13160 while Present (Arg) loop
13161 Expr := Get_Pragma_Arg (Arg);
13164 if Is_Entity_Name (Expr) then
13167 -- For string literals, we assume Standard_String as the
13168 -- type, unless the string contains wide or wide_wide
13171 elsif Nkind (Expr) = N_String_Literal then
13172 if Has_Wide_Wide_Character (Expr) then
13173 Resolve (Expr, Standard_Wide_Wide_String);
13174 elsif Has_Wide_Character (Expr) then
13175 Resolve (Expr, Standard_Wide_String);
13177 Resolve (Expr, Standard_String);
13180 elsif Is_Overloaded (Expr) then
13181 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
13192 -------------------------------------------------
13193 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13194 -------------------------------------------------
13197 -- ( [Check => ] Boolean_EXPRESSION
13198 -- [, [Message =>] Static_String_EXPRESSION]);
13200 -- pragma Assert_And_Cut
13201 -- ( [Check => ] Boolean_EXPRESSION
13202 -- [, [Message =>] Static_String_EXPRESSION]);
13205 -- ( [Check => ] Boolean_EXPRESSION
13206 -- [, [Message =>] Static_String_EXPRESSION]);
13208 -- pragma Loop_Invariant
13209 -- ( [Check => ] Boolean_EXPRESSION
13210 -- [, [Message =>] Static_String_EXPRESSION]);
13213 | Pragma_Assert_And_Cut
13215 | Pragma_Loop_Invariant
13218 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
13219 -- Determine whether expression Expr contains a Loop_Entry
13220 -- attribute reference.
13222 -------------------------
13223 -- Contains_Loop_Entry --
13224 -------------------------
13226 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
13227 Has_Loop_Entry : Boolean := False;
13229 function Process (N : Node_Id) return Traverse_Result;
13230 -- Process function for traversal to look for Loop_Entry
13236 function Process (N : Node_Id) return Traverse_Result is
13238 if Nkind (N) = N_Attribute_Reference
13239 and then Attribute_Name (N) = Name_Loop_Entry
13241 Has_Loop_Entry := True;
13248 procedure Traverse is new Traverse_Proc (Process);
13250 -- Start of processing for Contains_Loop_Entry
13254 return Has_Loop_Entry;
13255 end Contains_Loop_Entry;
13260 New_Args : List_Id;
13262 -- Start of processing for Assert
13265 -- Assert is an Ada 2005 RM-defined pragma
13267 if Prag_Id = Pragma_Assert then
13270 -- The remaining ones are GNAT pragmas
13276 Check_At_Least_N_Arguments (1);
13277 Check_At_Most_N_Arguments (2);
13278 Check_Arg_Order ((Name_Check, Name_Message));
13279 Check_Optional_Identifier (Arg1, Name_Check);
13280 Expr := Get_Pragma_Arg (Arg1);
13282 -- Special processing for Loop_Invariant, Loop_Variant or for
13283 -- other cases where a Loop_Entry attribute is present. If the
13284 -- assertion pragma contains attribute Loop_Entry, ensure that
13285 -- the related pragma is within a loop.
13287 if Prag_Id = Pragma_Loop_Invariant
13288 or else Prag_Id = Pragma_Loop_Variant
13289 or else Contains_Loop_Entry (Expr)
13291 Check_Loop_Pragma_Placement;
13293 -- Perform preanalysis to deal with embedded Loop_Entry
13296 Preanalyze_Assert_Expression (Expr, Any_Boolean);
13299 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13300 -- a corresponding Check pragma:
13302 -- pragma Check (name, condition [, msg]);
13304 -- Where name is the identifier matching the pragma name. So
13305 -- rewrite pragma in this manner, transfer the message argument
13306 -- if present, and analyze the result
13308 -- Note: When dealing with a semantically analyzed tree, the
13309 -- information that a Check node N corresponds to a source Assert,
13310 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13311 -- pragma kind of Original_Node(N).
13313 New_Args := New_List (
13314 Make_Pragma_Argument_Association (Loc,
13315 Expression => Make_Identifier (Loc, Pname)),
13316 Make_Pragma_Argument_Association (Sloc (Expr),
13317 Expression => Expr));
13319 if Arg_Count > 1 then
13320 Check_Optional_Identifier (Arg2, Name_Message);
13322 -- Provide semantic annnotations for optional argument, for
13323 -- ASIS use, before rewriting.
13325 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
13326 Append_To (New_Args, New_Copy_Tree (Arg2));
13329 -- Rewrite as Check pragma
13333 Chars => Name_Check,
13334 Pragma_Argument_Associations => New_Args));
13339 ----------------------
13340 -- Assertion_Policy --
13341 ----------------------
13343 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13345 -- The following form is Ada 2012 only, but we allow it in all modes
13347 -- Pragma Assertion_Policy (
13348 -- ASSERTION_KIND => POLICY_IDENTIFIER
13349 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13351 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13353 -- RM_ASSERTION_KIND ::= Assert |
13354 -- Static_Predicate |
13355 -- Dynamic_Predicate |
13360 -- Type_Invariant |
13361 -- Type_Invariant'Class
13363 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13365 -- Contract_Cases |
13367 -- Default_Initial_Condition |
13369 -- Initial_Condition |
13370 -- Loop_Invariant |
13376 -- Statement_Assertions
13378 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13379 -- ID_ASSERTION_KIND list contains implementation-defined additions
13380 -- recognized by GNAT. The effect is to control the behavior of
13381 -- identically named aspects and pragmas, depending on the specified
13382 -- policy identifier:
13384 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13386 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13387 -- implementation-defined addition that results in totally ignoring
13388 -- the corresponding assertion. If Disable is specified, then the
13389 -- argument of the assertion is not even analyzed. This is useful
13390 -- when the aspect/pragma argument references entities in a with'ed
13391 -- package that is replaced by a dummy package in the final build.
13393 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13394 -- and Type_Invariant'Class were recognized by the parser and
13395 -- transformed into references to the special internal identifiers
13396 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13397 -- processing is required here.
13399 when Pragma_Assertion_Policy => Assertion_Policy : declare
13400 procedure Resolve_Suppressible (Policy : Node_Id);
13401 -- Converts the assertion policy 'Suppressible' to either Check or
13402 -- Ignore based on whether checks are suppressed via -gnatp.
13404 --------------------------
13405 -- Resolve_Suppressible --
13406 --------------------------
13408 procedure Resolve_Suppressible (Policy : Node_Id) is
13409 Arg : constant Node_Id := Get_Pragma_Arg (Policy);
13413 -- Transform policy argument Suppressible into either Ignore or
13414 -- Check depending on whether checks are enabled or suppressed.
13416 if Chars (Arg) = Name_Suppressible then
13417 if Suppress_Checks then
13418 Nam := Name_Ignore;
13423 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
13425 end Resolve_Suppressible;
13437 -- This can always appear as a configuration pragma
13439 if Is_Configuration_Pragma then
13442 -- It can also appear in a declarative part or package spec in Ada
13443 -- 2012 mode. We allow this in other modes, but in that case we
13444 -- consider that we have an Ada 2012 pragma on our hands.
13447 Check_Is_In_Decl_Part_Or_Package_Spec;
13451 -- One argument case with no identifier (first form above)
13454 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
13455 or else Chars (Arg1) = No_Name)
13457 Check_Arg_Is_One_Of (Arg1,
13458 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13460 Resolve_Suppressible (Arg1);
13462 -- Treat one argument Assertion_Policy as equivalent to:
13464 -- pragma Check_Policy (Assertion, policy)
13466 -- So rewrite pragma in that manner and link on to the chain
13467 -- of Check_Policy pragmas, marking the pragma as analyzed.
13469 Policy := Get_Pragma_Arg (Arg1);
13473 Chars => Name_Check_Policy,
13474 Pragma_Argument_Associations => New_List (
13475 Make_Pragma_Argument_Association (Loc,
13476 Expression => Make_Identifier (Loc, Name_Assertion)),
13478 Make_Pragma_Argument_Association (Loc,
13480 Make_Identifier (Sloc (Policy), Chars (Policy))))));
13483 -- Here if we have two or more arguments
13486 Check_At_Least_N_Arguments (1);
13489 -- Loop through arguments
13492 while Present (Arg) loop
13493 LocP := Sloc (Arg);
13495 -- Kind must be specified
13497 if Nkind (Arg) /= N_Pragma_Argument_Association
13498 or else Chars (Arg) = No_Name
13501 ("missing assertion kind for pragma%", Arg);
13504 -- Check Kind and Policy have allowed forms
13506 Kind := Chars (Arg);
13507 Policy := Get_Pragma_Arg (Arg);
13509 if not Is_Valid_Assertion_Kind (Kind) then
13511 ("invalid assertion kind for pragma%", Arg);
13514 Check_Arg_Is_One_Of (Arg,
13515 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
13517 Resolve_Suppressible (Arg);
13519 if Kind = Name_Ghost then
13521 -- The Ghost policy must be either Check or Ignore
13522 -- (SPARK RM 6.9(6)).
13524 if not Nam_In (Chars (Policy), Name_Check,
13528 ("argument of pragma % Ghost must be Check or "
13529 & "Ignore", Policy);
13532 -- Pragma Assertion_Policy specifying a Ghost policy
13533 -- cannot occur within a Ghost subprogram or package
13534 -- (SPARK RM 6.9(14)).
13536 if Ghost_Mode > None then
13538 ("pragma % cannot appear within ghost subprogram or "
13543 -- Rewrite the Assertion_Policy pragma as a series of
13544 -- Check_Policy pragmas of the form:
13546 -- Check_Policy (Kind, Policy);
13548 -- Note: the insertion of the pragmas cannot be done with
13549 -- Insert_Action because in the configuration case, there
13550 -- are no scopes on the scope stack and the mechanism will
13553 Insert_Before_And_Analyze (N,
13555 Chars => Name_Check_Policy,
13556 Pragma_Argument_Associations => New_List (
13557 Make_Pragma_Argument_Association (LocP,
13558 Expression => Make_Identifier (LocP, Kind)),
13559 Make_Pragma_Argument_Association (LocP,
13560 Expression => Policy))));
13565 -- Rewrite the Assertion_Policy pragma as null since we have
13566 -- now inserted all the equivalent Check pragmas.
13568 Rewrite (N, Make_Null_Statement (Loc));
13571 end Assertion_Policy;
13573 ------------------------------
13574 -- Assume_No_Invalid_Values --
13575 ------------------------------
13577 -- pragma Assume_No_Invalid_Values (On | Off);
13579 when Pragma_Assume_No_Invalid_Values =>
13581 Check_Valid_Configuration_Pragma;
13582 Check_Arg_Count (1);
13583 Check_No_Identifiers;
13584 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13586 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
13587 Assume_No_Invalid_Values := True;
13589 Assume_No_Invalid_Values := False;
13592 --------------------------
13593 -- Attribute_Definition --
13594 --------------------------
13596 -- pragma Attribute_Definition
13597 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13598 -- [Entity =>] LOCAL_NAME,
13599 -- [Expression =>] EXPRESSION | NAME);
13601 when Pragma_Attribute_Definition => Attribute_Definition : declare
13602 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
13607 Check_Arg_Count (3);
13608 Check_Optional_Identifier (Arg1, "attribute");
13609 Check_Optional_Identifier (Arg2, "entity");
13610 Check_Optional_Identifier (Arg3, "expression");
13612 if Nkind (Attribute_Designator) /= N_Identifier then
13613 Error_Msg_N ("attribute name expected", Attribute_Designator);
13617 Check_Arg_Is_Local_Name (Arg2);
13619 -- If the attribute is not recognized, then issue a warning (not
13620 -- an error), and ignore the pragma.
13622 Aname := Chars (Attribute_Designator);
13624 if not Is_Attribute_Name (Aname) then
13625 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
13629 -- Otherwise, rewrite the pragma as an attribute definition clause
13632 Make_Attribute_Definition_Clause (Loc,
13633 Name => Get_Pragma_Arg (Arg2),
13635 Expression => Get_Pragma_Arg (Arg3)));
13637 end Attribute_Definition;
13639 ------------------------------------------------------------------
13640 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13642 ------------------------------------------------------------------
13644 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13645 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13646 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13647 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13648 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13650 when Pragma_Async_Readers
13651 | Pragma_Async_Writers
13652 | Pragma_Effective_Reads
13653 | Pragma_Effective_Writes
13654 | Pragma_No_Caching
13656 Async_Effective : declare
13657 Obj_Decl : Node_Id;
13658 Obj_Id : Entity_Id;
13662 Check_No_Identifiers;
13663 Check_At_Most_N_Arguments (1);
13665 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13667 -- Object declaration
13669 if Nkind (Obj_Decl) /= N_Object_Declaration then
13674 Obj_Id := Defining_Entity (Obj_Decl);
13676 -- Perform minimal verification to ensure that the argument is at
13677 -- least a variable. Subsequent finer grained checks will be done
13678 -- at the end of the declarative region the contains the pragma.
13680 if Ekind (Obj_Id) = E_Variable then
13682 -- A pragma that applies to a Ghost entity becomes Ghost for
13683 -- the purposes of legality checks and removal of ignored Ghost
13686 Mark_Ghost_Pragma (N, Obj_Id);
13688 -- Chain the pragma on the contract for further processing by
13689 -- Analyze_External_Property_In_Decl_Part.
13691 Add_Contract_Item (N, Obj_Id);
13693 -- Analyze the Boolean expression (if any)
13695 if Present (Arg1) then
13696 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13699 -- Otherwise the external property applies to a constant
13702 Error_Pragma ("pragma % must apply to a volatile object");
13704 end Async_Effective;
13710 -- pragma Asynchronous (LOCAL_NAME);
13712 when Pragma_Asynchronous => Asynchronous : declare
13715 Formal : Entity_Id;
13720 procedure Process_Async_Pragma;
13721 -- Common processing for procedure and access-to-procedure case
13723 --------------------------
13724 -- Process_Async_Pragma --
13725 --------------------------
13727 procedure Process_Async_Pragma is
13730 Set_Is_Asynchronous (Nm);
13734 -- The formals should be of mode IN (RM E.4.1(6))
13737 while Present (S) loop
13738 Formal := Defining_Identifier (S);
13740 if Nkind (Formal) = N_Defining_Identifier
13741 and then Ekind (Formal) /= E_In_Parameter
13744 ("pragma% procedure can only have IN parameter",
13751 Set_Is_Asynchronous (Nm);
13752 end Process_Async_Pragma;
13754 -- Start of processing for pragma Asynchronous
13757 Check_Ada_83_Warning;
13758 Check_No_Identifiers;
13759 Check_Arg_Count (1);
13760 Check_Arg_Is_Local_Name (Arg1);
13762 if Debug_Flag_U then
13766 C_Ent := Cunit_Entity (Current_Sem_Unit);
13767 Analyze (Get_Pragma_Arg (Arg1));
13768 Nm := Entity (Get_Pragma_Arg (Arg1));
13770 -- A pragma that applies to a Ghost entity becomes Ghost for the
13771 -- purposes of legality checks and removal of ignored Ghost code.
13773 Mark_Ghost_Pragma (N, Nm);
13775 if not Is_Remote_Call_Interface (C_Ent)
13776 and then not Is_Remote_Types (C_Ent)
13778 -- This pragma should only appear in an RCI or Remote Types
13779 -- unit (RM E.4.1(4)).
13782 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13785 if Ekind (Nm) = E_Procedure
13786 and then Nkind (Parent (Nm)) = N_Procedure_Specification
13788 if not Is_Remote_Call_Interface (Nm) then
13790 ("pragma% cannot be applied on non-remote procedure",
13794 L := Parameter_Specifications (Parent (Nm));
13795 Process_Async_Pragma;
13798 elsif Ekind (Nm) = E_Function then
13800 ("pragma% cannot be applied to function", Arg1);
13802 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
13803 if Is_Record_Type (Nm) then
13805 -- A record type that is the Equivalent_Type for a remote
13806 -- access-to-subprogram type.
13808 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
13811 -- A non-expanded RAS type (distribution is not enabled)
13813 Decl := Declaration_Node (Nm);
13816 if Nkind (Decl) = N_Full_Type_Declaration
13817 and then Nkind (Type_Definition (Decl)) =
13818 N_Access_Procedure_Definition
13820 L := Parameter_Specifications (Type_Definition (Decl));
13821 Process_Async_Pragma;
13823 if Is_Asynchronous (Nm)
13824 and then Expander_Active
13825 and then Get_PCS_Name /= Name_No_DSA
13827 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
13832 ("pragma% cannot reference access-to-function type",
13836 -- Only other possibility is Access-to-class-wide type
13838 elsif Is_Access_Type (Nm)
13839 and then Is_Class_Wide_Type (Designated_Type (Nm))
13841 Check_First_Subtype (Arg1);
13842 Set_Is_Asynchronous (Nm);
13843 if Expander_Active then
13844 RACW_Type_Is_Asynchronous (Nm);
13848 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
13856 -- pragma Atomic (LOCAL_NAME);
13858 when Pragma_Atomic =>
13859 Process_Atomic_Independent_Shared_Volatile;
13861 -----------------------
13862 -- Atomic_Components --
13863 -----------------------
13865 -- pragma Atomic_Components (array_LOCAL_NAME);
13867 -- This processing is shared by Volatile_Components
13869 when Pragma_Atomic_Components
13870 | Pragma_Volatile_Components
13872 Atomic_Components : declare
13879 Check_Ada_83_Warning;
13880 Check_No_Identifiers;
13881 Check_Arg_Count (1);
13882 Check_Arg_Is_Local_Name (Arg1);
13883 E_Id := Get_Pragma_Arg (Arg1);
13885 if Etype (E_Id) = Any_Type then
13889 E := Entity (E_Id);
13891 -- A pragma that applies to a Ghost entity becomes Ghost for the
13892 -- purposes of legality checks and removal of ignored Ghost code.
13894 Mark_Ghost_Pragma (N, E);
13895 Check_Duplicate_Pragma (E);
13897 if Rep_Item_Too_Early (E, N)
13899 Rep_Item_Too_Late (E, N)
13904 D := Declaration_Node (E);
13907 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
13909 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13910 and then Nkind (D) = N_Object_Declaration
13911 and then Nkind (Object_Definition (D)) =
13912 N_Constrained_Array_Definition)
13914 -- The flag is set on the object, or on the base type
13916 if Nkind (D) /= N_Object_Declaration then
13917 E := Base_Type (E);
13920 -- Atomic implies both Independent and Volatile
13922 if Prag_Id = Pragma_Atomic_Components then
13923 Set_Has_Atomic_Components (E);
13924 Set_Has_Independent_Components (E);
13927 Set_Has_Volatile_Components (E);
13930 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
13932 end Atomic_Components;
13934 --------------------
13935 -- Attach_Handler --
13936 --------------------
13938 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13940 when Pragma_Attach_Handler =>
13941 Check_Ada_83_Warning;
13942 Check_No_Identifiers;
13943 Check_Arg_Count (2);
13945 if No_Run_Time_Mode then
13946 Error_Msg_CRT ("Attach_Handler pragma", N);
13948 Check_Interrupt_Or_Attach_Handler;
13950 -- The expression that designates the attribute may depend on a
13951 -- discriminant, and is therefore a per-object expression, to
13952 -- be expanded in the init proc. If expansion is enabled, then
13953 -- perform semantic checks on a copy only.
13958 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
13961 -- In Relaxed_RM_Semantics mode, we allow any static
13962 -- integer value, for compatibility with other compilers.
13964 if Relaxed_RM_Semantics
13965 and then Nkind (Parg2) = N_Integer_Literal
13967 Typ := Standard_Integer;
13969 Typ := RTE (RE_Interrupt_ID);
13972 if Expander_Active then
13973 Temp := New_Copy_Tree (Parg2);
13974 Set_Parent (Temp, N);
13975 Preanalyze_And_Resolve (Temp, Typ);
13978 Resolve (Parg2, Typ);
13982 Process_Interrupt_Or_Attach_Handler;
13985 --------------------
13986 -- C_Pass_By_Copy --
13987 --------------------
13989 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13991 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
13997 Check_Valid_Configuration_Pragma;
13998 Check_Arg_Count (1);
13999 Check_Optional_Identifier (Arg1, "max_size");
14001 Arg := Get_Pragma_Arg (Arg1);
14002 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
14004 Val := Expr_Value (Arg);
14008 ("maximum size for pragma% must be positive", Arg1);
14010 elsif UI_Is_In_Int_Range (Val) then
14011 Default_C_Record_Mechanism := UI_To_Int (Val);
14013 -- If a giant value is given, Int'Last will do well enough.
14014 -- If sometime someone complains that a record larger than
14015 -- two gigabytes is not copied, we will worry about it then.
14018 Default_C_Record_Mechanism := Mechanism_Type'Last;
14020 end C_Pass_By_Copy;
14026 -- pragma Check ([Name =>] CHECK_KIND,
14027 -- [Check =>] Boolean_EXPRESSION
14028 -- [,[Message =>] String_EXPRESSION]);
14030 -- CHECK_KIND ::= IDENTIFIER |
14033 -- Invariant'Class |
14034 -- Type_Invariant'Class
14036 -- The identifiers Assertions and Statement_Assertions are not
14037 -- allowed, since they have special meaning for Check_Policy.
14039 -- WARNING: The code below manages Ghost regions. Return statements
14040 -- must be replaced by gotos which jump to the end of the code and
14041 -- restore the Ghost mode.
14043 when Pragma_Check => Check : declare
14044 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
14045 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
14046 -- Save the Ghost-related attributes to restore on exit
14052 pragma Warnings (Off, Str);
14055 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14056 -- the mode now to ensure that any nodes generated during analysis
14057 -- and expansion are marked as Ghost.
14059 Set_Ghost_Mode (N);
14062 Check_At_Least_N_Arguments (2);
14063 Check_At_Most_N_Arguments (3);
14064 Check_Optional_Identifier (Arg1, Name_Name);
14065 Check_Optional_Identifier (Arg2, Name_Check);
14067 if Arg_Count = 3 then
14068 Check_Optional_Identifier (Arg3, Name_Message);
14069 Str := Get_Pragma_Arg (Arg3);
14072 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
14073 Check_Arg_Is_Identifier (Arg1);
14074 Cname := Chars (Get_Pragma_Arg (Arg1));
14076 -- Check forbidden name Assertions or Statement_Assertions
14079 when Name_Assertions =>
14081 ("""Assertions"" is not allowed as a check kind for "
14082 & "pragma%", Arg1);
14084 when Name_Statement_Assertions =>
14086 ("""Statement_Assertions"" is not allowed as a check kind "
14087 & "for pragma%", Arg1);
14093 -- Check applicable policy. We skip this if Checked/Ignored status
14094 -- is already set (e.g. in the case of a pragma from an aspect).
14096 if Is_Checked (N) or else Is_Ignored (N) then
14099 -- For a non-source pragma that is a rewriting of another pragma,
14100 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14102 elsif Is_Rewrite_Substitution (N)
14103 and then Nkind (Original_Node (N)) = N_Pragma
14105 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
14106 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
14108 -- Otherwise query the applicable policy at this point
14111 case Check_Kind (Cname) is
14112 when Name_Ignore =>
14113 Set_Is_Ignored (N, True);
14114 Set_Is_Checked (N, False);
14117 Set_Is_Ignored (N, False);
14118 Set_Is_Checked (N, True);
14120 -- For disable, rewrite pragma as null statement and skip
14121 -- rest of the analysis of the pragma.
14123 when Name_Disable =>
14124 Rewrite (N, Make_Null_Statement (Loc));
14128 -- No other possibilities
14131 raise Program_Error;
14135 -- If check kind was not Disable, then continue pragma analysis
14137 Expr := Get_Pragma_Arg (Arg2);
14139 -- Mark the pragma (or, if rewritten from an aspect, the original
14140 -- aspect) as enabled. Nothing to do for an internally generated
14141 -- check for a dynamic predicate.
14144 and then not Split_PPC (N)
14145 and then Cname /= Name_Dynamic_Predicate
14147 Set_SCO_Pragma_Enabled (Loc);
14150 -- Deal with analyzing the string argument. If checks are not
14151 -- on we don't want any expansion (since such expansion would
14152 -- not get properly deleted) but we do want to analyze (to get
14153 -- proper references). The Preanalyze_And_Resolve routine does
14154 -- just what we want. Ditto if pragma is active, because it will
14155 -- be rewritten as an if-statement whose analysis will complete
14156 -- analysis and expansion of the string message. This makes a
14157 -- difference in the unusual case where the expression for the
14158 -- string may have a side effect, such as raising an exception.
14159 -- This is mandated by RM 11.4.2, which specifies that the string
14160 -- expression is only evaluated if the check fails and
14161 -- Assertion_Error is to be raised.
14163 if Arg_Count = 3 then
14164 Preanalyze_And_Resolve (Str, Standard_String);
14167 -- Now you might think we could just do the same with the Boolean
14168 -- expression if checks are off (and expansion is on) and then
14169 -- rewrite the check as a null statement. This would work but we
14170 -- would lose the useful warnings about an assertion being bound
14171 -- to fail even if assertions are turned off.
14173 -- So instead we wrap the boolean expression in an if statement
14174 -- that looks like:
14176 -- if False and then condition then
14180 -- The reason we do this rewriting during semantic analysis rather
14181 -- than as part of normal expansion is that we cannot analyze and
14182 -- expand the code for the boolean expression directly, or it may
14183 -- cause insertion of actions that would escape the attempt to
14184 -- suppress the check code.
14186 -- Note that the Sloc for the if statement corresponds to the
14187 -- argument condition, not the pragma itself. The reason for
14188 -- this is that we may generate a warning if the condition is
14189 -- False at compile time, and we do not want to delete this
14190 -- warning when we delete the if statement.
14192 if Expander_Active and Is_Ignored (N) then
14193 Eloc := Sloc (Expr);
14196 Make_If_Statement (Eloc,
14198 Make_And_Then (Eloc,
14199 Left_Opnd => Make_Identifier (Eloc, Name_False),
14200 Right_Opnd => Expr),
14201 Then_Statements => New_List (
14202 Make_Null_Statement (Eloc))));
14204 -- Now go ahead and analyze the if statement
14206 In_Assertion_Expr := In_Assertion_Expr + 1;
14208 -- One rather special treatment. If we are now in Eliminated
14209 -- overflow mode, then suppress overflow checking since we do
14210 -- not want to drag in the bignum stuff if we are in Ignore
14211 -- mode anyway. This is particularly important if we are using
14212 -- a configurable run time that does not support bignum ops.
14214 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
14216 Svo : constant Boolean :=
14217 Scope_Suppress.Suppress (Overflow_Check);
14219 Scope_Suppress.Overflow_Mode_Assertions := Strict;
14220 Scope_Suppress.Suppress (Overflow_Check) := True;
14222 Scope_Suppress.Suppress (Overflow_Check) := Svo;
14223 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
14226 -- Not that special case
14232 -- All done with this check
14234 In_Assertion_Expr := In_Assertion_Expr - 1;
14236 -- Check is active or expansion not active. In these cases we can
14237 -- just go ahead and analyze the boolean with no worries.
14240 In_Assertion_Expr := In_Assertion_Expr + 1;
14241 Analyze_And_Resolve (Expr, Any_Boolean);
14242 In_Assertion_Expr := In_Assertion_Expr - 1;
14245 Restore_Ghost_Region (Saved_GM, Saved_IGR);
14248 --------------------------
14249 -- Check_Float_Overflow --
14250 --------------------------
14252 -- pragma Check_Float_Overflow;
14254 when Pragma_Check_Float_Overflow =>
14256 Check_Valid_Configuration_Pragma;
14257 Check_Arg_Count (0);
14258 Check_Float_Overflow := not Machine_Overflows_On_Target;
14264 -- pragma Check_Name (check_IDENTIFIER);
14266 when Pragma_Check_Name =>
14268 Check_No_Identifiers;
14269 Check_Valid_Configuration_Pragma;
14270 Check_Arg_Count (1);
14271 Check_Arg_Is_Identifier (Arg1);
14274 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
14277 for J in Check_Names.First .. Check_Names.Last loop
14278 if Check_Names.Table (J) = Nam then
14283 Check_Names.Append (Nam);
14290 -- This is the old style syntax, which is still allowed in all modes:
14292 -- pragma Check_Policy ([Name =>] CHECK_KIND
14293 -- [Policy =>] POLICY_IDENTIFIER);
14295 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14297 -- CHECK_KIND ::= IDENTIFIER |
14300 -- Type_Invariant'Class |
14303 -- This is the new style syntax, compatible with Assertion_Policy
14304 -- and also allowed in all modes.
14306 -- Pragma Check_Policy (
14307 -- CHECK_KIND => POLICY_IDENTIFIER
14308 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14310 -- Note: the identifiers Name and Policy are not allowed as
14311 -- Check_Kind values. This avoids ambiguities between the old and
14312 -- new form syntax.
14314 when Pragma_Check_Policy => Check_Policy : declare
14319 Check_At_Least_N_Arguments (1);
14321 -- A Check_Policy pragma can appear either as a configuration
14322 -- pragma, or in a declarative part or a package spec (see RM
14323 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14324 -- followed for Check_Policy).
14326 if not Is_Configuration_Pragma then
14327 Check_Is_In_Decl_Part_Or_Package_Spec;
14330 -- Figure out if we have the old or new syntax. We have the
14331 -- old syntax if the first argument has no identifier, or the
14332 -- identifier is Name.
14334 if Nkind (Arg1) /= N_Pragma_Argument_Association
14335 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
14339 Check_Arg_Count (2);
14340 Check_Optional_Identifier (Arg1, Name_Name);
14341 Kind := Get_Pragma_Arg (Arg1);
14342 Rewrite_Assertion_Kind (Kind,
14343 From_Policy => Comes_From_Source (N));
14344 Check_Arg_Is_Identifier (Arg1);
14346 -- Check forbidden check kind
14348 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
14349 Error_Msg_Name_2 := Chars (Kind);
14351 ("pragma% does not allow% as check name", Arg1);
14356 Check_Optional_Identifier (Arg2, Name_Policy);
14357 Check_Arg_Is_One_Of
14359 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
14361 -- And chain pragma on the Check_Policy_List for search
14363 Set_Next_Pragma (N, Opt.Check_Policy_List);
14364 Opt.Check_Policy_List := N;
14366 -- For the new syntax, what we do is to convert each argument to
14367 -- an old syntax equivalent. We do that because we want to chain
14368 -- old style Check_Policy pragmas for the search (we don't want
14369 -- to have to deal with multiple arguments in the search).
14380 while Present (Arg) loop
14381 LocP := Sloc (Arg);
14382 Argx := Get_Pragma_Arg (Arg);
14384 -- Kind must be specified
14386 if Nkind (Arg) /= N_Pragma_Argument_Association
14387 or else Chars (Arg) = No_Name
14390 ("missing assertion kind for pragma%", Arg);
14393 -- Construct equivalent old form syntax Check_Policy
14394 -- pragma and insert it to get remaining checks.
14398 Chars => Name_Check_Policy,
14399 Pragma_Argument_Associations => New_List (
14400 Make_Pragma_Argument_Association (LocP,
14402 Make_Identifier (LocP, Chars (Arg))),
14403 Make_Pragma_Argument_Association (Sloc (Argx),
14404 Expression => Argx)));
14408 -- For a configuration pragma, insert old form in
14409 -- the corresponding file.
14411 if Is_Configuration_Pragma then
14412 Insert_After (N, New_P);
14416 Insert_Action (N, New_P);
14420 -- Rewrite original Check_Policy pragma to null, since we
14421 -- have converted it into a series of old syntax pragmas.
14423 Rewrite (N, Make_Null_Statement (Loc));
14433 -- pragma Comment (static_string_EXPRESSION)
14435 -- Processing for pragma Comment shares the circuitry for pragma
14436 -- Ident. The only differences are that Ident enforces a limit of 31
14437 -- characters on its argument, and also enforces limitations on
14438 -- placement for DEC compatibility. Pragma Comment shares neither of
14439 -- these restrictions.
14441 -------------------
14442 -- Common_Object --
14443 -------------------
14445 -- pragma Common_Object (
14446 -- [Internal =>] LOCAL_NAME
14447 -- [, [External =>] EXTERNAL_SYMBOL]
14448 -- [, [Size =>] EXTERNAL_SYMBOL]);
14450 -- Processing for this pragma is shared with Psect_Object
14452 ------------------------
14453 -- Compile_Time_Error --
14454 ------------------------
14456 -- pragma Compile_Time_Error
14457 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14459 when Pragma_Compile_Time_Error =>
14461 Process_Compile_Time_Warning_Or_Error;
14463 --------------------------
14464 -- Compile_Time_Warning --
14465 --------------------------
14467 -- pragma Compile_Time_Warning
14468 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14470 when Pragma_Compile_Time_Warning =>
14472 Process_Compile_Time_Warning_Or_Error;
14474 ---------------------------
14475 -- Compiler_Unit_Warning --
14476 ---------------------------
14478 -- pragma Compiler_Unit_Warning;
14482 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14483 -- errors not warnings. This means that we had introduced a big extra
14484 -- inertia to compiler changes, since even if we implemented a new
14485 -- feature, and even if all versions to be used for bootstrapping
14486 -- implemented this new feature, we could not use it, since old
14487 -- compilers would give errors for using this feature in units
14488 -- having Compiler_Unit pragmas.
14490 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14491 -- problem. We no longer have any units mentioning Compiler_Unit,
14492 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14493 -- and thus generates a warning which can be ignored. So that deals
14494 -- with the problem of old compilers not implementing the newer form
14497 -- Newer compilers recognize the new pragma, but generate warning
14498 -- messages instead of errors, which again can be ignored in the
14499 -- case of an old compiler which implements a wanted new feature
14500 -- but at the time felt like warning about it for older compilers.
14502 -- We retain Compiler_Unit so that new compilers can be used to build
14503 -- older run-times that use this pragma. That's an unusual case, but
14504 -- it's easy enough to handle, so why not?
14506 when Pragma_Compiler_Unit
14507 | Pragma_Compiler_Unit_Warning
14510 Check_Arg_Count (0);
14512 -- Only recognized in main unit
14514 if Current_Sem_Unit = Main_Unit then
14515 Compiler_Unit := True;
14518 -----------------------------
14519 -- Complete_Representation --
14520 -----------------------------
14522 -- pragma Complete_Representation;
14524 when Pragma_Complete_Representation =>
14526 Check_Arg_Count (0);
14528 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
14530 ("pragma & must appear within record representation clause");
14533 ----------------------------
14534 -- Complex_Representation --
14535 ----------------------------
14537 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14539 when Pragma_Complex_Representation => Complex_Representation : declare
14546 Check_Arg_Count (1);
14547 Check_Optional_Identifier (Arg1, Name_Entity);
14548 Check_Arg_Is_Local_Name (Arg1);
14549 E_Id := Get_Pragma_Arg (Arg1);
14551 if Etype (E_Id) = Any_Type then
14555 E := Entity (E_Id);
14557 if not Is_Record_Type (E) then
14559 ("argument for pragma% must be record type", Arg1);
14562 Ent := First_Entity (E);
14565 or else No (Next_Entity (Ent))
14566 or else Present (Next_Entity (Next_Entity (Ent)))
14567 or else not Is_Floating_Point_Type (Etype (Ent))
14568 or else Etype (Ent) /= Etype (Next_Entity (Ent))
14571 ("record for pragma% must have two fields of the same "
14572 & "floating-point type", Arg1);
14575 Set_Has_Complex_Representation (Base_Type (E));
14577 -- We need to treat the type has having a non-standard
14578 -- representation, for back-end purposes, even though in
14579 -- general a complex will have the default representation
14580 -- of a record with two real components.
14582 Set_Has_Non_Standard_Rep (Base_Type (E));
14584 end Complex_Representation;
14586 -------------------------
14587 -- Component_Alignment --
14588 -------------------------
14590 -- pragma Component_Alignment (
14591 -- [Form =>] ALIGNMENT_CHOICE
14592 -- [, [Name =>] type_LOCAL_NAME]);
14594 -- ALIGNMENT_CHOICE ::=
14596 -- | Component_Size_4
14600 when Pragma_Component_Alignment => Component_AlignmentP : declare
14601 Args : Args_List (1 .. 2);
14602 Names : constant Name_List (1 .. 2) := (
14606 Form : Node_Id renames Args (1);
14607 Name : Node_Id renames Args (2);
14609 Atype : Component_Alignment_Kind;
14614 Gather_Associations (Names, Args);
14617 Error_Pragma ("missing Form argument for pragma%");
14620 Check_Arg_Is_Identifier (Form);
14622 -- Get proper alignment, note that Default = Component_Size on all
14623 -- machines we have so far, and we want to set this value rather
14624 -- than the default value to indicate that it has been explicitly
14625 -- set (and thus will not get overridden by the default component
14626 -- alignment for the current scope)
14628 if Chars (Form) = Name_Component_Size then
14629 Atype := Calign_Component_Size;
14631 elsif Chars (Form) = Name_Component_Size_4 then
14632 Atype := Calign_Component_Size_4;
14634 elsif Chars (Form) = Name_Default then
14635 Atype := Calign_Component_Size;
14637 elsif Chars (Form) = Name_Storage_Unit then
14638 Atype := Calign_Storage_Unit;
14642 ("invalid Form parameter for pragma%", Form);
14645 -- The pragma appears in a configuration file
14647 if No (Parent (N)) then
14648 Check_Valid_Configuration_Pragma;
14650 -- Capture the component alignment in a global variable when
14651 -- the pragma appears in a configuration file. Note that the
14652 -- scope stack is empty at this point and cannot be used to
14653 -- store the alignment value.
14655 Configuration_Component_Alignment := Atype;
14657 -- Case with no name, supplied, affects scope table entry
14659 elsif No (Name) then
14661 (Scope_Stack.Last).Component_Alignment_Default := Atype;
14663 -- Case of name supplied
14666 Check_Arg_Is_Local_Name (Name);
14668 Typ := Entity (Name);
14671 or else Rep_Item_Too_Early (Typ, N)
14675 Typ := Underlying_Type (Typ);
14678 if not Is_Record_Type (Typ)
14679 and then not Is_Array_Type (Typ)
14682 ("Name parameter of pragma% must identify record or "
14683 & "array type", Name);
14686 -- An explicit Component_Alignment pragma overrides an
14687 -- implicit pragma Pack, but not an explicit one.
14689 if not Has_Pragma_Pack (Base_Type (Typ)) then
14690 Set_Is_Packed (Base_Type (Typ), False);
14691 Set_Component_Alignment (Base_Type (Typ), Atype);
14694 end Component_AlignmentP;
14696 --------------------------------
14697 -- Constant_After_Elaboration --
14698 --------------------------------
14700 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14702 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
14704 Obj_Decl : Node_Id;
14705 Obj_Id : Entity_Id;
14709 Check_No_Identifiers;
14710 Check_At_Most_N_Arguments (1);
14712 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
14714 if Nkind (Obj_Decl) /= N_Object_Declaration then
14719 Obj_Id := Defining_Entity (Obj_Decl);
14721 -- The object declaration must be a library-level variable which
14722 -- is either explicitly initialized or obtains a value during the
14723 -- elaboration of a package body (SPARK RM 3.3.1).
14725 if Ekind (Obj_Id) = E_Variable then
14726 if not Is_Library_Level_Entity (Obj_Id) then
14728 ("pragma % must apply to a library level variable");
14732 -- Otherwise the pragma applies to a constant, which is illegal
14735 Error_Pragma ("pragma % must apply to a variable declaration");
14739 -- A pragma that applies to a Ghost entity becomes Ghost for the
14740 -- purposes of legality checks and removal of ignored Ghost code.
14742 Mark_Ghost_Pragma (N, Obj_Id);
14744 -- Chain the pragma on the contract for completeness
14746 Add_Contract_Item (N, Obj_Id);
14748 -- Analyze the Boolean expression (if any)
14750 if Present (Arg1) then
14751 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
14753 end Constant_After_Elaboration;
14755 --------------------
14756 -- Contract_Cases --
14757 --------------------
14759 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14761 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14763 -- CASE_GUARD ::= boolean_EXPRESSION | others
14765 -- CONSEQUENCE ::= boolean_EXPRESSION
14767 -- Characteristics:
14769 -- * Analysis - The annotation undergoes initial checks to verify
14770 -- the legal placement and context. Secondary checks preanalyze the
14773 -- Analyze_Contract_Cases_In_Decl_Part
14775 -- * Expansion - The annotation is expanded during the expansion of
14776 -- the related subprogram [body] contract as performed in:
14778 -- Expand_Subprogram_Contract
14780 -- * Template - The annotation utilizes the generic template of the
14781 -- related subprogram [body] when it is:
14783 -- aspect on subprogram declaration
14784 -- aspect on stand-alone subprogram body
14785 -- pragma on stand-alone subprogram body
14787 -- The annotation must prepare its own template when it is:
14789 -- pragma on subprogram declaration
14791 -- * Globals - Capture of global references must occur after full
14794 -- * Instance - The annotation is instantiated automatically when
14795 -- the related generic subprogram [body] is instantiated except for
14796 -- the "pragma on subprogram declaration" case. In that scenario
14797 -- the annotation must instantiate itself.
14799 when Pragma_Contract_Cases => Contract_Cases : declare
14800 Spec_Id : Entity_Id;
14801 Subp_Decl : Node_Id;
14802 Subp_Spec : Node_Id;
14806 Check_No_Identifiers;
14807 Check_Arg_Count (1);
14809 -- Ensure the proper placement of the pragma. Contract_Cases must
14810 -- be associated with a subprogram declaration or a body that acts
14814 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14818 if Nkind (Subp_Decl) = N_Entry_Declaration then
14821 -- Generic subprogram
14823 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14826 -- Body acts as spec
14828 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14829 and then No (Corresponding_Spec (Subp_Decl))
14833 -- Body stub acts as spec
14835 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14836 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14842 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14843 Subp_Spec := Specification (Subp_Decl);
14845 -- Pragma Contract_Cases is forbidden on null procedures, as
14846 -- this may lead to potential ambiguities in behavior when
14847 -- interface null procedures are involved.
14849 if Nkind (Subp_Spec) = N_Procedure_Specification
14850 and then Null_Present (Subp_Spec)
14852 Error_Msg_N (Fix_Error
14853 ("pragma % cannot apply to null procedure"), N);
14862 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14864 -- A pragma that applies to a Ghost entity becomes Ghost for the
14865 -- purposes of legality checks and removal of ignored Ghost code.
14867 Mark_Ghost_Pragma (N, Spec_Id);
14868 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
14870 -- Chain the pragma on the contract for further processing by
14871 -- Analyze_Contract_Cases_In_Decl_Part.
14873 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14875 -- Fully analyze the pragma when it appears inside an entry
14876 -- or subprogram body because it cannot benefit from forward
14879 if Nkind_In (Subp_Decl, N_Entry_Body,
14881 N_Subprogram_Body_Stub)
14883 -- The legality checks of pragma Contract_Cases are affected by
14884 -- the SPARK mode in effect and the volatility of the context.
14885 -- Analyze all pragmas in a specific order.
14887 Analyze_If_Present (Pragma_SPARK_Mode);
14888 Analyze_If_Present (Pragma_Volatile_Function);
14889 Analyze_Contract_Cases_In_Decl_Part (N);
14891 end Contract_Cases;
14897 -- pragma Controlled (first_subtype_LOCAL_NAME);
14899 when Pragma_Controlled => Controlled : declare
14903 Check_No_Identifiers;
14904 Check_Arg_Count (1);
14905 Check_Arg_Is_Local_Name (Arg1);
14906 Arg := Get_Pragma_Arg (Arg1);
14908 if not Is_Entity_Name (Arg)
14909 or else not Is_Access_Type (Entity (Arg))
14911 Error_Pragma_Arg ("pragma% requires access type", Arg1);
14913 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
14921 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14922 -- [Entity =>] LOCAL_NAME);
14924 when Pragma_Convention => Convention : declare
14927 pragma Warnings (Off, C);
14928 pragma Warnings (Off, E);
14931 Check_Arg_Order ((Name_Convention, Name_Entity));
14932 Check_Ada_83_Warning;
14933 Check_Arg_Count (2);
14934 Process_Convention (C, E);
14936 -- A pragma that applies to a Ghost entity becomes Ghost for the
14937 -- purposes of legality checks and removal of ignored Ghost code.
14939 Mark_Ghost_Pragma (N, E);
14942 ---------------------------
14943 -- Convention_Identifier --
14944 ---------------------------
14946 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14947 -- [Convention =>] convention_IDENTIFIER);
14949 when Pragma_Convention_Identifier => Convention_Identifier : declare
14955 Check_Arg_Order ((Name_Name, Name_Convention));
14956 Check_Arg_Count (2);
14957 Check_Optional_Identifier (Arg1, Name_Name);
14958 Check_Optional_Identifier (Arg2, Name_Convention);
14959 Check_Arg_Is_Identifier (Arg1);
14960 Check_Arg_Is_Identifier (Arg2);
14961 Idnam := Chars (Get_Pragma_Arg (Arg1));
14962 Cname := Chars (Get_Pragma_Arg (Arg2));
14964 if Is_Convention_Name (Cname) then
14965 Record_Convention_Identifier
14966 (Idnam, Get_Convention_Id (Cname));
14969 ("second arg for % pragma must be convention", Arg2);
14971 end Convention_Identifier;
14977 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14979 when Pragma_CPP_Class =>
14982 if Warn_On_Obsolescent_Feature then
14984 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14985 & "effect; replace it by pragma import?j?", N);
14988 Check_Arg_Count (1);
14992 Chars => Name_Import,
14993 Pragma_Argument_Associations => New_List (
14994 Make_Pragma_Argument_Association (Loc,
14995 Expression => Make_Identifier (Loc, Name_CPP)),
14996 New_Copy (First (Pragma_Argument_Associations (N))))));
14999 ---------------------
15000 -- CPP_Constructor --
15001 ---------------------
15003 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
15004 -- [, [External_Name =>] static_string_EXPRESSION ]
15005 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15007 when Pragma_CPP_Constructor => CPP_Constructor : declare
15010 Def_Id : Entity_Id;
15011 Tag_Typ : Entity_Id;
15015 Check_At_Least_N_Arguments (1);
15016 Check_At_Most_N_Arguments (3);
15017 Check_Optional_Identifier (Arg1, Name_Entity);
15018 Check_Arg_Is_Local_Name (Arg1);
15020 Id := Get_Pragma_Arg (Arg1);
15021 Find_Program_Unit_Name (Id);
15023 -- If we did not find the name, we are done
15025 if Etype (Id) = Any_Type then
15029 Def_Id := Entity (Id);
15031 -- Check if already defined as constructor
15033 if Is_Constructor (Def_Id) then
15035 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
15039 if Ekind (Def_Id) = E_Function
15040 and then (Is_CPP_Class (Etype (Def_Id))
15041 or else (Is_Class_Wide_Type (Etype (Def_Id))
15043 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
15045 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
15047 ("'C'P'P constructor must be defined in the scope of "
15048 & "its returned type", Arg1);
15051 if Arg_Count >= 2 then
15052 Set_Imported (Def_Id);
15053 Set_Is_Public (Def_Id);
15054 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
15057 Set_Has_Completion (Def_Id);
15058 Set_Is_Constructor (Def_Id);
15059 Set_Convention (Def_Id, Convention_CPP);
15061 -- Imported C++ constructors are not dispatching primitives
15062 -- because in C++ they don't have a dispatch table slot.
15063 -- However, in Ada the constructor has the profile of a
15064 -- function that returns a tagged type and therefore it has
15065 -- been treated as a primitive operation during semantic
15066 -- analysis. We now remove it from the list of primitive
15067 -- operations of the type.
15069 if Is_Tagged_Type (Etype (Def_Id))
15070 and then not Is_Class_Wide_Type (Etype (Def_Id))
15071 and then Is_Dispatching_Operation (Def_Id)
15073 Tag_Typ := Etype (Def_Id);
15075 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
15076 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
15080 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
15081 Set_Is_Dispatching_Operation (Def_Id, False);
15084 -- For backward compatibility, if the constructor returns a
15085 -- class wide type, and we internally change the return type to
15086 -- the corresponding root type.
15088 if Is_Class_Wide_Type (Etype (Def_Id)) then
15089 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
15093 ("pragma% requires function returning a 'C'P'P_Class type",
15096 end CPP_Constructor;
15102 when Pragma_CPP_Virtual =>
15105 if Warn_On_Obsolescent_Feature then
15107 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15115 when Pragma_CPP_Vtable =>
15118 if Warn_On_Obsolescent_Feature then
15120 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15128 -- pragma CPU (EXPRESSION);
15130 when Pragma_CPU => CPU : declare
15131 P : constant Node_Id := Parent (N);
15137 Check_No_Identifiers;
15138 Check_Arg_Count (1);
15142 if Nkind (P) = N_Subprogram_Body then
15143 Check_In_Main_Program;
15145 Arg := Get_Pragma_Arg (Arg1);
15146 Analyze_And_Resolve (Arg, Any_Integer);
15148 Ent := Defining_Unit_Name (Specification (P));
15150 if Nkind (Ent) = N_Defining_Program_Unit_Name then
15151 Ent := Defining_Identifier (Ent);
15156 if not Is_OK_Static_Expression (Arg) then
15157 Flag_Non_Static_Expr
15158 ("main subprogram affinity is not static!", Arg);
15161 -- If constraint error, then we already signalled an error
15163 elsif Raises_Constraint_Error (Arg) then
15166 -- Otherwise check in range
15170 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
15171 -- This is the entity System.Multiprocessors.CPU_Range;
15173 Val : constant Uint := Expr_Value (Arg);
15176 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
15178 Val > Expr_Value (Type_High_Bound (CPU_Id))
15181 ("main subprogram CPU is out of range", Arg1);
15187 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
15191 elsif Nkind (P) = N_Task_Definition then
15192 Arg := Get_Pragma_Arg (Arg1);
15193 Ent := Defining_Identifier (Parent (P));
15195 -- The expression must be analyzed in the special manner
15196 -- described in "Handling of Default and Per-Object
15197 -- Expressions" in sem.ads.
15199 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
15201 -- Anything else is incorrect
15207 -- Check duplicate pragma before we chain the pragma in the Rep
15208 -- Item chain of Ent.
15210 Check_Duplicate_Pragma (Ent);
15211 Record_Rep_Item (Ent, N);
15214 --------------------
15215 -- Deadline_Floor --
15216 --------------------
15218 -- pragma Deadline_Floor (time_span_EXPRESSION);
15220 when Pragma_Deadline_Floor => Deadline_Floor : declare
15221 P : constant Node_Id := Parent (N);
15227 Check_No_Identifiers;
15228 Check_Arg_Count (1);
15230 Arg := Get_Pragma_Arg (Arg1);
15232 -- The expression must be analyzed in the special manner described
15233 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15235 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
15237 -- Only protected types allowed
15239 if Nkind (P) /= N_Protected_Definition then
15243 Ent := Defining_Identifier (Parent (P));
15245 -- Check duplicate pragma before we chain the pragma in the Rep
15246 -- Item chain of Ent.
15248 Check_Duplicate_Pragma (Ent);
15249 Record_Rep_Item (Ent, N);
15251 end Deadline_Floor;
15257 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15259 when Pragma_Debug => Debug : declare
15266 -- The condition for executing the call is that the expander
15267 -- is active and that we are not ignoring this debug pragma.
15272 (Expander_Active and then not Is_Ignored (N)),
15275 if not Is_Ignored (N) then
15276 Set_SCO_Pragma_Enabled (Loc);
15279 if Arg_Count = 2 then
15281 Make_And_Then (Loc,
15282 Left_Opnd => Relocate_Node (Cond),
15283 Right_Opnd => Get_Pragma_Arg (Arg1));
15284 Call := Get_Pragma_Arg (Arg2);
15286 Call := Get_Pragma_Arg (Arg1);
15289 if Nkind_In (Call, N_Expanded_Name,
15292 N_Indexed_Component,
15293 N_Selected_Component)
15295 -- If this pragma Debug comes from source, its argument was
15296 -- parsed as a name form (which is syntactically identical).
15297 -- In a generic context a parameterless call will be left as
15298 -- an expanded name (if global) or selected_component if local.
15299 -- Change it to a procedure call statement now.
15301 Change_Name_To_Procedure_Call_Statement (Call);
15303 elsif Nkind (Call) = N_Procedure_Call_Statement then
15305 -- Already in the form of a procedure call statement: nothing
15306 -- to do (could happen in case of an internally generated
15312 -- All other cases: diagnose error
15315 ("argument of pragma ""Debug"" is not procedure call",
15320 -- Rewrite into a conditional with an appropriate condition. We
15321 -- wrap the procedure call in a block so that overhead from e.g.
15322 -- use of the secondary stack does not generate execution overhead
15323 -- for suppressed conditions.
15325 -- Normally the analysis that follows will freeze the subprogram
15326 -- being called. However, if the call is to a null procedure,
15327 -- we want to freeze it before creating the block, because the
15328 -- analysis that follows may be done with expansion disabled, in
15329 -- which case the body will not be generated, leading to spurious
15332 if Nkind (Call) = N_Procedure_Call_Statement
15333 and then Is_Entity_Name (Name (Call))
15335 Analyze (Name (Call));
15336 Freeze_Before (N, Entity (Name (Call)));
15340 Make_Implicit_If_Statement (N,
15342 Then_Statements => New_List (
15343 Make_Block_Statement (Loc,
15344 Handled_Statement_Sequence =>
15345 Make_Handled_Sequence_Of_Statements (Loc,
15346 Statements => New_List (Relocate_Node (Call)))))));
15349 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15350 -- after analysis of the normally rewritten node, to capture all
15351 -- references to entities, which avoids issuing wrong warnings
15352 -- about unused entities.
15354 if GNATprove_Mode then
15355 Rewrite (N, Make_Null_Statement (Loc));
15363 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15365 when Pragma_Debug_Policy =>
15367 Check_Arg_Count (1);
15368 Check_No_Identifiers;
15369 Check_Arg_Is_Identifier (Arg1);
15371 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15372 -- rewrite it that way, and let the rest of the checking come
15373 -- from analyzing the rewritten pragma.
15377 Chars => Name_Check_Policy,
15378 Pragma_Argument_Associations => New_List (
15379 Make_Pragma_Argument_Association (Loc,
15380 Expression => Make_Identifier (Loc, Name_Debug)),
15382 Make_Pragma_Argument_Association (Loc,
15383 Expression => Get_Pragma_Arg (Arg1)))));
15386 -------------------------------
15387 -- Default_Initial_Condition --
15388 -------------------------------
15390 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15392 when Pragma_Default_Initial_Condition => DIC : declare
15399 Check_No_Identifiers;
15400 Check_At_Most_N_Arguments (1);
15404 while Present (Stmt) loop
15406 -- Skip prior pragmas, but check for duplicates
15408 if Nkind (Stmt) = N_Pragma then
15409 if Pragma_Name (Stmt) = Pname then
15416 -- Skip internally generated code. Note that derived type
15417 -- declarations of untagged types with discriminants are
15418 -- rewritten as private type declarations.
15420 elsif not Comes_From_Source (Stmt)
15421 and then Nkind (Stmt) /= N_Private_Type_Declaration
15425 -- The associated private type [extension] has been found, stop
15428 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
15429 N_Private_Type_Declaration)
15431 Typ := Defining_Entity (Stmt);
15434 -- The pragma does not apply to a legal construct, issue an
15435 -- error and stop the analysis.
15442 Stmt := Prev (Stmt);
15445 -- The pragma does not apply to a legal construct, issue an error
15446 -- and stop the analysis.
15453 -- A pragma that applies to a Ghost entity becomes Ghost for the
15454 -- purposes of legality checks and removal of ignored Ghost code.
15456 Mark_Ghost_Pragma (N, Typ);
15458 -- The pragma signals that the type defines its own DIC assertion
15461 Set_Has_Own_DIC (Typ);
15463 -- Chain the pragma on the rep item chain for further processing
15465 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
15467 -- Create the declaration of the procedure which verifies the
15468 -- assertion expression of pragma DIC at runtime.
15470 Build_DIC_Procedure_Declaration (Typ);
15473 ----------------------------------
15474 -- Default_Scalar_Storage_Order --
15475 ----------------------------------
15477 -- pragma Default_Scalar_Storage_Order
15478 -- (High_Order_First | Low_Order_First);
15480 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
15481 Default : Character;
15485 Check_Arg_Count (1);
15487 -- Default_Scalar_Storage_Order can appear as a configuration
15488 -- pragma, or in a declarative part of a package spec.
15490 if not Is_Configuration_Pragma then
15491 Check_Is_In_Decl_Part_Or_Package_Spec;
15494 Check_No_Identifiers;
15495 Check_Arg_Is_One_Of
15496 (Arg1, Name_High_Order_First, Name_Low_Order_First);
15497 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
15498 Default := Fold_Upper (Name_Buffer (1));
15500 if not Support_Nondefault_SSO_On_Target
15501 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
15503 if Warn_On_Unrecognized_Pragma then
15505 ("non-default Scalar_Storage_Order not supported "
15506 & "on target?g?", N);
15508 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
15511 -- Here set the specified default
15514 Opt.Default_SSO := Default;
15518 --------------------------
15519 -- Default_Storage_Pool --
15520 --------------------------
15522 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15524 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
15529 Check_Arg_Count (1);
15531 -- Default_Storage_Pool can appear as a configuration pragma, or
15532 -- in a declarative part of a package spec.
15534 if not Is_Configuration_Pragma then
15535 Check_Is_In_Decl_Part_Or_Package_Spec;
15538 if From_Aspect_Specification (N) then
15540 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
15542 if not In_Open_Scopes (E) then
15544 ("aspect must apply to package or subprogram", N);
15549 if Present (Arg1) then
15550 Pool := Get_Pragma_Arg (Arg1);
15552 -- Case of Default_Storage_Pool (null);
15554 if Nkind (Pool) = N_Null then
15557 -- This is an odd case, this is not really an expression,
15558 -- so we don't have a type for it. So just set the type to
15561 Set_Etype (Pool, Empty);
15563 -- Case of Default_Storage_Pool (storage_pool_NAME);
15566 -- If it's a configuration pragma, then the only allowed
15567 -- argument is "null".
15569 if Is_Configuration_Pragma then
15570 Error_Pragma_Arg ("NULL expected", Arg1);
15573 -- The expected type for a non-"null" argument is
15574 -- Root_Storage_Pool'Class, and the pool must be a variable.
15576 Analyze_And_Resolve
15577 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
15579 if Is_Variable (Pool) then
15581 -- A pragma that applies to a Ghost entity becomes Ghost
15582 -- for the purposes of legality checks and removal of
15583 -- ignored Ghost code.
15585 Mark_Ghost_Pragma (N, Entity (Pool));
15589 ("default storage pool must be a variable", Arg1);
15593 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15594 -- access type will use this information to set the appropriate
15595 -- attributes of the access type. If the pragma appears in a
15596 -- generic unit it is ignored, given that it may refer to a
15599 if not Inside_A_Generic then
15600 Default_Pool := Pool;
15603 end Default_Storage_Pool;
15609 -- pragma Depends (DEPENDENCY_RELATION);
15611 -- DEPENDENCY_RELATION ::=
15613 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15615 -- DEPENDENCY_CLAUSE ::=
15616 -- OUTPUT_LIST =>[+] INPUT_LIST
15617 -- | NULL_DEPENDENCY_CLAUSE
15619 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15621 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15623 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15625 -- OUTPUT ::= NAME | FUNCTION_RESULT
15628 -- where FUNCTION_RESULT is a function Result attribute_reference
15630 -- Characteristics:
15632 -- * Analysis - The annotation undergoes initial checks to verify
15633 -- the legal placement and context. Secondary checks fully analyze
15634 -- the dependency clauses in:
15636 -- Analyze_Depends_In_Decl_Part
15638 -- * Expansion - None.
15640 -- * Template - The annotation utilizes the generic template of the
15641 -- related subprogram [body] when it is:
15643 -- aspect on subprogram declaration
15644 -- aspect on stand-alone subprogram body
15645 -- pragma on stand-alone subprogram body
15647 -- The annotation must prepare its own template when it is:
15649 -- pragma on subprogram declaration
15651 -- * Globals - Capture of global references must occur after full
15654 -- * Instance - The annotation is instantiated automatically when
15655 -- the related generic subprogram [body] is instantiated except for
15656 -- the "pragma on subprogram declaration" case. In that scenario
15657 -- the annotation must instantiate itself.
15659 when Pragma_Depends => Depends : declare
15661 Spec_Id : Entity_Id;
15662 Subp_Decl : Node_Id;
15665 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15669 -- Chain the pragma on the contract for further processing by
15670 -- Analyze_Depends_In_Decl_Part.
15672 Add_Contract_Item (N, Spec_Id);
15674 -- Fully analyze the pragma when it appears inside an entry
15675 -- or subprogram body because it cannot benefit from forward
15678 if Nkind_In (Subp_Decl, N_Entry_Body,
15680 N_Subprogram_Body_Stub)
15682 -- The legality checks of pragmas Depends and Global are
15683 -- affected by the SPARK mode in effect and the volatility
15684 -- of the context. In addition these two pragmas are subject
15685 -- to an inherent order:
15690 -- Analyze all these pragmas in the order outlined above
15692 Analyze_If_Present (Pragma_SPARK_Mode);
15693 Analyze_If_Present (Pragma_Volatile_Function);
15694 Analyze_If_Present (Pragma_Global);
15695 Analyze_Depends_In_Decl_Part (N);
15700 ---------------------
15701 -- Detect_Blocking --
15702 ---------------------
15704 -- pragma Detect_Blocking;
15706 when Pragma_Detect_Blocking =>
15708 Check_Arg_Count (0);
15709 Check_Valid_Configuration_Pragma;
15710 Detect_Blocking := True;
15712 ------------------------------------
15713 -- Disable_Atomic_Synchronization --
15714 ------------------------------------
15716 -- pragma Disable_Atomic_Synchronization [(Entity)];
15718 when Pragma_Disable_Atomic_Synchronization =>
15720 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
15722 -------------------
15723 -- Discard_Names --
15724 -------------------
15726 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15728 when Pragma_Discard_Names => Discard_Names : declare
15733 Check_Ada_83_Warning;
15735 -- Deal with configuration pragma case
15737 if Arg_Count = 0 and then Is_Configuration_Pragma then
15738 Global_Discard_Names := True;
15741 -- Otherwise, check correct appropriate context
15744 Check_Is_In_Decl_Part_Or_Package_Spec;
15746 if Arg_Count = 0 then
15748 -- If there is no parameter, then from now on this pragma
15749 -- applies to any enumeration, exception or tagged type
15750 -- defined in the current declarative part, and recursively
15751 -- to any nested scope.
15753 Set_Discard_Names (Current_Scope);
15757 Check_Arg_Count (1);
15758 Check_Optional_Identifier (Arg1, Name_On);
15759 Check_Arg_Is_Local_Name (Arg1);
15761 E_Id := Get_Pragma_Arg (Arg1);
15763 if Etype (E_Id) = Any_Type then
15767 E := Entity (E_Id);
15769 -- A pragma that applies to a Ghost entity becomes Ghost for
15770 -- the purposes of legality checks and removal of ignored
15773 Mark_Ghost_Pragma (N, E);
15775 if (Is_First_Subtype (E)
15777 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
15778 or else Ekind (E) = E_Exception
15780 Set_Discard_Names (E);
15781 Record_Rep_Item (E, N);
15785 ("inappropriate entity for pragma%", Arg1);
15791 ------------------------
15792 -- Dispatching_Domain --
15793 ------------------------
15795 -- pragma Dispatching_Domain (EXPRESSION);
15797 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
15798 P : constant Node_Id := Parent (N);
15804 Check_No_Identifiers;
15805 Check_Arg_Count (1);
15807 -- This pragma is born obsolete, but not the aspect
15809 if not From_Aspect_Specification (N) then
15811 (No_Obsolescent_Features, Pragma_Identifier (N));
15814 if Nkind (P) = N_Task_Definition then
15815 Arg := Get_Pragma_Arg (Arg1);
15816 Ent := Defining_Identifier (Parent (P));
15818 -- A pragma that applies to a Ghost entity becomes Ghost for
15819 -- the purposes of legality checks and removal of ignored Ghost
15822 Mark_Ghost_Pragma (N, Ent);
15824 -- The expression must be analyzed in the special manner
15825 -- described in "Handling of Default and Per-Object
15826 -- Expressions" in sem.ads.
15828 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
15830 -- Check duplicate pragma before we chain the pragma in the Rep
15831 -- Item chain of Ent.
15833 Check_Duplicate_Pragma (Ent);
15834 Record_Rep_Item (Ent, N);
15836 -- Anything else is incorrect
15841 end Dispatching_Domain;
15847 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15849 when Pragma_Elaborate => Elaborate : declare
15854 -- Pragma must be in context items list of a compilation unit
15856 if not Is_In_Context_Clause then
15860 -- Must be at least one argument
15862 if Arg_Count = 0 then
15863 Error_Pragma ("pragma% requires at least one argument");
15866 -- In Ada 83 mode, there can be no items following it in the
15867 -- context list except other pragmas and implicit with clauses
15868 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15869 -- placement rule does not apply.
15871 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
15873 while Present (Citem) loop
15874 if Nkind (Citem) = N_Pragma
15875 or else (Nkind (Citem) = N_With_Clause
15876 and then Implicit_With (Citem))
15881 ("(Ada 83) pragma% must be at end of context clause");
15888 -- Finally, the arguments must all be units mentioned in a with
15889 -- clause in the same context clause. Note we already checked (in
15890 -- Par.Prag) that the arguments are all identifiers or selected
15894 Outer : while Present (Arg) loop
15895 Citem := First (List_Containing (N));
15896 Inner : while Citem /= N loop
15897 if Nkind (Citem) = N_With_Clause
15898 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15900 Set_Elaborate_Present (Citem, True);
15901 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15903 -- With the pragma present, elaboration calls on
15904 -- subprograms from the named unit need no further
15905 -- checks, as long as the pragma appears in the current
15906 -- compilation unit. If the pragma appears in some unit
15907 -- in the context, there might still be a need for an
15908 -- Elaborate_All_Desirable from the current compilation
15909 -- to the named unit, so we keep the check enabled. This
15910 -- does not apply in SPARK mode, where we allow pragma
15911 -- Elaborate, but we don't trust it to be right so we
15912 -- will still insist on the Elaborate_All.
15914 if Legacy_Elaboration_Checks
15915 and then In_Extended_Main_Source_Unit (N)
15916 and then SPARK_Mode /= On
15918 Set_Suppress_Elaboration_Warnings
15919 (Entity (Name (Citem)));
15930 ("argument of pragma% is not withed unit", Arg);
15937 -------------------
15938 -- Elaborate_All --
15939 -------------------
15941 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15943 when Pragma_Elaborate_All => Elaborate_All : declare
15948 Check_Ada_83_Warning;
15950 -- Pragma must be in context items list of a compilation unit
15952 if not Is_In_Context_Clause then
15956 -- Must be at least one argument
15958 if Arg_Count = 0 then
15959 Error_Pragma ("pragma% requires at least one argument");
15962 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15963 -- have to appear at the end of the context clause, but may
15964 -- appear mixed in with other items, even in Ada 83 mode.
15966 -- Final check: the arguments must all be units mentioned in
15967 -- a with clause in the same context clause. Note that we
15968 -- already checked (in Par.Prag) that all the arguments are
15969 -- either identifiers or selected components.
15972 Outr : while Present (Arg) loop
15973 Citem := First (List_Containing (N));
15974 Innr : while Citem /= N loop
15975 if Nkind (Citem) = N_With_Clause
15976 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
15978 Set_Elaborate_All_Present (Citem, True);
15979 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
15981 -- Suppress warnings and elaboration checks on the named
15982 -- unit if the pragma is in the current compilation, as
15983 -- for pragma Elaborate.
15985 if Legacy_Elaboration_Checks
15986 and then In_Extended_Main_Source_Unit (N)
15988 Set_Suppress_Elaboration_Warnings
15989 (Entity (Name (Citem)));
15999 Set_Error_Posted (N);
16001 ("argument of pragma% is not withed unit", Arg);
16008 --------------------
16009 -- Elaborate_Body --
16010 --------------------
16012 -- pragma Elaborate_Body [( library_unit_NAME )];
16014 when Pragma_Elaborate_Body => Elaborate_Body : declare
16015 Cunit_Node : Node_Id;
16016 Cunit_Ent : Entity_Id;
16019 Check_Ada_83_Warning;
16020 Check_Valid_Library_Unit_Pragma;
16022 if Nkind (N) = N_Null_Statement then
16026 Cunit_Node := Cunit (Current_Sem_Unit);
16027 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
16029 -- A pragma that applies to a Ghost entity becomes Ghost for the
16030 -- purposes of legality checks and removal of ignored Ghost code.
16032 Mark_Ghost_Pragma (N, Cunit_Ent);
16034 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
16037 Error_Pragma ("pragma% must refer to a spec, not a body");
16039 Set_Body_Required (Cunit_Node);
16040 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
16042 -- If we are in dynamic elaboration mode, then we suppress
16043 -- elaboration warnings for the unit, since it is definitely
16044 -- fine NOT to do dynamic checks at the first level (and such
16045 -- checks will be suppressed because no elaboration boolean
16046 -- is created for Elaborate_Body packages).
16048 -- But in the static model of elaboration, Elaborate_Body is
16049 -- definitely NOT good enough to ensure elaboration safety on
16050 -- its own, since the body may WITH other units that are not
16051 -- safe from an elaboration point of view, so a client must
16052 -- still do an Elaborate_All on such units.
16054 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16055 -- Elaborate_Body always suppressed elab warnings.
16057 if Legacy_Elaboration_Checks
16058 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD)
16060 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
16063 end Elaborate_Body;
16065 ------------------------
16066 -- Elaboration_Checks --
16067 ------------------------
16069 -- pragma Elaboration_Checks (Static | Dynamic);
16071 when Pragma_Elaboration_Checks => Elaboration_Checks : declare
16072 procedure Check_Duplicate_Elaboration_Checks_Pragma;
16073 -- Emit an error if the current context list already contains
16074 -- a previous Elaboration_Checks pragma. This routine raises
16075 -- Pragma_Exit if a duplicate is found.
16077 procedure Ignore_Elaboration_Checks_Pragma;
16078 -- Warn that the effects of the pragma are ignored. This routine
16079 -- raises Pragma_Exit.
16081 -----------------------------------------------
16082 -- Check_Duplicate_Elaboration_Checks_Pragma --
16083 -----------------------------------------------
16085 procedure Check_Duplicate_Elaboration_Checks_Pragma is
16090 while Present (Item) loop
16091 if Nkind (Item) = N_Pragma
16092 and then Pragma_Name (Item) = Name_Elaboration_Checks
16102 end Check_Duplicate_Elaboration_Checks_Pragma;
16104 --------------------------------------
16105 -- Ignore_Elaboration_Checks_Pragma --
16106 --------------------------------------
16108 procedure Ignore_Elaboration_Checks_Pragma is
16110 Error_Msg_Name_1 := Pname;
16111 Error_Msg_N ("??effects of pragma % are ignored", N);
16113 ("\place pragma on initial declaration of library unit", N);
16116 end Ignore_Elaboration_Checks_Pragma;
16120 Context : constant Node_Id := Parent (N);
16123 -- Start of processing for Elaboration_Checks
16127 Check_Arg_Count (1);
16128 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
16130 -- The pragma appears in a configuration file
16132 if No (Context) then
16133 Check_Valid_Configuration_Pragma;
16134 Check_Duplicate_Elaboration_Checks_Pragma;
16136 -- The pragma acts as a configuration pragma in a compilation unit
16138 -- pragma Elaboration_Checks (...);
16139 -- package Pack is ...;
16141 elsif Nkind (Context) = N_Compilation_Unit
16142 and then List_Containing (N) = Context_Items (Context)
16144 Check_Valid_Configuration_Pragma;
16145 Check_Duplicate_Elaboration_Checks_Pragma;
16147 Unt := Unit (Context);
16149 -- The pragma must appear on the initial declaration of a unit.
16150 -- If this is not the case, warn that the effects of the pragma
16153 if Nkind (Unt) = N_Package_Body then
16154 Ignore_Elaboration_Checks_Pragma;
16156 -- Check the Acts_As_Spec flag of the compilation units itself
16157 -- to determine whether the subprogram body completes since it
16158 -- has not been analyzed yet. This is safe because compilation
16159 -- units are not overloadable.
16161 elsif Nkind (Unt) = N_Subprogram_Body
16162 and then not Acts_As_Spec (Context)
16164 Ignore_Elaboration_Checks_Pragma;
16166 elsif Nkind (Unt) = N_Subunit then
16167 Ignore_Elaboration_Checks_Pragma;
16170 -- Otherwise the pragma does not appear at the configuration level
16177 -- At this point the pragma is not a duplicate, and appears in the
16178 -- proper context. Set the elaboration model in effect.
16180 Dynamic_Elaboration_Checks :=
16181 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
16182 end Elaboration_Checks;
16188 -- pragma Eliminate (
16189 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16190 -- [Entity =>] IDENTIFIER |
16191 -- SELECTED_COMPONENT |
16193 -- [, Source_Location => SOURCE_TRACE]);
16195 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16196 -- SOURCE_TRACE ::= STRING_LITERAL
16198 when Pragma_Eliminate => Eliminate : declare
16199 Args : Args_List (1 .. 5);
16200 Names : constant Name_List (1 .. 5) := (
16203 Name_Parameter_Types,
16205 Name_Source_Location);
16207 -- Note : Parameter_Types and Result_Type are leftovers from
16208 -- prior implementations of the pragma. They are not generated
16209 -- by the gnatelim tool, and play no role in selecting which
16210 -- of a set of overloaded names is chosen for elimination.
16212 Unit_Name : Node_Id renames Args (1);
16213 Entity : Node_Id renames Args (2);
16214 Parameter_Types : Node_Id renames Args (3);
16215 Result_Type : Node_Id renames Args (4);
16216 Source_Location : Node_Id renames Args (5);
16220 Check_Valid_Configuration_Pragma;
16221 Gather_Associations (Names, Args);
16223 if No (Unit_Name) then
16224 Error_Pragma ("missing Unit_Name argument for pragma%");
16228 and then (Present (Parameter_Types)
16230 Present (Result_Type)
16232 Present (Source_Location))
16234 Error_Pragma ("missing Entity argument for pragma%");
16237 if (Present (Parameter_Types)
16239 Present (Result_Type))
16241 Present (Source_Location)
16244 ("parameter profile and source location cannot be used "
16245 & "together in pragma%");
16248 Process_Eliminate_Pragma
16257 -----------------------------------
16258 -- Enable_Atomic_Synchronization --
16259 -----------------------------------
16261 -- pragma Enable_Atomic_Synchronization [(Entity)];
16263 when Pragma_Enable_Atomic_Synchronization =>
16265 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
16272 -- [ Convention =>] convention_IDENTIFIER,
16273 -- [ Entity =>] LOCAL_NAME
16274 -- [, [External_Name =>] static_string_EXPRESSION ]
16275 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16277 when Pragma_Export => Export : declare
16279 Def_Id : Entity_Id;
16281 pragma Warnings (Off, C);
16284 Check_Ada_83_Warning;
16288 Name_External_Name,
16291 Check_At_Least_N_Arguments (2);
16292 Check_At_Most_N_Arguments (4);
16294 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16295 -- pragma Export (Entity, "external name");
16297 if Relaxed_RM_Semantics
16298 and then Arg_Count = 2
16299 and then Nkind (Expression (Arg2)) = N_String_Literal
16302 Def_Id := Get_Pragma_Arg (Arg1);
16305 if not Is_Entity_Name (Def_Id) then
16306 Error_Pragma_Arg ("entity name required", Arg1);
16309 Def_Id := Entity (Def_Id);
16310 Set_Exported (Def_Id, Arg1);
16313 Process_Convention (C, Def_Id);
16315 -- A pragma that applies to a Ghost entity becomes Ghost for
16316 -- the purposes of legality checks and removal of ignored Ghost
16319 Mark_Ghost_Pragma (N, Def_Id);
16321 if Ekind (Def_Id) /= E_Constant then
16322 Note_Possible_Modification
16323 (Get_Pragma_Arg (Arg2), Sure => False);
16326 Process_Interface_Name (Def_Id, Arg3, Arg4, N);
16327 Set_Exported (Def_Id, Arg2);
16330 -- If the entity is a deferred constant, propagate the information
16331 -- to the full view, because gigi elaborates the full view only.
16333 if Ekind (Def_Id) = E_Constant
16334 and then Present (Full_View (Def_Id))
16337 Id2 : constant Entity_Id := Full_View (Def_Id);
16339 Set_Is_Exported (Id2, Is_Exported (Def_Id));
16340 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
16341 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
16346 ---------------------
16347 -- Export_Function --
16348 ---------------------
16350 -- pragma Export_Function (
16351 -- [Internal =>] LOCAL_NAME
16352 -- [, [External =>] EXTERNAL_SYMBOL]
16353 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16354 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16355 -- [, [Mechanism =>] MECHANISM]
16356 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16358 -- EXTERNAL_SYMBOL ::=
16360 -- | static_string_EXPRESSION
16362 -- PARAMETER_TYPES ::=
16364 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16366 -- TYPE_DESIGNATOR ::=
16368 -- | subtype_Name ' Access
16372 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16374 -- MECHANISM_ASSOCIATION ::=
16375 -- [formal_parameter_NAME =>] MECHANISM_NAME
16377 -- MECHANISM_NAME ::=
16381 when Pragma_Export_Function => Export_Function : declare
16382 Args : Args_List (1 .. 6);
16383 Names : constant Name_List (1 .. 6) := (
16386 Name_Parameter_Types,
16389 Name_Result_Mechanism);
16391 Internal : Node_Id renames Args (1);
16392 External : Node_Id renames Args (2);
16393 Parameter_Types : Node_Id renames Args (3);
16394 Result_Type : Node_Id renames Args (4);
16395 Mechanism : Node_Id renames Args (5);
16396 Result_Mechanism : Node_Id renames Args (6);
16400 Gather_Associations (Names, Args);
16401 Process_Extended_Import_Export_Subprogram_Pragma (
16402 Arg_Internal => Internal,
16403 Arg_External => External,
16404 Arg_Parameter_Types => Parameter_Types,
16405 Arg_Result_Type => Result_Type,
16406 Arg_Mechanism => Mechanism,
16407 Arg_Result_Mechanism => Result_Mechanism);
16408 end Export_Function;
16410 -------------------
16411 -- Export_Object --
16412 -------------------
16414 -- pragma Export_Object (
16415 -- [Internal =>] LOCAL_NAME
16416 -- [, [External =>] EXTERNAL_SYMBOL]
16417 -- [, [Size =>] EXTERNAL_SYMBOL]);
16419 -- EXTERNAL_SYMBOL ::=
16421 -- | static_string_EXPRESSION
16423 -- PARAMETER_TYPES ::=
16425 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16427 -- TYPE_DESIGNATOR ::=
16429 -- | subtype_Name ' Access
16433 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16435 -- MECHANISM_ASSOCIATION ::=
16436 -- [formal_parameter_NAME =>] MECHANISM_NAME
16438 -- MECHANISM_NAME ::=
16442 when Pragma_Export_Object => Export_Object : declare
16443 Args : Args_List (1 .. 3);
16444 Names : constant Name_List (1 .. 3) := (
16449 Internal : Node_Id renames Args (1);
16450 External : Node_Id renames Args (2);
16451 Size : Node_Id renames Args (3);
16455 Gather_Associations (Names, Args);
16456 Process_Extended_Import_Export_Object_Pragma (
16457 Arg_Internal => Internal,
16458 Arg_External => External,
16462 ----------------------
16463 -- Export_Procedure --
16464 ----------------------
16466 -- pragma Export_Procedure (
16467 -- [Internal =>] LOCAL_NAME
16468 -- [, [External =>] EXTERNAL_SYMBOL]
16469 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16470 -- [, [Mechanism =>] MECHANISM]);
16472 -- EXTERNAL_SYMBOL ::=
16474 -- | static_string_EXPRESSION
16476 -- PARAMETER_TYPES ::=
16478 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16480 -- TYPE_DESIGNATOR ::=
16482 -- | subtype_Name ' Access
16486 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16488 -- MECHANISM_ASSOCIATION ::=
16489 -- [formal_parameter_NAME =>] MECHANISM_NAME
16491 -- MECHANISM_NAME ::=
16495 when Pragma_Export_Procedure => Export_Procedure : declare
16496 Args : Args_List (1 .. 4);
16497 Names : constant Name_List (1 .. 4) := (
16500 Name_Parameter_Types,
16503 Internal : Node_Id renames Args (1);
16504 External : Node_Id renames Args (2);
16505 Parameter_Types : Node_Id renames Args (3);
16506 Mechanism : Node_Id renames Args (4);
16510 Gather_Associations (Names, Args);
16511 Process_Extended_Import_Export_Subprogram_Pragma (
16512 Arg_Internal => Internal,
16513 Arg_External => External,
16514 Arg_Parameter_Types => Parameter_Types,
16515 Arg_Mechanism => Mechanism);
16516 end Export_Procedure;
16522 -- pragma Export_Value (
16523 -- [Value =>] static_integer_EXPRESSION,
16524 -- [Link_Name =>] static_string_EXPRESSION);
16526 when Pragma_Export_Value =>
16528 Check_Arg_Order ((Name_Value, Name_Link_Name));
16529 Check_Arg_Count (2);
16531 Check_Optional_Identifier (Arg1, Name_Value);
16532 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16534 Check_Optional_Identifier (Arg2, Name_Link_Name);
16535 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16537 -----------------------------
16538 -- Export_Valued_Procedure --
16539 -----------------------------
16541 -- pragma Export_Valued_Procedure (
16542 -- [Internal =>] LOCAL_NAME
16543 -- [, [External =>] EXTERNAL_SYMBOL,]
16544 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16545 -- [, [Mechanism =>] MECHANISM]);
16547 -- EXTERNAL_SYMBOL ::=
16549 -- | static_string_EXPRESSION
16551 -- PARAMETER_TYPES ::=
16553 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16555 -- TYPE_DESIGNATOR ::=
16557 -- | subtype_Name ' Access
16561 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16563 -- MECHANISM_ASSOCIATION ::=
16564 -- [formal_parameter_NAME =>] MECHANISM_NAME
16566 -- MECHANISM_NAME ::=
16570 when Pragma_Export_Valued_Procedure =>
16571 Export_Valued_Procedure : declare
16572 Args : Args_List (1 .. 4);
16573 Names : constant Name_List (1 .. 4) := (
16576 Name_Parameter_Types,
16579 Internal : Node_Id renames Args (1);
16580 External : Node_Id renames Args (2);
16581 Parameter_Types : Node_Id renames Args (3);
16582 Mechanism : Node_Id renames Args (4);
16586 Gather_Associations (Names, Args);
16587 Process_Extended_Import_Export_Subprogram_Pragma (
16588 Arg_Internal => Internal,
16589 Arg_External => External,
16590 Arg_Parameter_Types => Parameter_Types,
16591 Arg_Mechanism => Mechanism);
16592 end Export_Valued_Procedure;
16594 -------------------
16595 -- Extend_System --
16596 -------------------
16598 -- pragma Extend_System ([Name =>] Identifier);
16600 when Pragma_Extend_System =>
16602 Check_Valid_Configuration_Pragma;
16603 Check_Arg_Count (1);
16604 Check_Optional_Identifier (Arg1, Name_Name);
16605 Check_Arg_Is_Identifier (Arg1);
16607 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
16610 and then Name_Buffer (1 .. 4) = "aux_"
16612 if Present (System_Extend_Pragma_Arg) then
16613 if Chars (Get_Pragma_Arg (Arg1)) =
16614 Chars (Expression (System_Extend_Pragma_Arg))
16618 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
16619 Error_Pragma ("pragma% conflicts with that #");
16623 System_Extend_Pragma_Arg := Arg1;
16625 if not GNAT_Mode then
16626 System_Extend_Unit := Arg1;
16630 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
16633 ------------------------
16634 -- Extensions_Allowed --
16635 ------------------------
16637 -- pragma Extensions_Allowed (ON | OFF);
16639 when Pragma_Extensions_Allowed =>
16641 Check_Arg_Count (1);
16642 Check_No_Identifiers;
16643 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
16645 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
16646 Extensions_Allowed := True;
16647 Ada_Version := Ada_Version_Type'Last;
16650 Extensions_Allowed := False;
16651 Ada_Version := Ada_Version_Explicit;
16652 Ada_Version_Pragma := Empty;
16655 ------------------------
16656 -- Extensions_Visible --
16657 ------------------------
16659 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16661 -- Characteristics:
16663 -- * Analysis - The annotation is fully analyzed immediately upon
16664 -- elaboration as its expression must be static.
16666 -- * Expansion - None.
16668 -- * Template - The annotation utilizes the generic template of the
16669 -- related subprogram [body] when it is:
16671 -- aspect on subprogram declaration
16672 -- aspect on stand-alone subprogram body
16673 -- pragma on stand-alone subprogram body
16675 -- The annotation must prepare its own template when it is:
16677 -- pragma on subprogram declaration
16679 -- * Globals - Capture of global references must occur after full
16682 -- * Instance - The annotation is instantiated automatically when
16683 -- the related generic subprogram [body] is instantiated except for
16684 -- the "pragma on subprogram declaration" case. In that scenario
16685 -- the annotation must instantiate itself.
16687 when Pragma_Extensions_Visible => Extensions_Visible : declare
16688 Formal : Entity_Id;
16689 Has_OK_Formal : Boolean := False;
16690 Spec_Id : Entity_Id;
16691 Subp_Decl : Node_Id;
16695 Check_No_Identifiers;
16696 Check_At_Most_N_Arguments (1);
16699 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
16701 -- Abstract subprogram declaration
16703 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
16706 -- Generic subprogram declaration
16708 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
16711 -- Body acts as spec
16713 elsif Nkind (Subp_Decl) = N_Subprogram_Body
16714 and then No (Corresponding_Spec (Subp_Decl))
16718 -- Body stub acts as spec
16720 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
16721 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
16725 -- Subprogram declaration
16727 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
16730 -- Otherwise the pragma is associated with an illegal construct
16733 Error_Pragma ("pragma % must apply to a subprogram");
16737 -- Mark the pragma as Ghost if the related subprogram is also
16738 -- Ghost. This also ensures that any expansion performed further
16739 -- below will produce Ghost nodes.
16741 Spec_Id := Unique_Defining_Entity (Subp_Decl);
16742 Mark_Ghost_Pragma (N, Spec_Id);
16744 -- Chain the pragma on the contract for completeness
16746 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
16748 -- The legality checks of pragma Extension_Visible are affected
16749 -- by the SPARK mode in effect. Analyze all pragmas in specific
16752 Analyze_If_Present (Pragma_SPARK_Mode);
16754 -- Examine the formals of the related subprogram
16756 Formal := First_Formal (Spec_Id);
16757 while Present (Formal) loop
16759 -- At least one of the formals is of a specific tagged type,
16760 -- the pragma is legal.
16762 if Is_Specific_Tagged_Type (Etype (Formal)) then
16763 Has_OK_Formal := True;
16766 -- A generic subprogram with at least one formal of a private
16767 -- type ensures the legality of the pragma because the actual
16768 -- may be specifically tagged. Note that this is verified by
16769 -- the check above at instantiation time.
16771 elsif Is_Private_Type (Etype (Formal))
16772 and then Is_Generic_Type (Etype (Formal))
16774 Has_OK_Formal := True;
16778 Next_Formal (Formal);
16781 if not Has_OK_Formal then
16782 Error_Msg_Name_1 := Pname;
16783 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
16785 ("\subprogram & lacks parameter of specific tagged or "
16786 & "generic private type", N, Spec_Id);
16791 -- Analyze the Boolean expression (if any)
16793 if Present (Arg1) then
16794 Check_Static_Boolean_Expression
16795 (Expression (Get_Argument (N, Spec_Id)));
16797 end Extensions_Visible;
16803 -- pragma External (
16804 -- [ Convention =>] convention_IDENTIFIER,
16805 -- [ Entity =>] LOCAL_NAME
16806 -- [, [External_Name =>] static_string_EXPRESSION ]
16807 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16809 when Pragma_External => External : declare
16812 pragma Warnings (Off, C);
16819 Name_External_Name,
16821 Check_At_Least_N_Arguments (2);
16822 Check_At_Most_N_Arguments (4);
16823 Process_Convention (C, E);
16825 -- A pragma that applies to a Ghost entity becomes Ghost for the
16826 -- purposes of legality checks and removal of ignored Ghost code.
16828 Mark_Ghost_Pragma (N, E);
16830 Note_Possible_Modification
16831 (Get_Pragma_Arg (Arg2), Sure => False);
16832 Process_Interface_Name (E, Arg3, Arg4, N);
16833 Set_Exported (E, Arg2);
16836 --------------------------
16837 -- External_Name_Casing --
16838 --------------------------
16840 -- pragma External_Name_Casing (
16841 -- UPPERCASE | LOWERCASE
16842 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16844 when Pragma_External_Name_Casing =>
16846 Check_No_Identifiers;
16848 if Arg_Count = 2 then
16849 Check_Arg_Is_One_Of
16850 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
16852 case Chars (Get_Pragma_Arg (Arg2)) is
16854 Opt.External_Name_Exp_Casing := As_Is;
16856 when Name_Uppercase =>
16857 Opt.External_Name_Exp_Casing := Uppercase;
16859 when Name_Lowercase =>
16860 Opt.External_Name_Exp_Casing := Lowercase;
16867 Check_Arg_Count (1);
16870 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
16872 case Chars (Get_Pragma_Arg (Arg1)) is
16873 when Name_Uppercase =>
16874 Opt.External_Name_Imp_Casing := Uppercase;
16876 when Name_Lowercase =>
16877 Opt.External_Name_Imp_Casing := Lowercase;
16887 -- pragma Fast_Math;
16889 when Pragma_Fast_Math =>
16891 Check_No_Identifiers;
16892 Check_Valid_Configuration_Pragma;
16895 --------------------------
16896 -- Favor_Top_Level --
16897 --------------------------
16899 -- pragma Favor_Top_Level (type_NAME);
16901 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
16906 Check_No_Identifiers;
16907 Check_Arg_Count (1);
16908 Check_Arg_Is_Local_Name (Arg1);
16909 Typ := Entity (Get_Pragma_Arg (Arg1));
16911 -- A pragma that applies to a Ghost entity becomes Ghost for the
16912 -- purposes of legality checks and removal of ignored Ghost code.
16914 Mark_Ghost_Pragma (N, Typ);
16916 -- If it's an access-to-subprogram type (in particular, not a
16917 -- subtype), set the flag on that type.
16919 if Is_Access_Subprogram_Type (Typ) then
16920 Set_Can_Use_Internal_Rep (Typ, False);
16922 -- Otherwise it's an error (name denotes the wrong sort of entity)
16926 ("access-to-subprogram type expected",
16927 Get_Pragma_Arg (Arg1));
16929 end Favor_Top_Level;
16931 ---------------------------
16932 -- Finalize_Storage_Only --
16933 ---------------------------
16935 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16937 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
16938 Assoc : constant Node_Id := Arg1;
16939 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
16944 Check_No_Identifiers;
16945 Check_Arg_Count (1);
16946 Check_Arg_Is_Local_Name (Arg1);
16948 Find_Type (Type_Id);
16949 Typ := Entity (Type_Id);
16952 or else Rep_Item_Too_Early (Typ, N)
16956 Typ := Underlying_Type (Typ);
16959 if not Is_Controlled (Typ) then
16960 Error_Pragma ("pragma% must specify controlled type");
16963 Check_First_Subtype (Arg1);
16965 if Finalize_Storage_Only (Typ) then
16966 Error_Pragma ("duplicate pragma%, only one allowed");
16968 elsif not Rep_Item_Too_Late (Typ, N) then
16969 Set_Finalize_Storage_Only (Base_Type (Typ), True);
16971 end Finalize_Storage;
16977 -- pragma Ghost [ (boolean_EXPRESSION) ];
16979 when Pragma_Ghost => Ghost : declare
16983 Orig_Stmt : Node_Id;
16984 Prev_Id : Entity_Id;
16989 Check_No_Identifiers;
16990 Check_At_Most_N_Arguments (1);
16994 while Present (Stmt) loop
16996 -- Skip prior pragmas, but check for duplicates
16998 if Nkind (Stmt) = N_Pragma then
16999 if Pragma_Name (Stmt) = Pname then
17006 -- Task unit declared without a definition cannot be subject to
17007 -- pragma Ghost (SPARK RM 6.9(19)).
17009 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
17010 N_Task_Type_Declaration)
17012 Error_Pragma ("pragma % cannot apply to a task type");
17015 -- Skip internally generated code
17017 elsif not Comes_From_Source (Stmt) then
17018 Orig_Stmt := Original_Node (Stmt);
17020 -- When pragma Ghost applies to an untagged derivation, the
17021 -- derivation is transformed into a [sub]type declaration.
17023 if Nkind_In (Stmt, N_Full_Type_Declaration,
17024 N_Subtype_Declaration)
17025 and then Comes_From_Source (Orig_Stmt)
17026 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
17027 and then Nkind (Type_Definition (Orig_Stmt)) =
17028 N_Derived_Type_Definition
17030 Id := Defining_Entity (Stmt);
17033 -- When pragma Ghost applies to an object declaration which
17034 -- is initialized by means of a function call that returns
17035 -- on the secondary stack, the object declaration becomes a
17038 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
17039 and then Comes_From_Source (Orig_Stmt)
17040 and then Nkind (Orig_Stmt) = N_Object_Declaration
17042 Id := Defining_Entity (Stmt);
17045 -- When pragma Ghost applies to an expression function, the
17046 -- expression function is transformed into a subprogram.
17048 elsif Nkind (Stmt) = N_Subprogram_Declaration
17049 and then Comes_From_Source (Orig_Stmt)
17050 and then Nkind (Orig_Stmt) = N_Expression_Function
17052 Id := Defining_Entity (Stmt);
17056 -- The pragma applies to a legal construct, stop the traversal
17058 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
17059 N_Full_Type_Declaration,
17060 N_Generic_Subprogram_Declaration,
17061 N_Object_Declaration,
17062 N_Private_Extension_Declaration,
17063 N_Private_Type_Declaration,
17064 N_Subprogram_Declaration,
17065 N_Subtype_Declaration)
17067 Id := Defining_Entity (Stmt);
17070 -- The pragma does not apply to a legal construct, issue an
17071 -- error and stop the analysis.
17075 ("pragma % must apply to an object, package, subprogram "
17080 Stmt := Prev (Stmt);
17083 Context := Parent (N);
17085 -- Handle compilation units
17087 if Nkind (Context) = N_Compilation_Unit_Aux then
17088 Context := Unit (Parent (Context));
17091 -- Protected and task types cannot be subject to pragma Ghost
17092 -- (SPARK RM 6.9(19)).
17094 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
17096 Error_Pragma ("pragma % cannot apply to a protected type");
17099 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
17100 Error_Pragma ("pragma % cannot apply to a task type");
17106 -- When pragma Ghost is associated with a [generic] package, it
17107 -- appears in the visible declarations.
17109 if Nkind (Context) = N_Package_Specification
17110 and then Present (Visible_Declarations (Context))
17111 and then List_Containing (N) = Visible_Declarations (Context)
17113 Id := Defining_Entity (Context);
17115 -- Pragma Ghost applies to a stand-alone subprogram body
17117 elsif Nkind (Context) = N_Subprogram_Body
17118 and then No (Corresponding_Spec (Context))
17120 Id := Defining_Entity (Context);
17122 -- Pragma Ghost applies to a subprogram declaration that acts
17123 -- as a compilation unit.
17125 elsif Nkind (Context) = N_Subprogram_Declaration then
17126 Id := Defining_Entity (Context);
17128 -- Pragma Ghost applies to a generic subprogram
17130 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then
17131 Id := Defining_Entity (Specification (Context));
17137 ("pragma % must apply to an object, package, subprogram or "
17142 -- Handle completions of types and constants that are subject to
17145 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
17146 Prev_Id := Incomplete_Or_Partial_View (Id);
17148 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
17149 Error_Msg_Name_1 := Pname;
17151 -- The full declaration of a deferred constant cannot be
17152 -- subject to pragma Ghost unless the deferred declaration
17153 -- is also Ghost (SPARK RM 6.9(9)).
17155 if Ekind (Prev_Id) = E_Constant then
17156 Error_Msg_Name_1 := Pname;
17157 Error_Msg_NE (Fix_Error
17158 ("pragma % must apply to declaration of deferred "
17159 & "constant &"), N, Id);
17162 -- Pragma Ghost may appear on the full view of an incomplete
17163 -- type because the incomplete declaration lacks aspects and
17164 -- cannot be subject to pragma Ghost.
17166 elsif Ekind (Prev_Id) = E_Incomplete_Type then
17169 -- The full declaration of a type cannot be subject to
17170 -- pragma Ghost unless the partial view is also Ghost
17171 -- (SPARK RM 6.9(9)).
17174 Error_Msg_NE (Fix_Error
17175 ("pragma % must apply to partial view of type &"),
17181 -- A synchronized object cannot be subject to pragma Ghost
17182 -- (SPARK RM 6.9(19)).
17184 elsif Ekind (Id) = E_Variable then
17185 if Is_Protected_Type (Etype (Id)) then
17186 Error_Pragma ("pragma % cannot apply to a protected object");
17189 elsif Is_Task_Type (Etype (Id)) then
17190 Error_Pragma ("pragma % cannot apply to a task object");
17195 -- Analyze the Boolean expression (if any)
17197 if Present (Arg1) then
17198 Expr := Get_Pragma_Arg (Arg1);
17200 Analyze_And_Resolve (Expr, Standard_Boolean);
17202 if Is_OK_Static_Expression (Expr) then
17204 -- "Ghostness" cannot be turned off once enabled within a
17205 -- region (SPARK RM 6.9(6)).
17207 if Is_False (Expr_Value (Expr))
17208 and then Ghost_Mode > None
17211 ("pragma % with value False cannot appear in enabled "
17216 -- Otherwie the expression is not static
17220 ("expression of pragma % must be static", Expr);
17225 Set_Is_Ghost_Entity (Id);
17232 -- pragma Global (GLOBAL_SPECIFICATION);
17234 -- GLOBAL_SPECIFICATION ::=
17237 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17239 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17241 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17242 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17243 -- GLOBAL_ITEM ::= NAME
17245 -- Characteristics:
17247 -- * Analysis - The annotation undergoes initial checks to verify
17248 -- the legal placement and context. Secondary checks fully analyze
17249 -- the dependency clauses in:
17251 -- Analyze_Global_In_Decl_Part
17253 -- * Expansion - None.
17255 -- * Template - The annotation utilizes the generic template of the
17256 -- related subprogram [body] when it is:
17258 -- aspect on subprogram declaration
17259 -- aspect on stand-alone subprogram body
17260 -- pragma on stand-alone subprogram body
17262 -- The annotation must prepare its own template when it is:
17264 -- pragma on subprogram declaration
17266 -- * Globals - Capture of global references must occur after full
17269 -- * Instance - The annotation is instantiated automatically when
17270 -- the related generic subprogram [body] is instantiated except for
17271 -- the "pragma on subprogram declaration" case. In that scenario
17272 -- the annotation must instantiate itself.
17274 when Pragma_Global => Global : declare
17276 Spec_Id : Entity_Id;
17277 Subp_Decl : Node_Id;
17280 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
17284 -- Chain the pragma on the contract for further processing by
17285 -- Analyze_Global_In_Decl_Part.
17287 Add_Contract_Item (N, Spec_Id);
17289 -- Fully analyze the pragma when it appears inside an entry
17290 -- or subprogram body because it cannot benefit from forward
17293 if Nkind_In (Subp_Decl, N_Entry_Body,
17295 N_Subprogram_Body_Stub)
17297 -- The legality checks of pragmas Depends and Global are
17298 -- affected by the SPARK mode in effect and the volatility
17299 -- of the context. In addition these two pragmas are subject
17300 -- to an inherent order:
17305 -- Analyze all these pragmas in the order outlined above
17307 Analyze_If_Present (Pragma_SPARK_Mode);
17308 Analyze_If_Present (Pragma_Volatile_Function);
17309 Analyze_Global_In_Decl_Part (N);
17310 Analyze_If_Present (Pragma_Depends);
17319 -- pragma Ident (static_string_EXPRESSION)
17321 -- Note: pragma Comment shares this processing. Pragma Ident is
17322 -- identical in effect to pragma Commment.
17324 when Pragma_Comment
17332 Check_Arg_Count (1);
17333 Check_No_Identifiers;
17334 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17337 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
17344 GP := Parent (Parent (N));
17346 if Nkind_In (GP, N_Package_Declaration,
17347 N_Generic_Package_Declaration)
17352 -- If we have a compilation unit, then record the ident value,
17353 -- checking for improper duplication.
17355 if Nkind (GP) = N_Compilation_Unit then
17356 CS := Ident_String (Current_Sem_Unit);
17358 if Present (CS) then
17360 -- If we have multiple instances, concatenate them, but
17361 -- not in ASIS, where we want the original tree.
17363 if not ASIS_Mode then
17364 Start_String (Strval (CS));
17365 Store_String_Char (' ');
17366 Store_String_Chars (Strval (Str));
17367 Set_Strval (CS, End_String);
17371 Set_Ident_String (Current_Sem_Unit, Str);
17374 -- For subunits, we just ignore the Ident, since in GNAT these
17375 -- are not separate object files, and hence not separate units
17376 -- in the unit table.
17378 elsif Nkind (GP) = N_Subunit then
17384 -------------------
17385 -- Ignore_Pragma --
17386 -------------------
17388 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17390 -- Entirely handled in the parser, nothing to do here
17392 when Pragma_Ignore_Pragma =>
17395 ----------------------------
17396 -- Implementation_Defined --
17397 ----------------------------
17399 -- pragma Implementation_Defined (LOCAL_NAME);
17401 -- Marks previously declared entity as implementation defined. For
17402 -- an overloaded entity, applies to the most recent homonym.
17404 -- pragma Implementation_Defined;
17406 -- The form with no arguments appears anywhere within a scope, most
17407 -- typically a package spec, and indicates that all entities that are
17408 -- defined within the package spec are Implementation_Defined.
17410 when Pragma_Implementation_Defined => Implementation_Defined : declare
17415 Check_No_Identifiers;
17417 -- Form with no arguments
17419 if Arg_Count = 0 then
17420 Set_Is_Implementation_Defined (Current_Scope);
17422 -- Form with one argument
17425 Check_Arg_Count (1);
17426 Check_Arg_Is_Local_Name (Arg1);
17427 Ent := Entity (Get_Pragma_Arg (Arg1));
17428 Set_Is_Implementation_Defined (Ent);
17430 end Implementation_Defined;
17436 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17438 -- IMPLEMENTATION_KIND ::=
17439 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17441 -- "By_Any" and "Optional" are treated as synonyms in order to
17442 -- support Ada 2012 aspect Synchronization.
17444 when Pragma_Implemented => Implemented : declare
17445 Proc_Id : Entity_Id;
17450 Check_Arg_Count (2);
17451 Check_No_Identifiers;
17452 Check_Arg_Is_Identifier (Arg1);
17453 Check_Arg_Is_Local_Name (Arg1);
17454 Check_Arg_Is_One_Of (Arg2,
17457 Name_By_Protected_Procedure,
17460 -- Extract the name of the local procedure
17462 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
17464 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17465 -- primitive procedure of a synchronized tagged type.
17467 if Ekind (Proc_Id) = E_Procedure
17468 and then Is_Primitive (Proc_Id)
17469 and then Present (First_Formal (Proc_Id))
17471 Typ := Etype (First_Formal (Proc_Id));
17473 if Is_Tagged_Type (Typ)
17476 -- Check for a protected, a synchronized or a task interface
17478 ((Is_Interface (Typ)
17479 and then Is_Synchronized_Interface (Typ))
17481 -- Check for a protected type or a task type that implements
17485 (Is_Concurrent_Record_Type (Typ)
17486 and then Present (Interfaces (Typ)))
17488 -- In analysis-only mode, examine original protected type
17491 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
17492 and then Present (Interface_List (Parent (Typ))))
17494 -- Check for a private record extension with keyword
17498 (Ekind_In (Typ, E_Record_Type_With_Private,
17499 E_Record_Subtype_With_Private)
17500 and then Synchronized_Present (Parent (Typ))))
17505 ("controlling formal must be of synchronized tagged type",
17510 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17511 -- By_Protected_Procedure to the primitive procedure of a task
17514 if Chars (Arg2) = Name_By_Protected_Procedure
17515 and then Is_Interface (Typ)
17516 and then Is_Task_Interface (Typ)
17519 ("implementation kind By_Protected_Procedure cannot be "
17520 & "applied to a task interface primitive", Arg2);
17524 -- Procedures declared inside a protected type must be accepted
17526 elsif Ekind (Proc_Id) = E_Procedure
17527 and then Is_Protected_Type (Scope (Proc_Id))
17531 -- The first argument is not a primitive procedure
17535 ("pragma % must be applied to a primitive procedure", Arg1);
17539 Record_Rep_Item (Proc_Id, N);
17542 ----------------------
17543 -- Implicit_Packing --
17544 ----------------------
17546 -- pragma Implicit_Packing;
17548 when Pragma_Implicit_Packing =>
17550 Check_Arg_Count (0);
17551 Implicit_Packing := True;
17558 -- [Convention =>] convention_IDENTIFIER,
17559 -- [Entity =>] LOCAL_NAME
17560 -- [, [External_Name =>] static_string_EXPRESSION ]
17561 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17563 when Pragma_Import =>
17564 Check_Ada_83_Warning;
17568 Name_External_Name,
17571 Check_At_Least_N_Arguments (2);
17572 Check_At_Most_N_Arguments (4);
17573 Process_Import_Or_Interface;
17575 ---------------------
17576 -- Import_Function --
17577 ---------------------
17579 -- pragma Import_Function (
17580 -- [Internal =>] LOCAL_NAME,
17581 -- [, [External =>] EXTERNAL_SYMBOL]
17582 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17583 -- [, [Result_Type =>] SUBTYPE_MARK]
17584 -- [, [Mechanism =>] MECHANISM]
17585 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17587 -- EXTERNAL_SYMBOL ::=
17589 -- | static_string_EXPRESSION
17591 -- PARAMETER_TYPES ::=
17593 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17595 -- TYPE_DESIGNATOR ::=
17597 -- | subtype_Name ' Access
17601 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17603 -- MECHANISM_ASSOCIATION ::=
17604 -- [formal_parameter_NAME =>] MECHANISM_NAME
17606 -- MECHANISM_NAME ::=
17610 when Pragma_Import_Function => Import_Function : declare
17611 Args : Args_List (1 .. 6);
17612 Names : constant Name_List (1 .. 6) := (
17615 Name_Parameter_Types,
17618 Name_Result_Mechanism);
17620 Internal : Node_Id renames Args (1);
17621 External : Node_Id renames Args (2);
17622 Parameter_Types : Node_Id renames Args (3);
17623 Result_Type : Node_Id renames Args (4);
17624 Mechanism : Node_Id renames Args (5);
17625 Result_Mechanism : Node_Id renames Args (6);
17629 Gather_Associations (Names, Args);
17630 Process_Extended_Import_Export_Subprogram_Pragma (
17631 Arg_Internal => Internal,
17632 Arg_External => External,
17633 Arg_Parameter_Types => Parameter_Types,
17634 Arg_Result_Type => Result_Type,
17635 Arg_Mechanism => Mechanism,
17636 Arg_Result_Mechanism => Result_Mechanism);
17637 end Import_Function;
17639 -------------------
17640 -- Import_Object --
17641 -------------------
17643 -- pragma Import_Object (
17644 -- [Internal =>] LOCAL_NAME
17645 -- [, [External =>] EXTERNAL_SYMBOL]
17646 -- [, [Size =>] EXTERNAL_SYMBOL]);
17648 -- EXTERNAL_SYMBOL ::=
17650 -- | static_string_EXPRESSION
17652 when Pragma_Import_Object => Import_Object : declare
17653 Args : Args_List (1 .. 3);
17654 Names : constant Name_List (1 .. 3) := (
17659 Internal : Node_Id renames Args (1);
17660 External : Node_Id renames Args (2);
17661 Size : Node_Id renames Args (3);
17665 Gather_Associations (Names, Args);
17666 Process_Extended_Import_Export_Object_Pragma (
17667 Arg_Internal => Internal,
17668 Arg_External => External,
17672 ----------------------
17673 -- Import_Procedure --
17674 ----------------------
17676 -- pragma Import_Procedure (
17677 -- [Internal =>] LOCAL_NAME
17678 -- [, [External =>] EXTERNAL_SYMBOL]
17679 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17680 -- [, [Mechanism =>] MECHANISM]);
17682 -- EXTERNAL_SYMBOL ::=
17684 -- | static_string_EXPRESSION
17686 -- PARAMETER_TYPES ::=
17688 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17690 -- TYPE_DESIGNATOR ::=
17692 -- | subtype_Name ' Access
17696 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17698 -- MECHANISM_ASSOCIATION ::=
17699 -- [formal_parameter_NAME =>] MECHANISM_NAME
17701 -- MECHANISM_NAME ::=
17705 when Pragma_Import_Procedure => Import_Procedure : declare
17706 Args : Args_List (1 .. 4);
17707 Names : constant Name_List (1 .. 4) := (
17710 Name_Parameter_Types,
17713 Internal : Node_Id renames Args (1);
17714 External : Node_Id renames Args (2);
17715 Parameter_Types : Node_Id renames Args (3);
17716 Mechanism : Node_Id renames Args (4);
17720 Gather_Associations (Names, Args);
17721 Process_Extended_Import_Export_Subprogram_Pragma (
17722 Arg_Internal => Internal,
17723 Arg_External => External,
17724 Arg_Parameter_Types => Parameter_Types,
17725 Arg_Mechanism => Mechanism);
17726 end Import_Procedure;
17728 -----------------------------
17729 -- Import_Valued_Procedure --
17730 -----------------------------
17732 -- pragma Import_Valued_Procedure (
17733 -- [Internal =>] LOCAL_NAME
17734 -- [, [External =>] EXTERNAL_SYMBOL]
17735 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17736 -- [, [Mechanism =>] MECHANISM]);
17738 -- EXTERNAL_SYMBOL ::=
17740 -- | static_string_EXPRESSION
17742 -- PARAMETER_TYPES ::=
17744 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17746 -- TYPE_DESIGNATOR ::=
17748 -- | subtype_Name ' Access
17752 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17754 -- MECHANISM_ASSOCIATION ::=
17755 -- [formal_parameter_NAME =>] MECHANISM_NAME
17757 -- MECHANISM_NAME ::=
17761 when Pragma_Import_Valued_Procedure =>
17762 Import_Valued_Procedure : declare
17763 Args : Args_List (1 .. 4);
17764 Names : constant Name_List (1 .. 4) := (
17767 Name_Parameter_Types,
17770 Internal : Node_Id renames Args (1);
17771 External : Node_Id renames Args (2);
17772 Parameter_Types : Node_Id renames Args (3);
17773 Mechanism : Node_Id renames Args (4);
17777 Gather_Associations (Names, Args);
17778 Process_Extended_Import_Export_Subprogram_Pragma (
17779 Arg_Internal => Internal,
17780 Arg_External => External,
17781 Arg_Parameter_Types => Parameter_Types,
17782 Arg_Mechanism => Mechanism);
17783 end Import_Valued_Procedure;
17789 -- pragma Independent (LOCAL_NAME);
17791 when Pragma_Independent =>
17792 Process_Atomic_Independent_Shared_Volatile;
17794 ----------------------------
17795 -- Independent_Components --
17796 ----------------------------
17798 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17800 when Pragma_Independent_Components => Independent_Components : declare
17808 Check_Ada_83_Warning;
17810 Check_No_Identifiers;
17811 Check_Arg_Count (1);
17812 Check_Arg_Is_Local_Name (Arg1);
17813 E_Id := Get_Pragma_Arg (Arg1);
17815 if Etype (E_Id) = Any_Type then
17819 E := Entity (E_Id);
17821 -- A record type with a self-referential component of anonymous
17822 -- access type is given an incomplete view in order to handle the
17825 -- type Rec is record
17826 -- Self : access Rec;
17832 -- type Ptr is access Rec;
17833 -- type Rec is record
17837 -- Since the incomplete view is now the initial view of the type,
17838 -- the argument of the pragma will reference the incomplete view,
17839 -- but this view is illegal according to the semantics of the
17842 -- Obtain the full view of an internally-generated incomplete type
17843 -- only. This way an attempt to associate the pragma with a source
17844 -- incomplete type is still caught.
17846 if Ekind (E) = E_Incomplete_Type
17847 and then not Comes_From_Source (E)
17848 and then Present (Full_View (E))
17850 E := Full_View (E);
17853 -- A pragma that applies to a Ghost entity becomes Ghost for the
17854 -- purposes of legality checks and removal of ignored Ghost code.
17856 Mark_Ghost_Pragma (N, E);
17858 -- Check duplicate before we chain ourselves
17860 Check_Duplicate_Pragma (E);
17862 -- Check appropriate entity
17864 if Rep_Item_Too_Early (E, N)
17866 Rep_Item_Too_Late (E, N)
17871 D := Declaration_Node (E);
17874 -- The flag is set on the base type, or on the object
17876 if K = N_Full_Type_Declaration
17877 and then (Is_Array_Type (E) or else Is_Record_Type (E))
17879 Set_Has_Independent_Components (Base_Type (E));
17880 Record_Independence_Check (N, Base_Type (E));
17882 -- For record type, set all components independent
17884 if Is_Record_Type (E) then
17885 C := First_Component (E);
17886 while Present (C) loop
17887 Set_Is_Independent (C);
17888 Next_Component (C);
17892 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
17893 and then Nkind (D) = N_Object_Declaration
17894 and then Nkind (Object_Definition (D)) =
17895 N_Constrained_Array_Definition
17897 Set_Has_Independent_Components (E);
17898 Record_Independence_Check (N, E);
17901 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
17903 end Independent_Components;
17905 -----------------------
17906 -- Initial_Condition --
17907 -----------------------
17909 -- pragma Initial_Condition (boolean_EXPRESSION);
17911 -- Characteristics:
17913 -- * Analysis - The annotation undergoes initial checks to verify
17914 -- the legal placement and context. Secondary checks preanalyze the
17917 -- Analyze_Initial_Condition_In_Decl_Part
17919 -- * Expansion - The annotation is expanded during the expansion of
17920 -- the package body whose declaration is subject to the annotation
17923 -- Expand_Pragma_Initial_Condition
17925 -- * Template - The annotation utilizes the generic template of the
17926 -- related package declaration.
17928 -- * Globals - Capture of global references must occur after full
17931 -- * Instance - The annotation is instantiated automatically when
17932 -- the related generic package is instantiated.
17934 when Pragma_Initial_Condition => Initial_Condition : declare
17935 Pack_Decl : Node_Id;
17936 Pack_Id : Entity_Id;
17940 Check_No_Identifiers;
17941 Check_Arg_Count (1);
17943 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
17945 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
17946 N_Package_Declaration)
17952 Pack_Id := Defining_Entity (Pack_Decl);
17954 -- A pragma that applies to a Ghost entity becomes Ghost for the
17955 -- purposes of legality checks and removal of ignored Ghost code.
17957 Mark_Ghost_Pragma (N, Pack_Id);
17959 -- Chain the pragma on the contract for further processing by
17960 -- Analyze_Initial_Condition_In_Decl_Part.
17962 Add_Contract_Item (N, Pack_Id);
17964 -- The legality checks of pragmas Abstract_State, Initializes, and
17965 -- Initial_Condition are affected by the SPARK mode in effect. In
17966 -- addition, these three pragmas are subject to an inherent order:
17968 -- 1) Abstract_State
17970 -- 3) Initial_Condition
17972 -- Analyze all these pragmas in the order outlined above
17974 Analyze_If_Present (Pragma_SPARK_Mode);
17975 Analyze_If_Present (Pragma_Abstract_State);
17976 Analyze_If_Present (Pragma_Initializes);
17977 end Initial_Condition;
17979 ------------------------
17980 -- Initialize_Scalars --
17981 ------------------------
17983 -- pragma Initialize_Scalars
17984 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17986 -- TYPE_VALUE_PAIR ::=
17987 -- SCALAR_TYPE => static_EXPRESSION
17993 -- | Long_Long_Flat
18003 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
18004 Seen : array (Scalar_Id) of Node_Id := (others => Empty);
18005 -- This collection holds the individual pairs which specify the
18006 -- invalid values of their respective scalar types.
18008 procedure Analyze_Float_Value
18009 (Scal_Typ : Float_Scalar_Id;
18010 Val_Expr : Node_Id);
18011 -- Analyze a type value pair associated with float type Scal_Typ
18012 -- and expression Val_Expr.
18014 procedure Analyze_Integer_Value
18015 (Scal_Typ : Integer_Scalar_Id;
18016 Val_Expr : Node_Id);
18017 -- Analyze a type value pair associated with integer type Scal_Typ
18018 -- and expression Val_Expr.
18020 procedure Analyze_Type_Value_Pair (Pair : Node_Id);
18021 -- Analyze type value pair Pair
18023 -------------------------
18024 -- Analyze_Float_Value --
18025 -------------------------
18027 procedure Analyze_Float_Value
18028 (Scal_Typ : Float_Scalar_Id;
18029 Val_Expr : Node_Id)
18032 Analyze_And_Resolve (Val_Expr, Any_Real);
18034 if Is_OK_Static_Expression (Val_Expr) then
18035 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
18038 Error_Msg_Name_1 := Scal_Typ;
18039 Error_Msg_N ("value for type % must be static", Val_Expr);
18041 end Analyze_Float_Value;
18043 ---------------------------
18044 -- Analyze_Integer_Value --
18045 ---------------------------
18047 procedure Analyze_Integer_Value
18048 (Scal_Typ : Integer_Scalar_Id;
18049 Val_Expr : Node_Id)
18052 Analyze_And_Resolve (Val_Expr, Any_Integer);
18054 if Is_OK_Static_Expression (Val_Expr) then
18055 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
18058 Error_Msg_Name_1 := Scal_Typ;
18059 Error_Msg_N ("value for type % must be static", Val_Expr);
18061 end Analyze_Integer_Value;
18063 -----------------------------
18064 -- Analyze_Type_Value_Pair --
18065 -----------------------------
18067 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
18068 Scal_Typ : constant Name_Id := Chars (Pair);
18069 Val_Expr : constant Node_Id := Expression (Pair);
18070 Prev_Pair : Node_Id;
18073 if Scal_Typ in Scalar_Id then
18074 Prev_Pair := Seen (Scal_Typ);
18076 -- Prevent multiple attempts to set a value for a scalar
18079 if Present (Prev_Pair) then
18080 Error_Msg_Name_1 := Scal_Typ;
18082 ("cannot specify multiple invalid values for type %",
18085 Error_Msg_Sloc := Sloc (Prev_Pair);
18086 Error_Msg_N ("previous value set #", Pair);
18088 -- Ignore the effects of the pair, but do not halt the
18089 -- analysis of the pragma altogether.
18093 -- Otherwise capture the first pair for this scalar type
18096 Seen (Scal_Typ) := Pair;
18099 if Scal_Typ in Float_Scalar_Id then
18100 Analyze_Float_Value (Scal_Typ, Val_Expr);
18102 else pragma Assert (Scal_Typ in Integer_Scalar_Id);
18103 Analyze_Integer_Value (Scal_Typ, Val_Expr);
18106 -- Otherwise the scalar family is illegal
18109 Error_Msg_Name_1 := Pname;
18111 ("argument of pragma % must denote valid scalar family",
18114 end Analyze_Type_Value_Pair;
18118 Pairs : constant List_Id := Pragma_Argument_Associations (N);
18121 -- Start of processing for Do_Initialize_Scalars
18125 Check_Valid_Configuration_Pragma;
18126 Check_Restriction (No_Initialize_Scalars, N);
18128 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18131 if Restriction_Active (No_Initialize_Scalars) then
18134 -- Initialize_Scalars creates false positives in CodePeer, and
18135 -- incorrect negative results in GNATprove mode, so ignore this
18136 -- pragma in these modes.
18138 elsif CodePeer_Mode or GNATprove_Mode then
18141 -- Otherwise analyze the pragma
18144 if Present (Pairs) then
18146 -- Install Standard in order to provide access to primitive
18147 -- types in case the expressions contain attributes such as
18150 Push_Scope (Standard_Standard);
18152 Pair := First (Pairs);
18153 while Present (Pair) loop
18154 Analyze_Type_Value_Pair (Pair);
18163 Init_Or_Norm_Scalars := True;
18164 Initialize_Scalars := True;
18166 end Do_Initialize_Scalars;
18172 -- pragma Initializes (INITIALIZATION_LIST);
18174 -- INITIALIZATION_LIST ::=
18176 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18178 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18183 -- | (INPUT {, INPUT})
18187 -- Characteristics:
18189 -- * Analysis - The annotation undergoes initial checks to verify
18190 -- the legal placement and context. Secondary checks preanalyze the
18193 -- Analyze_Initializes_In_Decl_Part
18195 -- * Expansion - None.
18197 -- * Template - The annotation utilizes the generic template of the
18198 -- related package declaration.
18200 -- * Globals - Capture of global references must occur after full
18203 -- * Instance - The annotation is instantiated automatically when
18204 -- the related generic package is instantiated.
18206 when Pragma_Initializes => Initializes : declare
18207 Pack_Decl : Node_Id;
18208 Pack_Id : Entity_Id;
18212 Check_No_Identifiers;
18213 Check_Arg_Count (1);
18215 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
18217 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
18218 N_Package_Declaration)
18224 Pack_Id := Defining_Entity (Pack_Decl);
18226 -- A pragma that applies to a Ghost entity becomes Ghost for the
18227 -- purposes of legality checks and removal of ignored Ghost code.
18229 Mark_Ghost_Pragma (N, Pack_Id);
18230 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
18232 -- Chain the pragma on the contract for further processing by
18233 -- Analyze_Initializes_In_Decl_Part.
18235 Add_Contract_Item (N, Pack_Id);
18237 -- The legality checks of pragmas Abstract_State, Initializes, and
18238 -- Initial_Condition are affected by the SPARK mode in effect. In
18239 -- addition, these three pragmas are subject to an inherent order:
18241 -- 1) Abstract_State
18243 -- 3) Initial_Condition
18245 -- Analyze all these pragmas in the order outlined above
18247 Analyze_If_Present (Pragma_SPARK_Mode);
18248 Analyze_If_Present (Pragma_Abstract_State);
18249 Analyze_If_Present (Pragma_Initial_Condition);
18256 -- pragma Inline ( NAME {, NAME} );
18258 when Pragma_Inline =>
18260 -- Pragma always active unless in GNATprove mode. It is disabled
18261 -- in GNATprove mode because frontend inlining is applied
18262 -- independently of pragmas Inline and Inline_Always for
18263 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18266 if not GNATprove_Mode then
18268 -- Inline status is Enabled if option -gnatn is specified.
18269 -- However this status determines only the value of the
18270 -- Is_Inlined flag on the subprogram and does not prevent
18271 -- the pragma itself from being recorded for later use,
18272 -- in particular for a later modification of Is_Inlined
18273 -- independently of the -gnatn option.
18275 -- In other words, if -gnatn is specified for a unit, then
18276 -- all Inline pragmas processed for the compilation of this
18277 -- unit, including those in the spec of other units, are
18278 -- activated, so subprograms will be inlined across units.
18280 -- If -gnatn is not specified, no Inline pragma is activated
18281 -- here, which means that subprograms will not be inlined
18282 -- across units. The Is_Inlined flag will nevertheless be
18283 -- set later when bodies are analyzed, so subprograms will
18284 -- be inlined within the unit.
18286 if Inline_Active then
18287 Process_Inline (Enabled);
18289 Process_Inline (Disabled);
18293 -------------------
18294 -- Inline_Always --
18295 -------------------
18297 -- pragma Inline_Always ( NAME {, NAME} );
18299 when Pragma_Inline_Always =>
18302 -- Pragma always active unless in CodePeer mode or GNATprove
18303 -- mode. It is disabled in CodePeer mode because inlining is
18304 -- not helpful, and enabling it caused walk order issues. It
18305 -- is disabled in GNATprove mode because frontend inlining is
18306 -- applied independently of pragmas Inline and Inline_Always for
18307 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18310 if not CodePeer_Mode and not GNATprove_Mode then
18311 Process_Inline (Enabled);
18314 --------------------
18315 -- Inline_Generic --
18316 --------------------
18318 -- pragma Inline_Generic (NAME {, NAME});
18320 when Pragma_Inline_Generic =>
18322 Process_Generic_List;
18324 ----------------------
18325 -- Inspection_Point --
18326 ----------------------
18328 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18330 when Pragma_Inspection_Point => Inspection_Point : declare
18337 if Arg_Count > 0 then
18340 Exp := Get_Pragma_Arg (Arg);
18343 if not Is_Entity_Name (Exp)
18344 or else not Is_Object (Entity (Exp))
18346 Error_Pragma_Arg ("object name required", Arg);
18350 exit when No (Arg);
18353 end Inspection_Point;
18359 -- pragma Interface (
18360 -- [ Convention =>] convention_IDENTIFIER,
18361 -- [ Entity =>] LOCAL_NAME
18362 -- [, [External_Name =>] static_string_EXPRESSION ]
18363 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18365 when Pragma_Interface =>
18370 Name_External_Name,
18372 Check_At_Least_N_Arguments (2);
18373 Check_At_Most_N_Arguments (4);
18374 Process_Import_Or_Interface;
18376 -- In Ada 2005, the permission to use Interface (a reserved word)
18377 -- as a pragma name is considered an obsolescent feature, and this
18378 -- pragma was already obsolescent in Ada 95.
18380 if Ada_Version >= Ada_95 then
18382 (No_Obsolescent_Features, Pragma_Identifier (N));
18384 if Warn_On_Obsolescent_Feature then
18386 ("pragma Interface is an obsolescent feature?j?", N);
18388 ("|use pragma Import instead?j?", N);
18392 --------------------
18393 -- Interface_Name --
18394 --------------------
18396 -- pragma Interface_Name (
18397 -- [ Entity =>] LOCAL_NAME
18398 -- [,[External_Name =>] static_string_EXPRESSION ]
18399 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18401 when Pragma_Interface_Name => Interface_Name : declare
18403 Def_Id : Entity_Id;
18404 Hom_Id : Entity_Id;
18410 ((Name_Entity, Name_External_Name, Name_Link_Name));
18411 Check_At_Least_N_Arguments (2);
18412 Check_At_Most_N_Arguments (3);
18413 Id := Get_Pragma_Arg (Arg1);
18416 -- This is obsolete from Ada 95 on, but it is an implementation
18417 -- defined pragma, so we do not consider that it violates the
18418 -- restriction (No_Obsolescent_Features).
18420 if Ada_Version >= Ada_95 then
18421 if Warn_On_Obsolescent_Feature then
18423 ("pragma Interface_Name is an obsolescent feature?j?", N);
18425 ("|use pragma Import instead?j?", N);
18429 if not Is_Entity_Name (Id) then
18431 ("first argument for pragma% must be entity name", Arg1);
18432 elsif Etype (Id) = Any_Type then
18435 Def_Id := Entity (Id);
18438 -- Special DEC-compatible processing for the object case, forces
18439 -- object to be imported.
18441 if Ekind (Def_Id) = E_Variable then
18442 Kill_Size_Check_Code (Def_Id);
18443 Note_Possible_Modification (Id, Sure => False);
18445 -- Initialization is not allowed for imported variable
18447 if Present (Expression (Parent (Def_Id)))
18448 and then Comes_From_Source (Expression (Parent (Def_Id)))
18450 Error_Msg_Sloc := Sloc (Def_Id);
18452 ("no initialization allowed for declaration of& #",
18456 -- For compatibility, support VADS usage of providing both
18457 -- pragmas Interface and Interface_Name to obtain the effect
18458 -- of a single Import pragma.
18460 if Is_Imported (Def_Id)
18461 and then Present (First_Rep_Item (Def_Id))
18462 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
18463 and then Pragma_Name (First_Rep_Item (Def_Id)) =
18468 Set_Imported (Def_Id);
18471 Set_Is_Public (Def_Id);
18472 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18475 -- Otherwise must be subprogram
18477 elsif not Is_Subprogram (Def_Id) then
18479 ("argument of pragma% is not subprogram", Arg1);
18482 Check_At_Most_N_Arguments (3);
18486 -- Loop through homonyms
18489 Def_Id := Get_Base_Subprogram (Hom_Id);
18491 if Is_Imported (Def_Id) then
18492 Process_Interface_Name (Def_Id, Arg2, Arg3, N);
18496 exit when From_Aspect_Specification (N);
18497 Hom_Id := Homonym (Hom_Id);
18499 exit when No (Hom_Id)
18500 or else Scope (Hom_Id) /= Current_Scope;
18505 ("argument of pragma% is not imported subprogram",
18509 end Interface_Name;
18511 -----------------------
18512 -- Interrupt_Handler --
18513 -----------------------
18515 -- pragma Interrupt_Handler (handler_NAME);
18517 when Pragma_Interrupt_Handler =>
18518 Check_Ada_83_Warning;
18519 Check_Arg_Count (1);
18520 Check_No_Identifiers;
18522 if No_Run_Time_Mode then
18523 Error_Msg_CRT ("Interrupt_Handler pragma", N);
18525 Check_Interrupt_Or_Attach_Handler;
18526 Process_Interrupt_Or_Attach_Handler;
18529 ------------------------
18530 -- Interrupt_Priority --
18531 ------------------------
18533 -- pragma Interrupt_Priority [(EXPRESSION)];
18535 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
18536 P : constant Node_Id := Parent (N);
18541 Check_Ada_83_Warning;
18543 if Arg_Count /= 0 then
18544 Arg := Get_Pragma_Arg (Arg1);
18545 Check_Arg_Count (1);
18546 Check_No_Identifiers;
18548 -- The expression must be analyzed in the special manner
18549 -- described in "Handling of Default and Per-Object
18550 -- Expressions" in sem.ads.
18552 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
18555 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
18560 Ent := Defining_Identifier (Parent (P));
18562 -- Check duplicate pragma before we chain the pragma in the Rep
18563 -- Item chain of Ent.
18565 Check_Duplicate_Pragma (Ent);
18566 Record_Rep_Item (Ent, N);
18568 -- Check the No_Task_At_Interrupt_Priority restriction
18570 if Nkind (P) = N_Task_Definition then
18571 Check_Restriction (No_Task_At_Interrupt_Priority, N);
18574 end Interrupt_Priority;
18576 ---------------------
18577 -- Interrupt_State --
18578 ---------------------
18580 -- pragma Interrupt_State (
18581 -- [Name =>] INTERRUPT_ID,
18582 -- [State =>] INTERRUPT_STATE);
18584 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18585 -- INTERRUPT_STATE => System | Runtime | User
18587 -- Note: if the interrupt id is given as an identifier, then it must
18588 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18589 -- given as a static integer expression which must be in the range of
18590 -- Ada.Interrupts.Interrupt_ID.
18592 when Pragma_Interrupt_State => Interrupt_State : declare
18593 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
18594 -- This is the entity Ada.Interrupts.Interrupt_ID;
18596 State_Type : Character;
18597 -- Set to 's'/'r'/'u' for System/Runtime/User
18600 -- Index to entry in Interrupt_States table
18603 -- Value of interrupt
18605 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
18606 -- The first argument to the pragma
18608 Int_Ent : Entity_Id;
18609 -- Interrupt entity in Ada.Interrupts.Names
18613 Check_Arg_Order ((Name_Name, Name_State));
18614 Check_Arg_Count (2);
18616 Check_Optional_Identifier (Arg1, Name_Name);
18617 Check_Optional_Identifier (Arg2, Name_State);
18618 Check_Arg_Is_Identifier (Arg2);
18620 -- First argument is identifier
18622 if Nkind (Arg1X) = N_Identifier then
18624 -- Search list of names in Ada.Interrupts.Names
18626 Int_Ent := First_Entity (RTE (RE_Names));
18628 if No (Int_Ent) then
18629 Error_Pragma_Arg ("invalid interrupt name", Arg1);
18631 elsif Chars (Int_Ent) = Chars (Arg1X) then
18632 Int_Val := Expr_Value (Constant_Value (Int_Ent));
18636 Next_Entity (Int_Ent);
18639 -- First argument is not an identifier, so it must be a static
18640 -- expression of type Ada.Interrupts.Interrupt_ID.
18643 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
18644 Int_Val := Expr_Value (Arg1X);
18646 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
18648 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
18651 ("value not in range of type "
18652 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
18658 case Chars (Get_Pragma_Arg (Arg2)) is
18659 when Name_Runtime => State_Type := 'r';
18660 when Name_System => State_Type := 's';
18661 when Name_User => State_Type := 'u';
18664 Error_Pragma_Arg ("invalid interrupt state", Arg2);
18667 -- Check if entry is already stored
18669 IST_Num := Interrupt_States.First;
18671 -- If entry not found, add it
18673 if IST_Num > Interrupt_States.Last then
18674 Interrupt_States.Append
18675 ((Interrupt_Number => UI_To_Int (Int_Val),
18676 Interrupt_State => State_Type,
18677 Pragma_Loc => Loc));
18680 -- Case of entry for the same entry
18682 elsif Int_Val = Interrupt_States.Table (IST_Num).
18685 -- If state matches, done, no need to make redundant entry
18688 State_Type = Interrupt_States.Table (IST_Num).
18691 -- Otherwise if state does not match, error
18694 Interrupt_States.Table (IST_Num).Pragma_Loc;
18696 ("state conflicts with that given #", Arg2);
18700 IST_Num := IST_Num + 1;
18702 end Interrupt_State;
18708 -- pragma Invariant
18709 -- ([Entity =>] type_LOCAL_NAME,
18710 -- [Check =>] EXPRESSION
18711 -- [,[Message =>] String_Expression]);
18713 when Pragma_Invariant => Invariant : declare
18720 Check_At_Least_N_Arguments (2);
18721 Check_At_Most_N_Arguments (3);
18722 Check_Optional_Identifier (Arg1, Name_Entity);
18723 Check_Optional_Identifier (Arg2, Name_Check);
18725 if Arg_Count = 3 then
18726 Check_Optional_Identifier (Arg3, Name_Message);
18727 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
18730 Check_Arg_Is_Local_Name (Arg1);
18732 Typ_Arg := Get_Pragma_Arg (Arg1);
18733 Find_Type (Typ_Arg);
18734 Typ := Entity (Typ_Arg);
18736 -- Nothing to do of the related type is erroneous in some way
18738 if Typ = Any_Type then
18741 -- AI12-0041: Invariants are allowed in interface types
18743 elsif Is_Interface (Typ) then
18746 -- An invariant must apply to a private type, or appear in the
18747 -- private part of a package spec and apply to a completion.
18748 -- a class-wide invariant can only appear on a private declaration
18749 -- or private extension, not a completion.
18751 -- A [class-wide] invariant may be associated a [limited] private
18752 -- type or a private extension.
18754 elsif Ekind_In (Typ, E_Limited_Private_Type,
18756 E_Record_Type_With_Private)
18760 -- A non-class-wide invariant may be associated with the full view
18761 -- of a [limited] private type or a private extension.
18763 elsif Has_Private_Declaration (Typ)
18764 and then not Class_Present (N)
18768 -- A class-wide invariant may appear on the partial view only
18770 elsif Class_Present (N) then
18772 ("pragma % only allowed for private type", Arg1);
18775 -- A regular invariant may appear on both views
18779 ("pragma % only allowed for private type or corresponding "
18780 & "full view", Arg1);
18784 -- An invariant associated with an abstract type (this includes
18785 -- interfaces) must be class-wide.
18787 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
18789 ("pragma % not allowed for abstract type", Arg1);
18793 -- A pragma that applies to a Ghost entity becomes Ghost for the
18794 -- purposes of legality checks and removal of ignored Ghost code.
18796 Mark_Ghost_Pragma (N, Typ);
18798 -- The pragma defines a type-specific invariant, the type is said
18799 -- to have invariants of its "own".
18801 Set_Has_Own_Invariants (Typ);
18803 -- If the invariant is class-wide, then it can be inherited by
18804 -- derived or interface implementing types. The type is said to
18805 -- have "inheritable" invariants.
18807 if Class_Present (N) then
18808 Set_Has_Inheritable_Invariants (Typ);
18811 -- Chain the pragma on to the rep item chain, for processing when
18812 -- the type is frozen.
18814 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18816 -- Create the declaration of the invariant procedure that will
18817 -- verify the invariant at run time. Interfaces are treated as the
18818 -- partial view of a private type in order to achieve uniformity
18819 -- with the general case. As a result, an interface receives only
18820 -- a "partial" invariant procedure, which is never called.
18822 Build_Invariant_Procedure_Declaration
18824 Partial_Invariant => Is_Interface (Typ));
18831 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18833 when Pragma_Keep_Names => Keep_Names : declare
18838 Check_Arg_Count (1);
18839 Check_Optional_Identifier (Arg1, Name_On);
18840 Check_Arg_Is_Local_Name (Arg1);
18842 Arg := Get_Pragma_Arg (Arg1);
18845 if Etype (Arg) = Any_Type then
18849 if not Is_Entity_Name (Arg)
18850 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
18853 ("pragma% requires a local enumeration type", Arg1);
18856 Set_Discard_Names (Entity (Arg), False);
18863 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18865 when Pragma_License =>
18868 -- Do not analyze pragma any further in CodePeer mode, to avoid
18869 -- extraneous errors in this implementation-dependent pragma,
18870 -- which has a different profile on other compilers.
18872 if CodePeer_Mode then
18876 Check_Arg_Count (1);
18877 Check_No_Identifiers;
18878 Check_Valid_Configuration_Pragma;
18879 Check_Arg_Is_Identifier (Arg1);
18882 Sind : constant Source_File_Index :=
18883 Source_Index (Current_Sem_Unit);
18886 case Chars (Get_Pragma_Arg (Arg1)) is
18888 Set_License (Sind, GPL);
18890 when Name_Modified_GPL =>
18891 Set_License (Sind, Modified_GPL);
18893 when Name_Restricted =>
18894 Set_License (Sind, Restricted);
18896 when Name_Unrestricted =>
18897 Set_License (Sind, Unrestricted);
18900 Error_Pragma_Arg ("invalid license name", Arg1);
18908 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18910 when Pragma_Link_With => Link_With : declare
18916 if Operating_Mode = Generate_Code
18917 and then In_Extended_Main_Source_Unit (N)
18919 Check_At_Least_N_Arguments (1);
18920 Check_No_Identifiers;
18921 Check_Is_In_Decl_Part_Or_Package_Spec;
18922 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18926 while Present (Arg) loop
18927 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
18929 -- Store argument, converting sequences of spaces to a
18930 -- single null character (this is one of the differences
18931 -- in processing between Link_With and Linker_Options).
18933 Arg_Store : declare
18934 C : constant Char_Code := Get_Char_Code (' ');
18935 S : constant String_Id :=
18936 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
18937 L : constant Nat := String_Length (S);
18940 procedure Skip_Spaces;
18941 -- Advance F past any spaces
18947 procedure Skip_Spaces is
18949 while F <= L and then Get_String_Char (S, F) = C loop
18954 -- Start of processing for Arg_Store
18957 Skip_Spaces; -- skip leading spaces
18959 -- Loop through characters, changing any embedded
18960 -- sequence of spaces to a single null character (this
18961 -- is how Link_With/Linker_Options differ)
18964 if Get_String_Char (S, F) = C then
18967 Store_String_Char (ASCII.NUL);
18970 Store_String_Char (Get_String_Char (S, F));
18978 if Present (Arg) then
18979 Store_String_Char (ASCII.NUL);
18983 Store_Linker_Option_String (End_String);
18991 -- pragma Linker_Alias (
18992 -- [Entity =>] LOCAL_NAME
18993 -- [Target =>] static_string_EXPRESSION);
18995 when Pragma_Linker_Alias =>
18997 Check_Arg_Order ((Name_Entity, Name_Target));
18998 Check_Arg_Count (2);
18999 Check_Optional_Identifier (Arg1, Name_Entity);
19000 Check_Optional_Identifier (Arg2, Name_Target);
19001 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19002 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19004 -- The only processing required is to link this item on to the
19005 -- list of rep items for the given entity. This is accomplished
19006 -- by the call to Rep_Item_Too_Late (when no error is detected
19007 -- and False is returned).
19009 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
19012 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19015 ------------------------
19016 -- Linker_Constructor --
19017 ------------------------
19019 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19021 -- Code is shared with Linker_Destructor
19023 -----------------------
19024 -- Linker_Destructor --
19025 -----------------------
19027 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19029 when Pragma_Linker_Constructor
19030 | Pragma_Linker_Destructor
19032 Linker_Constructor : declare
19038 Check_Arg_Count (1);
19039 Check_No_Identifiers;
19040 Check_Arg_Is_Local_Name (Arg1);
19041 Arg1_X := Get_Pragma_Arg (Arg1);
19043 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
19045 if not Is_Library_Level_Entity (Proc) then
19047 ("argument for pragma% must be library level entity", Arg1);
19050 -- The only processing required is to link this item on to the
19051 -- list of rep items for the given entity. This is accomplished
19052 -- by the call to Rep_Item_Too_Late (when no error is detected
19053 -- and False is returned).
19055 if Rep_Item_Too_Late (Proc, N) then
19058 Set_Has_Gigi_Rep_Item (Proc);
19060 end Linker_Constructor;
19062 --------------------
19063 -- Linker_Options --
19064 --------------------
19066 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19068 when Pragma_Linker_Options => Linker_Options : declare
19072 Check_Ada_83_Warning;
19073 Check_No_Identifiers;
19074 Check_Arg_Count (1);
19075 Check_Is_In_Decl_Part_Or_Package_Spec;
19076 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
19077 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
19080 while Present (Arg) loop
19081 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
19082 Store_String_Char (ASCII.NUL);
19084 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
19088 if Operating_Mode = Generate_Code
19089 and then In_Extended_Main_Source_Unit (N)
19091 Store_Linker_Option_String (End_String);
19093 end Linker_Options;
19095 --------------------
19096 -- Linker_Section --
19097 --------------------
19099 -- pragma Linker_Section (
19100 -- [Entity =>] LOCAL_NAME
19101 -- [Section =>] static_string_EXPRESSION);
19103 when Pragma_Linker_Section => Linker_Section : declare
19108 Ghost_Error_Posted : Boolean := False;
19109 -- Flag set when an error concerning the illegal mix of Ghost and
19110 -- non-Ghost subprograms is emitted.
19112 Ghost_Id : Entity_Id := Empty;
19113 -- The entity of the first Ghost subprogram encountered while
19114 -- processing the arguments of the pragma.
19118 Check_Arg_Order ((Name_Entity, Name_Section));
19119 Check_Arg_Count (2);
19120 Check_Optional_Identifier (Arg1, Name_Entity);
19121 Check_Optional_Identifier (Arg2, Name_Section);
19122 Check_Arg_Is_Library_Level_Local_Name (Arg1);
19123 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19125 -- Check kind of entity
19127 Arg := Get_Pragma_Arg (Arg1);
19128 Ent := Entity (Arg);
19130 case Ekind (Ent) is
19132 -- Objects (constants and variables) and types. For these cases
19133 -- all we need to do is to set the Linker_Section_pragma field,
19134 -- checking that we do not have a duplicate.
19140 LPE := Linker_Section_Pragma (Ent);
19142 if Present (LPE) then
19143 Error_Msg_Sloc := Sloc (LPE);
19145 ("Linker_Section already specified for &#", Arg1, Ent);
19148 Set_Linker_Section_Pragma (Ent, N);
19150 -- A pragma that applies to a Ghost entity becomes Ghost for
19151 -- the purposes of legality checks and removal of ignored
19154 Mark_Ghost_Pragma (N, Ent);
19158 when Subprogram_Kind =>
19160 -- Aspect case, entity already set
19162 if From_Aspect_Specification (N) then
19163 Set_Linker_Section_Pragma
19164 (Entity (Corresponding_Aspect (N)), N);
19166 -- Pragma case, we must climb the homonym chain, but skip
19167 -- any for which the linker section is already set.
19171 if No (Linker_Section_Pragma (Ent)) then
19172 Set_Linker_Section_Pragma (Ent, N);
19174 -- A pragma that applies to a Ghost entity becomes
19175 -- Ghost for the purposes of legality checks and
19176 -- removal of ignored Ghost code.
19178 Mark_Ghost_Pragma (N, Ent);
19180 -- Capture the entity of the first Ghost subprogram
19181 -- being processed for error detection purposes.
19183 if Is_Ghost_Entity (Ent) then
19184 if No (Ghost_Id) then
19188 -- Otherwise the subprogram is non-Ghost. It is
19189 -- illegal to mix references to Ghost and non-Ghost
19190 -- entities (SPARK RM 6.9).
19192 elsif Present (Ghost_Id)
19193 and then not Ghost_Error_Posted
19195 Ghost_Error_Posted := True;
19197 Error_Msg_Name_1 := Pname;
19199 ("pragma % cannot mention ghost and "
19200 & "non-ghost subprograms", N);
19202 Error_Msg_Sloc := Sloc (Ghost_Id);
19204 ("\& # declared as ghost", N, Ghost_Id);
19206 Error_Msg_Sloc := Sloc (Ent);
19208 ("\& # declared as non-ghost", N, Ent);
19212 Ent := Homonym (Ent);
19214 or else Scope (Ent) /= Current_Scope;
19218 -- All other cases are illegal
19222 ("pragma% applies only to objects, subprograms, and types",
19225 end Linker_Section;
19231 -- pragma List (On | Off)
19233 -- There is nothing to do here, since we did all the processing for
19234 -- this pragma in Par.Prag (so that it works properly even in syntax
19237 when Pragma_List =>
19244 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19246 when Pragma_Lock_Free => Lock_Free : declare
19247 P : constant Node_Id := Parent (N);
19253 Check_No_Identifiers;
19254 Check_At_Most_N_Arguments (1);
19256 -- Protected definition case
19258 if Nkind (P) = N_Protected_Definition then
19259 Ent := Defining_Identifier (Parent (P));
19263 if Arg_Count = 1 then
19264 Arg := Get_Pragma_Arg (Arg1);
19265 Val := Is_True (Static_Boolean (Arg));
19267 -- No arguments (expression is considered to be True)
19273 -- Check duplicate pragma before we chain the pragma in the Rep
19274 -- Item chain of Ent.
19276 Check_Duplicate_Pragma (Ent);
19277 Record_Rep_Item (Ent, N);
19278 Set_Uses_Lock_Free (Ent, Val);
19280 -- Anything else is incorrect placement
19287 --------------------
19288 -- Locking_Policy --
19289 --------------------
19291 -- pragma Locking_Policy (policy_IDENTIFIER);
19293 when Pragma_Locking_Policy => declare
19294 subtype LP_Range is Name_Id
19295 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
19300 Check_Ada_83_Warning;
19301 Check_Arg_Count (1);
19302 Check_No_Identifiers;
19303 Check_Arg_Is_Locking_Policy (Arg1);
19304 Check_Valid_Configuration_Pragma;
19305 LP_Val := Chars (Get_Pragma_Arg (Arg1));
19308 when Name_Ceiling_Locking => LP := 'C';
19309 when Name_Concurrent_Readers_Locking => LP := 'R';
19310 when Name_Inheritance_Locking => LP := 'I';
19313 if Locking_Policy /= ' '
19314 and then Locking_Policy /= LP
19316 Error_Msg_Sloc := Locking_Policy_Sloc;
19317 Error_Pragma ("locking policy incompatible with policy#");
19319 -- Set new policy, but always preserve System_Location since we
19320 -- like the error message with the run time name.
19323 Locking_Policy := LP;
19325 if Locking_Policy_Sloc /= System_Location then
19326 Locking_Policy_Sloc := Loc;
19331 -------------------
19332 -- Loop_Optimize --
19333 -------------------
19335 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19337 -- OPTIMIZATION_HINT ::=
19338 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19340 when Pragma_Loop_Optimize => Loop_Optimize : declare
19345 Check_At_Least_N_Arguments (1);
19346 Check_No_Identifiers;
19348 Hint := First (Pragma_Argument_Associations (N));
19349 while Present (Hint) loop
19350 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
19358 Check_Loop_Pragma_Placement;
19365 -- pragma Loop_Variant
19366 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19368 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19370 -- CHANGE_DIRECTION ::= Increases | Decreases
19372 when Pragma_Loop_Variant => Loop_Variant : declare
19377 Check_At_Least_N_Arguments (1);
19378 Check_Loop_Pragma_Placement;
19380 -- Process all increasing / decreasing expressions
19382 Variant := First (Pragma_Argument_Associations (N));
19383 while Present (Variant) loop
19384 if Chars (Variant) = No_Name then
19385 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant);
19387 elsif not Nam_In (Chars (Variant), Name_Decreases,
19391 Name : String := Get_Name_String (Chars (Variant));
19394 -- It is a common mistake to write "Increasing" for
19395 -- "Increases" or "Decreasing" for "Decreases". Recognize
19396 -- specially names starting with "incr" or "decr" to
19397 -- suggest the corresponding name.
19399 System.Case_Util.To_Lower (Name);
19401 if Name'Length >= 4
19402 and then Name (1 .. 4) = "incr"
19404 Error_Pragma_Arg_Ident
19405 ("expect name `Increases`", Variant);
19407 elsif Name'Length >= 4
19408 and then Name (1 .. 4) = "decr"
19410 Error_Pragma_Arg_Ident
19411 ("expect name `Decreases`", Variant);
19414 Error_Pragma_Arg_Ident
19415 ("expect name `Increases` or `Decreases`", Variant);
19420 Preanalyze_Assert_Expression
19421 (Expression (Variant), Any_Discrete);
19427 -----------------------
19428 -- Machine_Attribute --
19429 -----------------------
19431 -- pragma Machine_Attribute (
19432 -- [Entity =>] LOCAL_NAME,
19433 -- [Attribute_Name =>] static_string_EXPRESSION
19434 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19436 when Pragma_Machine_Attribute => Machine_Attribute : declare
19438 Def_Id : Entity_Id;
19442 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
19444 if Arg_Count >= 3 then
19445 Check_Optional_Identifier (Arg3, Name_Info);
19447 while Present (Arg) loop
19448 Check_Arg_Is_OK_Static_Expression (Arg);
19452 Check_Arg_Count (2);
19455 Check_Optional_Identifier (Arg1, Name_Entity);
19456 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
19457 Check_Arg_Is_Local_Name (Arg1);
19458 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
19459 Def_Id := Entity (Get_Pragma_Arg (Arg1));
19461 if Is_Access_Type (Def_Id) then
19462 Def_Id := Designated_Type (Def_Id);
19465 if Rep_Item_Too_Early (Def_Id, N) then
19469 Def_Id := Underlying_Type (Def_Id);
19471 -- The only processing required is to link this item on to the
19472 -- list of rep items for the given entity. This is accomplished
19473 -- by the call to Rep_Item_Too_Late (when no error is detected
19474 -- and False is returned).
19476 if Rep_Item_Too_Late (Def_Id, N) then
19479 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
19481 end Machine_Attribute;
19488 -- (MAIN_OPTION [, MAIN_OPTION]);
19491 -- [STACK_SIZE =>] static_integer_EXPRESSION
19492 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19493 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19495 when Pragma_Main => Main : declare
19496 Args : Args_List (1 .. 3);
19497 Names : constant Name_List (1 .. 3) := (
19499 Name_Task_Stack_Size_Default,
19500 Name_Time_Slicing_Enabled);
19506 Gather_Associations (Names, Args);
19508 for J in 1 .. 2 loop
19509 if Present (Args (J)) then
19510 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19514 if Present (Args (3)) then
19515 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
19519 while Present (Nod) loop
19520 if Nkind (Nod) = N_Pragma
19521 and then Pragma_Name (Nod) = Name_Main
19523 Error_Msg_Name_1 := Pname;
19524 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19535 -- pragma Main_Storage
19536 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19538 -- MAIN_STORAGE_OPTION ::=
19539 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19540 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19542 when Pragma_Main_Storage => Main_Storage : declare
19543 Args : Args_List (1 .. 2);
19544 Names : constant Name_List (1 .. 2) := (
19545 Name_Working_Storage,
19552 Gather_Associations (Names, Args);
19554 for J in 1 .. 2 loop
19555 if Present (Args (J)) then
19556 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
19560 Check_In_Main_Program;
19563 while Present (Nod) loop
19564 if Nkind (Nod) = N_Pragma
19565 and then Pragma_Name (Nod) = Name_Main_Storage
19567 Error_Msg_Name_1 := Pname;
19568 Error_Msg_N ("duplicate pragma% not permitted", Nod);
19575 ----------------------------
19576 -- Max_Entry_Queue_Length --
19577 ----------------------------
19579 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19581 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19582 -- Pragma_Max_Queue_Length.
19584 when Pragma_Max_Entry_Queue_Length
19585 | Pragma_Max_Entry_Queue_Depth
19586 | Pragma_Max_Queue_Length
19588 Max_Queue_Length : declare
19590 Entry_Decl : Node_Id;
19591 Entry_Id : Entity_Id;
19595 if Prag_Id = Pragma_Max_Entry_Queue_Depth
19596 or else Prag_Id = Pragma_Max_Queue_Length
19601 Check_Arg_Count (1);
19604 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
19606 -- Entry declaration
19608 if Nkind (Entry_Decl) = N_Entry_Declaration then
19610 -- Entry illegally within a task
19612 if Nkind (Parent (N)) = N_Task_Definition then
19613 Error_Pragma ("pragma % cannot apply to task entries");
19617 Entry_Id := Defining_Entity (Entry_Decl);
19619 -- Otherwise the pragma is associated with an illegal construct
19622 Error_Pragma ("pragma % must apply to a protected entry");
19626 -- Mark the pragma as Ghost if the related subprogram is also
19627 -- Ghost. This also ensures that any expansion performed further
19628 -- below will produce Ghost nodes.
19630 Mark_Ghost_Pragma (N, Entry_Id);
19632 -- Analyze the Integer expression
19634 Arg := Get_Pragma_Arg (Arg1);
19635 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
19637 Val := Expr_Value (Arg);
19641 ("argument for pragma% must be positive", Arg1);
19643 elsif not UI_Is_In_Int_Range (Val) then
19645 ("argument for pragma% out of range of Integer", Arg1);
19649 -- Manually substitute the expression value of the pragma argument
19650 -- if it's not an integer literal because this is not taken care
19651 -- of automatically elsewhere.
19653 if Nkind (Arg) /= N_Integer_Literal then
19654 Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
19655 Set_Etype (Arg, Etype (Original_Node (Arg)));
19658 Record_Rep_Item (Entry_Id, N);
19659 end Max_Queue_Length;
19665 -- pragma Memory_Size (NUMERIC_LITERAL)
19667 when Pragma_Memory_Size =>
19670 -- Memory size is simply ignored
19672 Check_No_Identifiers;
19673 Check_Arg_Count (1);
19674 Check_Arg_Is_Integer_Literal (Arg1);
19682 -- The only correct use of this pragma is on its own in a file, in
19683 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19684 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19685 -- check for a file containing nothing but a No_Body pragma). If we
19686 -- attempt to process it during normal semantics processing, it means
19687 -- it was misplaced.
19689 when Pragma_No_Body =>
19693 -----------------------------
19694 -- No_Elaboration_Code_All --
19695 -----------------------------
19697 -- pragma No_Elaboration_Code_All;
19699 when Pragma_No_Elaboration_Code_All =>
19701 Check_Valid_Library_Unit_Pragma;
19703 if Nkind (N) = N_Null_Statement then
19707 -- Must appear for a spec or generic spec
19709 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
19710 N_Generic_Package_Declaration,
19711 N_Generic_Subprogram_Declaration,
19712 N_Package_Declaration,
19713 N_Subprogram_Declaration)
19717 ("pragma% can only occur for package "
19718 & "or subprogram spec"));
19721 -- Set flag in unit table
19723 Set_No_Elab_Code_All (Current_Sem_Unit);
19725 -- Set restriction No_Elaboration_Code if this is the main unit
19727 if Current_Sem_Unit = Main_Unit then
19728 Set_Restriction (No_Elaboration_Code, N);
19731 -- If we are in the main unit or in an extended main source unit,
19732 -- then we also add it to the configuration restrictions so that
19733 -- it will apply to all units in the extended main source.
19735 if Current_Sem_Unit = Main_Unit
19736 or else In_Extended_Main_Source_Unit (N)
19738 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
19741 -- If in main extended unit, activate transitive with test
19743 if In_Extended_Main_Source_Unit (N) then
19744 Opt.No_Elab_Code_All_Pragma := N;
19747 -----------------------------
19748 -- No_Component_Reordering --
19749 -----------------------------
19751 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19753 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
19759 Check_At_Most_N_Arguments (1);
19761 if Arg_Count = 0 then
19762 Check_Valid_Configuration_Pragma;
19763 Opt.No_Component_Reordering := True;
19766 Check_Optional_Identifier (Arg2, Name_Entity);
19767 Check_Arg_Is_Local_Name (Arg1);
19768 E_Id := Get_Pragma_Arg (Arg1);
19770 if Etype (E_Id) = Any_Type then
19774 E := Entity (E_Id);
19776 if not Is_Record_Type (E) then
19777 Error_Pragma_Arg ("pragma% requires record type", Arg1);
19780 Set_No_Reordering (Base_Type (E));
19782 end No_Comp_Reordering;
19784 --------------------------
19785 -- No_Heap_Finalization --
19786 --------------------------
19788 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19790 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
19791 Context : constant Node_Id := Parent (N);
19792 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
19798 Check_No_Identifiers;
19800 -- The pragma appears in a configuration file
19802 if No (Context) then
19803 Check_Arg_Count (0);
19804 Check_Valid_Configuration_Pragma;
19806 -- Detect a duplicate pragma
19808 if Present (No_Heap_Finalization_Pragma) then
19811 Prev => No_Heap_Finalization_Pragma);
19815 No_Heap_Finalization_Pragma := N;
19817 -- Otherwise the pragma should be associated with a library-level
19818 -- named access-to-object type.
19821 Check_Arg_Count (1);
19822 Check_Arg_Is_Local_Name (Arg1);
19824 Find_Type (Typ_Arg);
19825 Typ := Entity (Typ_Arg);
19827 -- The type being subjected to the pragma is erroneous
19829 if Typ = Any_Type then
19830 Error_Pragma ("cannot find type referenced by pragma %");
19832 -- The pragma is applied to an incomplete or generic formal
19833 -- type way too early.
19835 elsif Rep_Item_Too_Early (Typ, N) then
19839 Typ := Underlying_Type (Typ);
19842 -- The pragma must apply to an access-to-object type
19844 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
19847 -- Give a detailed error message on all other access type kinds
19849 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
19851 ("pragma % cannot apply to access protected subprogram "
19854 elsif Ekind (Typ) = E_Access_Subprogram_Type then
19856 ("pragma % cannot apply to access subprogram type");
19858 elsif Is_Anonymous_Access_Type (Typ) then
19860 ("pragma % cannot apply to anonymous access type");
19862 -- Give a general error message in case the pragma applies to a
19863 -- non-access type.
19867 ("pragma % must apply to library level access type");
19870 -- At this point the argument denotes an access-to-object type.
19871 -- Ensure that the type is declared at the library level.
19873 if Is_Library_Level_Entity (Typ) then
19876 -- Quietly ignore an access-to-object type originally declared
19877 -- at the library level within a generic, but instantiated at
19878 -- a non-library level. As a result the access-to-object type
19879 -- "loses" its No_Heap_Finalization property.
19881 elsif In_Instance then
19886 ("pragma % must apply to library level access type");
19889 -- Detect a duplicate pragma
19891 if Present (No_Heap_Finalization_Pragma) then
19894 Prev => No_Heap_Finalization_Pragma);
19898 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
19900 if Present (Prev) then
19908 Record_Rep_Item (Typ, N);
19910 end No_Heap_Finalization;
19916 -- pragma No_Inline ( NAME {, NAME} );
19918 when Pragma_No_Inline =>
19920 Process_Inline (Suppressed);
19926 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19928 when Pragma_No_Return => No_Return : declare
19934 Ghost_Error_Posted : Boolean := False;
19935 -- Flag set when an error concerning the illegal mix of Ghost and
19936 -- non-Ghost subprograms is emitted.
19938 Ghost_Id : Entity_Id := Empty;
19939 -- The entity of the first Ghost procedure encountered while
19940 -- processing the arguments of the pragma.
19944 Check_At_Least_N_Arguments (1);
19946 -- Loop through arguments of pragma
19949 while Present (Arg) loop
19950 Check_Arg_Is_Local_Name (Arg);
19951 Id := Get_Pragma_Arg (Arg);
19954 if not Is_Entity_Name (Id) then
19955 Error_Pragma_Arg ("entity name required", Arg);
19958 if Etype (Id) = Any_Type then
19962 -- Loop to find matching procedures
19968 and then Scope (E) = Current_Scope
19970 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
19972 -- Check that the pragma is not applied to a body.
19973 -- First check the specless body case, to give a
19974 -- different error message. These checks do not apply
19975 -- if Relaxed_RM_Semantics, to accommodate other Ada
19976 -- compilers. Disable these checks under -gnatd.J.
19978 if not Debug_Flag_Dot_JJ then
19979 if Nkind (Parent (Declaration_Node (E))) =
19981 and then not Relaxed_RM_Semantics
19984 ("pragma% requires separate spec and must come "
19988 -- Now the "specful" body case
19990 if Rep_Item_Too_Late (E, N) then
19997 -- A pragma that applies to a Ghost entity becomes Ghost
19998 -- for the purposes of legality checks and removal of
19999 -- ignored Ghost code.
20001 Mark_Ghost_Pragma (N, E);
20003 -- Capture the entity of the first Ghost procedure being
20004 -- processed for error detection purposes.
20006 if Is_Ghost_Entity (E) then
20007 if No (Ghost_Id) then
20011 -- Otherwise the subprogram is non-Ghost. It is illegal
20012 -- to mix references to Ghost and non-Ghost entities
20015 elsif Present (Ghost_Id)
20016 and then not Ghost_Error_Posted
20018 Ghost_Error_Posted := True;
20020 Error_Msg_Name_1 := Pname;
20022 ("pragma % cannot mention ghost and non-ghost "
20023 & "procedures", N);
20025 Error_Msg_Sloc := Sloc (Ghost_Id);
20026 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
20028 Error_Msg_Sloc := Sloc (E);
20029 Error_Msg_NE ("\& # declared as non-ghost", N, E);
20032 -- Set flag on any alias as well
20034 if Is_Overloadable (E) and then Present (Alias (E)) then
20035 Set_No_Return (Alias (E));
20041 exit when From_Aspect_Specification (N);
20045 -- If entity in not in current scope it may be the enclosing
20046 -- suprogram body to which the aspect applies.
20049 if Entity (Id) = Current_Scope
20050 and then From_Aspect_Specification (N)
20052 Set_No_Return (Entity (Id));
20054 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
20066 -- pragma No_Run_Time;
20068 -- Note: this pragma is retained for backwards compatibility. See
20069 -- body of Rtsfind for full details on its handling.
20071 when Pragma_No_Run_Time =>
20073 Check_Valid_Configuration_Pragma;
20074 Check_Arg_Count (0);
20076 -- Remove backward compatibility if Build_Type is FSF or GPL and
20077 -- generate a warning.
20080 Ignore : constant Boolean := Build_Type in FSF .. GPL;
20083 Error_Pragma ("pragma% is ignored, has no effect??");
20085 No_Run_Time_Mode := True;
20086 Configurable_Run_Time_Mode := True;
20088 -- Set Duration to 32 bits if word size is 32
20090 if Ttypes.System_Word_Size = 32 then
20091 Duration_32_Bits_On_Target := True;
20094 -- Set appropriate restrictions
20096 Set_Restriction (No_Finalization, N);
20097 Set_Restriction (No_Exception_Handlers, N);
20098 Set_Restriction (Max_Tasks, N, 0);
20099 Set_Restriction (No_Tasking, N);
20103 -----------------------
20104 -- No_Tagged_Streams --
20105 -----------------------
20107 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20109 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
20115 Check_At_Most_N_Arguments (1);
20117 -- One argument case
20119 if Arg_Count = 1 then
20120 Check_Optional_Identifier (Arg1, Name_Entity);
20121 Check_Arg_Is_Local_Name (Arg1);
20122 E_Id := Get_Pragma_Arg (Arg1);
20124 if Etype (E_Id) = Any_Type then
20128 E := Entity (E_Id);
20130 Check_Duplicate_Pragma (E);
20132 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
20134 ("argument for pragma% must be root tagged type", Arg1);
20137 if Rep_Item_Too_Early (E, N)
20139 Rep_Item_Too_Late (E, N)
20143 Set_No_Tagged_Streams_Pragma (E, N);
20146 -- Zero argument case
20149 Check_Is_In_Decl_Part_Or_Package_Spec;
20150 No_Tagged_Streams := N;
20152 end No_Tagged_Strms;
20154 ------------------------
20155 -- No_Strict_Aliasing --
20156 ------------------------
20158 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20160 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
20166 Check_At_Most_N_Arguments (1);
20168 if Arg_Count = 0 then
20169 Check_Valid_Configuration_Pragma;
20170 Opt.No_Strict_Aliasing := True;
20173 Check_Optional_Identifier (Arg2, Name_Entity);
20174 Check_Arg_Is_Local_Name (Arg1);
20175 E_Id := Get_Pragma_Arg (Arg1);
20177 if Etype (E_Id) = Any_Type then
20181 E := Entity (E_Id);
20183 if not Is_Access_Type (E) then
20184 Error_Pragma_Arg ("pragma% requires access type", Arg1);
20187 Set_No_Strict_Aliasing (Base_Type (E));
20189 end No_Strict_Aliasing;
20191 -----------------------
20192 -- Normalize_Scalars --
20193 -----------------------
20195 -- pragma Normalize_Scalars;
20197 when Pragma_Normalize_Scalars =>
20198 Check_Ada_83_Warning;
20199 Check_Arg_Count (0);
20200 Check_Valid_Configuration_Pragma;
20202 -- Normalize_Scalars creates false positives in CodePeer, and
20203 -- incorrect negative results in GNATprove mode, so ignore this
20204 -- pragma in these modes.
20206 if not (CodePeer_Mode or GNATprove_Mode) then
20207 Normalize_Scalars := True;
20208 Init_Or_Norm_Scalars := True;
20215 -- pragma Obsolescent;
20217 -- pragma Obsolescent (
20218 -- [Message =>] static_string_EXPRESSION
20219 -- [,[Version =>] Ada_05]]);
20221 -- pragma Obsolescent (
20222 -- [Entity =>] NAME
20223 -- [,[Message =>] static_string_EXPRESSION
20224 -- [,[Version =>] Ada_05]] );
20226 when Pragma_Obsolescent => Obsolescent : declare
20230 procedure Set_Obsolescent (E : Entity_Id);
20231 -- Given an entity Ent, mark it as obsolescent if appropriate
20233 ---------------------
20234 -- Set_Obsolescent --
20235 ---------------------
20237 procedure Set_Obsolescent (E : Entity_Id) is
20246 -- A pragma that applies to a Ghost entity becomes Ghost for
20247 -- the purposes of legality checks and removal of ignored Ghost
20250 Mark_Ghost_Pragma (N, E);
20252 -- Entity name was given
20254 if Present (Ename) then
20256 -- If entity name matches, we are fine. Save entity in
20257 -- pragma argument, for ASIS use.
20259 if Chars (Ename) = Chars (Ent) then
20260 Set_Entity (Ename, Ent);
20261 Generate_Reference (Ent, Ename);
20263 -- If entity name does not match, only possibility is an
20264 -- enumeration literal from an enumeration type declaration.
20266 elsif Ekind (Ent) /= E_Enumeration_Type then
20268 ("pragma % entity name does not match declaration");
20271 Ent := First_Literal (E);
20275 ("pragma % entity name does not match any "
20276 & "enumeration literal");
20278 elsif Chars (Ent) = Chars (Ename) then
20279 Set_Entity (Ename, Ent);
20280 Generate_Reference (Ent, Ename);
20284 Ent := Next_Literal (Ent);
20290 -- Ent points to entity to be marked
20292 if Arg_Count >= 1 then
20294 -- Deal with static string argument
20296 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
20297 S := Strval (Get_Pragma_Arg (Arg1));
20299 for J in 1 .. String_Length (S) loop
20300 if not In_Character_Range (Get_String_Char (S, J)) then
20302 ("pragma% argument does not allow wide characters",
20307 Obsolescent_Warnings.Append
20308 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
20310 -- Check for Ada_05 parameter
20312 if Arg_Count /= 1 then
20313 Check_Arg_Count (2);
20316 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
20319 Check_Arg_Is_Identifier (Argx);
20321 if Chars (Argx) /= Name_Ada_05 then
20322 Error_Msg_Name_2 := Name_Ada_05;
20324 ("only allowed argument for pragma% is %", Argx);
20327 if Ada_Version_Explicit < Ada_2005
20328 or else not Warn_On_Ada_2005_Compatibility
20336 -- Set flag if pragma active
20339 Set_Is_Obsolescent (Ent);
20343 end Set_Obsolescent;
20345 -- Start of processing for pragma Obsolescent
20350 Check_At_Most_N_Arguments (3);
20352 -- See if first argument specifies an entity name
20356 (Chars (Arg1) = Name_Entity
20358 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
20360 N_Operator_Symbol))
20362 Ename := Get_Pragma_Arg (Arg1);
20364 -- Eliminate first argument, so we can share processing
20368 Arg_Count := Arg_Count - 1;
20370 -- No Entity name argument given
20376 if Arg_Count >= 1 then
20377 Check_Optional_Identifier (Arg1, Name_Message);
20379 if Arg_Count = 2 then
20380 Check_Optional_Identifier (Arg2, Name_Version);
20384 -- Get immediately preceding declaration
20387 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
20391 -- Cases where we do not follow anything other than another pragma
20395 -- First case: library level compilation unit declaration with
20396 -- the pragma immediately following the declaration.
20398 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
20400 (Defining_Entity (Unit (Parent (Parent (N)))));
20403 -- Case 2: library unit placement for package
20407 Ent : constant Entity_Id := Find_Lib_Unit_Name;
20409 if Is_Package_Or_Generic_Package (Ent) then
20410 Set_Obsolescent (Ent);
20416 -- Cases where we must follow a declaration, including an
20417 -- abstract subprogram declaration, which is not in the
20418 -- other node subtypes.
20421 if Nkind (Decl) not in N_Declaration
20422 and then Nkind (Decl) not in N_Later_Decl_Item
20423 and then Nkind (Decl) not in N_Generic_Declaration
20424 and then Nkind (Decl) not in N_Renaming_Declaration
20425 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
20428 ("pragma% misplaced, "
20429 & "must immediately follow a declaration");
20432 Set_Obsolescent (Defining_Entity (Decl));
20442 -- pragma Optimize (Time | Space | Off);
20444 -- The actual check for optimize is done in Gigi. Note that this
20445 -- pragma does not actually change the optimization setting, it
20446 -- simply checks that it is consistent with the pragma.
20448 when Pragma_Optimize =>
20449 Check_No_Identifiers;
20450 Check_Arg_Count (1);
20451 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
20453 ------------------------
20454 -- Optimize_Alignment --
20455 ------------------------
20457 -- pragma Optimize_Alignment (Time | Space | Off);
20459 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
20461 Check_No_Identifiers;
20462 Check_Arg_Count (1);
20463 Check_Valid_Configuration_Pragma;
20466 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
20469 when Name_Off => Opt.Optimize_Alignment := 'O';
20470 when Name_Space => Opt.Optimize_Alignment := 'S';
20471 when Name_Time => Opt.Optimize_Alignment := 'T';
20474 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
20478 -- Set indication that mode is set locally. If we are in fact in a
20479 -- configuration pragma file, this setting is harmless since the
20480 -- switch will get reset anyway at the start of each unit.
20482 Optimize_Alignment_Local := True;
20483 end Optimize_Alignment;
20489 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20491 when Pragma_Ordered => Ordered : declare
20492 Assoc : constant Node_Id := Arg1;
20498 Check_No_Identifiers;
20499 Check_Arg_Count (1);
20500 Check_Arg_Is_Local_Name (Arg1);
20502 Type_Id := Get_Pragma_Arg (Assoc);
20503 Find_Type (Type_Id);
20504 Typ := Entity (Type_Id);
20506 if Typ = Any_Type then
20509 Typ := Underlying_Type (Typ);
20512 if not Is_Enumeration_Type (Typ) then
20513 Error_Pragma ("pragma% must specify enumeration type");
20516 Check_First_Subtype (Arg1);
20517 Set_Has_Pragma_Ordered (Base_Type (Typ));
20520 -------------------
20521 -- Overflow_Mode --
20522 -------------------
20524 -- pragma Overflow_Mode
20525 -- ([General => ] MODE [, [Assertions => ] MODE]);
20527 -- MODE := STRICT | MINIMIZED | ELIMINATED
20529 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20530 -- since System.Bignums makes this assumption. This is true of nearly
20531 -- all (all?) targets.
20533 when Pragma_Overflow_Mode => Overflow_Mode : declare
20534 function Get_Overflow_Mode
20536 Arg : Node_Id) return Overflow_Mode_Type;
20537 -- Function to process one pragma argument, Arg. If an identifier
20538 -- is present, it must be Name. Mode type is returned if a valid
20539 -- argument exists, otherwise an error is signalled.
20541 -----------------------
20542 -- Get_Overflow_Mode --
20543 -----------------------
20545 function Get_Overflow_Mode
20547 Arg : Node_Id) return Overflow_Mode_Type
20549 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
20552 Check_Optional_Identifier (Arg, Name);
20553 Check_Arg_Is_Identifier (Argx);
20555 if Chars (Argx) = Name_Strict then
20558 elsif Chars (Argx) = Name_Minimized then
20561 elsif Chars (Argx) = Name_Eliminated then
20562 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
20564 ("Eliminated not implemented on this target", Argx);
20570 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
20572 end Get_Overflow_Mode;
20574 -- Start of processing for Overflow_Mode
20578 Check_At_Least_N_Arguments (1);
20579 Check_At_Most_N_Arguments (2);
20581 -- Process first argument
20583 Scope_Suppress.Overflow_Mode_General :=
20584 Get_Overflow_Mode (Name_General, Arg1);
20586 -- Case of only one argument
20588 if Arg_Count = 1 then
20589 Scope_Suppress.Overflow_Mode_Assertions :=
20590 Scope_Suppress.Overflow_Mode_General;
20592 -- Case of two arguments present
20595 Scope_Suppress.Overflow_Mode_Assertions :=
20596 Get_Overflow_Mode (Name_Assertions, Arg2);
20600 --------------------------
20601 -- Overriding Renamings --
20602 --------------------------
20604 -- pragma Overriding_Renamings;
20606 when Pragma_Overriding_Renamings =>
20608 Check_Arg_Count (0);
20609 Check_Valid_Configuration_Pragma;
20610 Overriding_Renamings := True;
20616 -- pragma Pack (first_subtype_LOCAL_NAME);
20618 when Pragma_Pack => Pack : declare
20619 Assoc : constant Node_Id := Arg1;
20621 Ignore : Boolean := False;
20626 Check_No_Identifiers;
20627 Check_Arg_Count (1);
20628 Check_Arg_Is_Local_Name (Arg1);
20629 Type_Id := Get_Pragma_Arg (Assoc);
20631 if not Is_Entity_Name (Type_Id)
20632 or else not Is_Type (Entity (Type_Id))
20635 ("argument for pragma% must be type or subtype", Arg1);
20638 Find_Type (Type_Id);
20639 Typ := Entity (Type_Id);
20642 or else Rep_Item_Too_Early (Typ, N)
20646 Typ := Underlying_Type (Typ);
20649 -- A pragma that applies to a Ghost entity becomes Ghost for the
20650 -- purposes of legality checks and removal of ignored Ghost code.
20652 Mark_Ghost_Pragma (N, Typ);
20654 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
20655 Error_Pragma ("pragma% must specify array or record type");
20658 Check_First_Subtype (Arg1);
20659 Check_Duplicate_Pragma (Typ);
20663 if Is_Array_Type (Typ) then
20664 Ctyp := Component_Type (Typ);
20666 -- Ignore pack that does nothing
20668 if Known_Static_Esize (Ctyp)
20669 and then Known_Static_RM_Size (Ctyp)
20670 and then Esize (Ctyp) = RM_Size (Ctyp)
20671 and then Addressable (Esize (Ctyp))
20676 -- Process OK pragma Pack. Note that if there is a separate
20677 -- component clause present, the Pack will be cancelled. This
20678 -- processing is in Freeze.
20680 if not Rep_Item_Too_Late (Typ, N) then
20682 -- In CodePeer mode, we do not need complex front-end
20683 -- expansions related to pragma Pack, so disable handling
20686 if CodePeer_Mode then
20689 -- Normal case where we do the pack action
20693 Set_Is_Packed (Base_Type (Typ));
20694 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20697 Set_Has_Pragma_Pack (Base_Type (Typ));
20701 -- For record types, the pack is always effective
20703 else pragma Assert (Is_Record_Type (Typ));
20704 if not Rep_Item_Too_Late (Typ, N) then
20705 Set_Is_Packed (Base_Type (Typ));
20706 Set_Has_Pragma_Pack (Base_Type (Typ));
20707 Set_Has_Non_Standard_Rep (Base_Type (Typ));
20718 -- There is nothing to do here, since we did all the processing for
20719 -- this pragma in Par.Prag (so that it works properly even in syntax
20722 when Pragma_Page =>
20729 -- pragma Part_Of (ABSTRACT_STATE);
20731 -- ABSTRACT_STATE ::= NAME
20733 when Pragma_Part_Of => Part_Of : declare
20734 procedure Propagate_Part_Of
20735 (Pack_Id : Entity_Id;
20736 State_Id : Entity_Id;
20737 Instance : Node_Id);
20738 -- Propagate the Part_Of indicator to all abstract states and
20739 -- objects declared in the visible state space of a package
20740 -- denoted by Pack_Id. State_Id is the encapsulating state.
20741 -- Instance is the package instantiation node.
20743 -----------------------
20744 -- Propagate_Part_Of --
20745 -----------------------
20747 procedure Propagate_Part_Of
20748 (Pack_Id : Entity_Id;
20749 State_Id : Entity_Id;
20750 Instance : Node_Id)
20752 Has_Item : Boolean := False;
20753 -- Flag set when the visible state space contains at least one
20754 -- abstract state or variable.
20756 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
20757 -- Propagate the Part_Of indicator to all abstract states and
20758 -- objects declared in the visible state space of a package
20759 -- denoted by Pack_Id.
20761 -----------------------
20762 -- Propagate_Part_Of --
20763 -----------------------
20765 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
20766 Constits : Elist_Id;
20767 Item_Id : Entity_Id;
20770 -- Traverse the entity chain of the package and set relevant
20771 -- attributes of abstract states and objects declared in the
20772 -- visible state space of the package.
20774 Item_Id := First_Entity (Pack_Id);
20775 while Present (Item_Id)
20776 and then not In_Private_Part (Item_Id)
20778 -- Do not consider internally generated items
20780 if not Comes_From_Source (Item_Id) then
20783 -- Do not consider generic formals or their corresponding
20784 -- actuals because they are not part of a visible state.
20785 -- Note that both entities are marked as hidden.
20787 elsif Is_Hidden (Item_Id) then
20790 -- The Part_Of indicator turns an abstract state or an
20791 -- object into a constituent of the encapsulating state.
20792 -- Note that constants are considered here even though
20793 -- they may not depend on variable input. This check is
20794 -- left to the SPARK prover.
20796 elsif Ekind_In (Item_Id, E_Abstract_State,
20801 Constits := Part_Of_Constituents (State_Id);
20803 if No (Constits) then
20804 Constits := New_Elmt_List;
20805 Set_Part_Of_Constituents (State_Id, Constits);
20808 Append_Elmt (Item_Id, Constits);
20809 Set_Encapsulating_State (Item_Id, State_Id);
20811 -- Recursively handle nested packages and instantiations
20813 elsif Ekind (Item_Id) = E_Package then
20814 Propagate_Part_Of (Item_Id);
20817 Next_Entity (Item_Id);
20819 end Propagate_Part_Of;
20821 -- Start of processing for Propagate_Part_Of
20824 Propagate_Part_Of (Pack_Id);
20826 -- Detect a package instantiation that is subject to a Part_Of
20827 -- indicator, but has no visible state.
20829 if not Has_Item then
20831 ("package instantiation & has Part_Of indicator but "
20832 & "lacks visible state", Instance, Pack_Id);
20834 end Propagate_Part_Of;
20838 Constits : Elist_Id;
20840 Encap_Id : Entity_Id;
20841 Item_Id : Entity_Id;
20845 -- Start of processing for Part_Of
20849 Check_No_Identifiers;
20850 Check_Arg_Count (1);
20852 Stmt := Find_Related_Context (N, Do_Checks => True);
20854 -- Object declaration
20856 if Nkind (Stmt) = N_Object_Declaration then
20859 -- Package instantiation
20861 elsif Nkind (Stmt) = N_Package_Instantiation then
20864 -- Single concurrent type declaration
20866 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
20869 -- Otherwise the pragma is associated with an illegal construct
20876 -- Extract the entity of the related object declaration or package
20877 -- instantiation. In the case of the instantiation, use the entity
20878 -- of the instance spec.
20880 if Nkind (Stmt) = N_Package_Instantiation then
20881 Stmt := Instance_Spec (Stmt);
20884 Item_Id := Defining_Entity (Stmt);
20886 -- A pragma that applies to a Ghost entity becomes Ghost for the
20887 -- purposes of legality checks and removal of ignored Ghost code.
20889 Mark_Ghost_Pragma (N, Item_Id);
20891 -- Chain the pragma on the contract for further processing by
20892 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20894 Add_Contract_Item (N, Item_Id);
20896 -- A variable may act as constituent of a single concurrent type
20897 -- which in turn could be declared after the variable. Due to this
20898 -- discrepancy, the full analysis of indicator Part_Of is delayed
20899 -- until the end of the enclosing declarative region (see routine
20900 -- Analyze_Part_Of_In_Decl_Part).
20902 if Ekind (Item_Id) = E_Variable then
20905 -- Otherwise indicator Part_Of applies to a constant or a package
20909 Encap := Get_Pragma_Arg (Arg1);
20911 -- Detect any discrepancies between the placement of the
20912 -- constant or package instantiation with respect to state
20913 -- space and the encapsulating state.
20917 Item_Id => Item_Id,
20919 Encap_Id => Encap_Id,
20923 pragma Assert (Present (Encap_Id));
20925 if Ekind (Item_Id) = E_Constant then
20926 Constits := Part_Of_Constituents (Encap_Id);
20928 if No (Constits) then
20929 Constits := New_Elmt_List;
20930 Set_Part_Of_Constituents (Encap_Id, Constits);
20933 Append_Elmt (Item_Id, Constits);
20934 Set_Encapsulating_State (Item_Id, Encap_Id);
20936 -- Propagate the Part_Of indicator to the visible state
20937 -- space of the package instantiation.
20941 (Pack_Id => Item_Id,
20942 State_Id => Encap_Id,
20949 ----------------------------------
20950 -- Partition_Elaboration_Policy --
20951 ----------------------------------
20953 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20955 when Pragma_Partition_Elaboration_Policy => PEP : declare
20956 subtype PEP_Range is Name_Id
20957 range First_Partition_Elaboration_Policy_Name
20958 .. Last_Partition_Elaboration_Policy_Name;
20959 PEP_Val : PEP_Range;
20964 Check_Arg_Count (1);
20965 Check_No_Identifiers;
20966 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
20967 Check_Valid_Configuration_Pragma;
20968 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
20971 when Name_Concurrent => PEP := 'C';
20972 when Name_Sequential => PEP := 'S';
20975 if Partition_Elaboration_Policy /= ' '
20976 and then Partition_Elaboration_Policy /= PEP
20978 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
20980 ("partition elaboration policy incompatible with policy#");
20982 -- Set new policy, but always preserve System_Location since we
20983 -- like the error message with the run time name.
20986 Partition_Elaboration_Policy := PEP;
20988 if Partition_Elaboration_Policy_Sloc /= System_Location then
20989 Partition_Elaboration_Policy_Sloc := Loc;
20998 -- pragma Passive [(PASSIVE_FORM)];
21000 -- PASSIVE_FORM ::= Semaphore | No
21002 when Pragma_Passive =>
21005 if Nkind (Parent (N)) /= N_Task_Definition then
21006 Error_Pragma ("pragma% must be within task definition");
21009 if Arg_Count /= 0 then
21010 Check_Arg_Count (1);
21011 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
21014 ----------------------------------
21015 -- Preelaborable_Initialization --
21016 ----------------------------------
21018 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21020 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
21025 Check_Arg_Count (1);
21026 Check_No_Identifiers;
21027 Check_Arg_Is_Identifier (Arg1);
21028 Check_Arg_Is_Local_Name (Arg1);
21029 Check_First_Subtype (Arg1);
21030 Ent := Entity (Get_Pragma_Arg (Arg1));
21032 -- A pragma that applies to a Ghost entity becomes Ghost for the
21033 -- purposes of legality checks and removal of ignored Ghost code.
21035 Mark_Ghost_Pragma (N, Ent);
21037 -- The pragma may come from an aspect on a private declaration,
21038 -- even if the freeze point at which this is analyzed in the
21039 -- private part after the full view.
21041 if Has_Private_Declaration (Ent)
21042 and then From_Aspect_Specification (N)
21046 -- Check appropriate type argument
21048 elsif Is_Private_Type (Ent)
21049 or else Is_Protected_Type (Ent)
21050 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
21052 -- AI05-0028: The pragma applies to all composite types. Note
21053 -- that we apply this binding interpretation to earlier versions
21054 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21055 -- choice since there are other compilers that do the same.
21057 or else Is_Composite_Type (Ent)
21063 ("pragma % can only be applied to private, formal derived, "
21064 & "protected, or composite type", Arg1);
21067 -- Give an error if the pragma is applied to a protected type that
21068 -- does not qualify (due to having entries, or due to components
21069 -- that do not qualify).
21071 if Is_Protected_Type (Ent)
21072 and then not Has_Preelaborable_Initialization (Ent)
21075 ("protected type & does not have preelaborable "
21076 & "initialization", Ent);
21078 -- Otherwise mark the type as definitely having preelaborable
21082 Set_Known_To_Have_Preelab_Init (Ent);
21085 if Has_Pragma_Preelab_Init (Ent)
21086 and then Warn_On_Redundant_Constructs
21088 Error_Pragma ("?r?duplicate pragma%!");
21090 Set_Has_Pragma_Preelab_Init (Ent);
21094 --------------------
21095 -- Persistent_BSS --
21096 --------------------
21098 -- pragma Persistent_BSS [(object_NAME)];
21100 when Pragma_Persistent_BSS => Persistent_BSS : declare
21107 Check_At_Most_N_Arguments (1);
21109 -- Case of application to specific object (one argument)
21111 if Arg_Count = 1 then
21112 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21114 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
21116 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
21119 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
21122 Ent := Entity (Get_Pragma_Arg (Arg1));
21124 -- A pragma that applies to a Ghost entity becomes Ghost for
21125 -- the purposes of legality checks and removal of ignored Ghost
21128 Mark_Ghost_Pragma (N, Ent);
21130 -- Check for duplication before inserting in list of
21131 -- representation items.
21133 Check_Duplicate_Pragma (Ent);
21135 if Rep_Item_Too_Late (Ent, N) then
21139 Decl := Parent (Ent);
21141 if Present (Expression (Decl)) then
21143 ("object for pragma% cannot have initialization", Arg1);
21146 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
21148 ("object type for pragma% is not potentially persistent",
21153 Make_Linker_Section_Pragma
21154 (Ent, Sloc (N), ".persistent.bss");
21155 Insert_After (N, Prag);
21158 -- Case of use as configuration pragma with no arguments
21161 Check_Valid_Configuration_Pragma;
21162 Persistent_BSS_Mode := True;
21164 end Persistent_BSS;
21166 --------------------
21167 -- Rename_Pragma --
21168 --------------------
21170 -- pragma Rename_Pragma (
21171 -- [New_Name =>] IDENTIFIER,
21172 -- [Renamed =>] pragma_IDENTIFIER);
21174 when Pragma_Rename_Pragma => Rename_Pragma : declare
21175 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
21176 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
21180 Check_Valid_Configuration_Pragma;
21181 Check_Arg_Count (2);
21182 Check_Optional_Identifier (Arg1, Name_New_Name);
21183 Check_Optional_Identifier (Arg2, Name_Renamed);
21185 if Nkind (New_Name) /= N_Identifier then
21186 Error_Pragma_Arg ("identifier expected", Arg1);
21189 if Nkind (Old_Name) /= N_Identifier then
21190 Error_Pragma_Arg ("identifier expected", Arg2);
21193 -- The New_Name arg should not be an existing pragma (but we allow
21194 -- it; it's just a warning). The Old_Name arg must be an existing
21197 if Is_Pragma_Name (Chars (New_Name)) then
21198 Error_Pragma_Arg ("??pragma is already defined", Arg1);
21201 if not Is_Pragma_Name (Chars (Old_Name)) then
21202 Error_Pragma_Arg ("existing pragma name expected", Arg1);
21205 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
21212 -- pragma Polling (ON | OFF);
21214 when Pragma_Polling =>
21216 Check_Arg_Count (1);
21217 Check_No_Identifiers;
21218 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21219 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
21221 -----------------------------------
21222 -- Post/Post_Class/Postcondition --
21223 -----------------------------------
21225 -- pragma Post (Boolean_EXPRESSION);
21226 -- pragma Post_Class (Boolean_EXPRESSION);
21227 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21228 -- [,[Message =>] String_EXPRESSION]);
21230 -- Characteristics:
21232 -- * Analysis - The annotation undergoes initial checks to verify
21233 -- the legal placement and context. Secondary checks preanalyze the
21236 -- Analyze_Pre_Post_Condition_In_Decl_Part
21238 -- * Expansion - The annotation is expanded during the expansion of
21239 -- the related subprogram [body] contract as performed in:
21241 -- Expand_Subprogram_Contract
21243 -- * Template - The annotation utilizes the generic template of the
21244 -- related subprogram [body] when it is:
21246 -- aspect on subprogram declaration
21247 -- aspect on stand-alone subprogram body
21248 -- pragma on stand-alone subprogram body
21250 -- The annotation must prepare its own template when it is:
21252 -- pragma on subprogram declaration
21254 -- * Globals - Capture of global references must occur after full
21257 -- * Instance - The annotation is instantiated automatically when
21258 -- the related generic subprogram [body] is instantiated except for
21259 -- the "pragma on subprogram declaration" case. In that scenario
21260 -- the annotation must instantiate itself.
21263 | Pragma_Post_Class
21264 | Pragma_Postcondition
21266 Analyze_Pre_Post_Condition;
21268 --------------------------------
21269 -- Pre/Pre_Class/Precondition --
21270 --------------------------------
21272 -- pragma Pre (Boolean_EXPRESSION);
21273 -- pragma Pre_Class (Boolean_EXPRESSION);
21274 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21275 -- [,[Message =>] String_EXPRESSION]);
21277 -- Characteristics:
21279 -- * Analysis - The annotation undergoes initial checks to verify
21280 -- the legal placement and context. Secondary checks preanalyze the
21283 -- Analyze_Pre_Post_Condition_In_Decl_Part
21285 -- * Expansion - The annotation is expanded during the expansion of
21286 -- the related subprogram [body] contract as performed in:
21288 -- Expand_Subprogram_Contract
21290 -- * Template - The annotation utilizes the generic template of the
21291 -- related subprogram [body] when it is:
21293 -- aspect on subprogram declaration
21294 -- aspect on stand-alone subprogram body
21295 -- pragma on stand-alone subprogram body
21297 -- The annotation must prepare its own template when it is:
21299 -- pragma on subprogram declaration
21301 -- * Globals - Capture of global references must occur after full
21304 -- * Instance - The annotation is instantiated automatically when
21305 -- the related generic subprogram [body] is instantiated except for
21306 -- the "pragma on subprogram declaration" case. In that scenario
21307 -- the annotation must instantiate itself.
21311 | Pragma_Precondition
21313 Analyze_Pre_Post_Condition;
21319 -- pragma Predicate
21320 -- ([Entity =>] type_LOCAL_NAME,
21321 -- [Check =>] boolean_EXPRESSION);
21323 when Pragma_Predicate => Predicate : declare
21330 Check_Arg_Count (2);
21331 Check_Optional_Identifier (Arg1, Name_Entity);
21332 Check_Optional_Identifier (Arg2, Name_Check);
21334 Check_Arg_Is_Local_Name (Arg1);
21336 Type_Id := Get_Pragma_Arg (Arg1);
21337 Find_Type (Type_Id);
21338 Typ := Entity (Type_Id);
21340 if Typ = Any_Type then
21344 -- A pragma that applies to a Ghost entity becomes Ghost for the
21345 -- purposes of legality checks and removal of ignored Ghost code.
21347 Mark_Ghost_Pragma (N, Typ);
21349 -- The remaining processing is simply to link the pragma on to
21350 -- the rep item chain, for processing when the type is frozen.
21351 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21352 -- mark the type as having predicates.
21354 -- If the current policy for predicate checking is Ignore mark the
21355 -- subtype accordingly. In the case of predicates we consider them
21356 -- enabled unless Ignore is specified (either directly or with a
21357 -- general Assertion_Policy pragma) to preserve existing warnings.
21359 Set_Has_Predicates (Typ);
21361 -- Indicate that the pragma must be processed at the point the
21362 -- type is frozen, as is done for the corresponding aspect.
21364 Set_Has_Delayed_Aspects (Typ);
21365 Set_Has_Delayed_Freeze (Typ);
21367 Set_Predicates_Ignored (Typ,
21368 Present (Check_Policy_List)
21370 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
21371 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21374 -----------------------
21375 -- Predicate_Failure --
21376 -----------------------
21378 -- pragma Predicate_Failure
21379 -- ([Entity =>] type_LOCAL_NAME,
21380 -- [Message =>] string_EXPRESSION);
21382 when Pragma_Predicate_Failure => Predicate_Failure : declare
21389 Check_Arg_Count (2);
21390 Check_Optional_Identifier (Arg1, Name_Entity);
21391 Check_Optional_Identifier (Arg2, Name_Message);
21393 Check_Arg_Is_Local_Name (Arg1);
21395 Type_Id := Get_Pragma_Arg (Arg1);
21396 Find_Type (Type_Id);
21397 Typ := Entity (Type_Id);
21399 if Typ = Any_Type then
21403 -- A pragma that applies to a Ghost entity becomes Ghost for the
21404 -- purposes of legality checks and removal of ignored Ghost code.
21406 Mark_Ghost_Pragma (N, Typ);
21408 -- The remaining processing is simply to link the pragma on to
21409 -- the rep item chain, for processing when the type is frozen.
21410 -- This is accomplished by a call to Rep_Item_Too_Late.
21412 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
21413 end Predicate_Failure;
21419 -- pragma Preelaborate [(library_unit_NAME)];
21421 -- Set the flag Is_Preelaborated of program unit name entity
21423 when Pragma_Preelaborate => Preelaborate : declare
21424 Pa : constant Node_Id := Parent (N);
21425 Pk : constant Node_Kind := Nkind (Pa);
21429 Check_Ada_83_Warning;
21430 Check_Valid_Library_Unit_Pragma;
21432 if Nkind (N) = N_Null_Statement then
21436 Ent := Find_Lib_Unit_Name;
21438 -- A pragma that applies to a Ghost entity becomes Ghost for the
21439 -- purposes of legality checks and removal of ignored Ghost code.
21441 Mark_Ghost_Pragma (N, Ent);
21442 Check_Duplicate_Pragma (Ent);
21444 -- This filters out pragmas inside generic parents that show up
21445 -- inside instantiations. Pragmas that come from aspects in the
21446 -- unit are not ignored.
21448 if Present (Ent) then
21449 if Pk = N_Package_Specification
21450 and then Present (Generic_Parent (Pa))
21451 and then not From_Aspect_Specification (N)
21456 if not Debug_Flag_U then
21457 Set_Is_Preelaborated (Ent);
21459 if Legacy_Elaboration_Checks then
21460 Set_Suppress_Elaboration_Warnings (Ent);
21467 -------------------------------
21468 -- Prefix_Exception_Messages --
21469 -------------------------------
21471 -- pragma Prefix_Exception_Messages;
21473 when Pragma_Prefix_Exception_Messages =>
21475 Check_Valid_Configuration_Pragma;
21476 Check_Arg_Count (0);
21477 Prefix_Exception_Messages := True;
21483 -- pragma Priority (EXPRESSION);
21485 when Pragma_Priority => Priority : declare
21486 P : constant Node_Id := Parent (N);
21491 Check_No_Identifiers;
21492 Check_Arg_Count (1);
21496 if Nkind (P) = N_Subprogram_Body then
21497 Check_In_Main_Program;
21499 Ent := Defining_Unit_Name (Specification (P));
21501 if Nkind (Ent) = N_Defining_Program_Unit_Name then
21502 Ent := Defining_Identifier (Ent);
21505 Arg := Get_Pragma_Arg (Arg1);
21506 Analyze_And_Resolve (Arg, Standard_Integer);
21510 if not Is_OK_Static_Expression (Arg) then
21511 Flag_Non_Static_Expr
21512 ("main subprogram priority is not static!", Arg);
21515 -- If constraint error, then we already signalled an error
21517 elsif Raises_Constraint_Error (Arg) then
21520 -- Otherwise check in range except if Relaxed_RM_Semantics
21521 -- where we ignore the value if out of range.
21524 if not Relaxed_RM_Semantics
21525 and then not Is_In_Range (Arg, RTE (RE_Priority))
21528 ("main subprogram priority is out of range", Arg1);
21531 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
21535 -- Load an arbitrary entity from System.Tasking.Stages or
21536 -- System.Tasking.Restricted.Stages (depending on the
21537 -- supported profile) to make sure that one of these packages
21538 -- is implicitly with'ed, since we need to have the tasking
21539 -- run time active for the pragma Priority to have any effect.
21540 -- Previously we with'ed the package System.Tasking, but this
21541 -- package does not trigger the required initialization of the
21542 -- run-time library.
21545 Discard : Entity_Id;
21546 pragma Warnings (Off, Discard);
21548 if Restricted_Profile then
21549 Discard := RTE (RE_Activate_Restricted_Tasks);
21551 Discard := RTE (RE_Activate_Tasks);
21555 -- Task or Protected, must be of type Integer
21557 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
21558 Arg := Get_Pragma_Arg (Arg1);
21559 Ent := Defining_Identifier (Parent (P));
21561 -- The expression must be analyzed in the special manner
21562 -- described in "Handling of Default and Per-Object
21563 -- Expressions" in sem.ads.
21565 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
21567 if not Is_OK_Static_Expression (Arg) then
21568 Check_Restriction (Static_Priorities, Arg);
21571 -- Anything else is incorrect
21577 -- Check duplicate pragma before we chain the pragma in the Rep
21578 -- Item chain of Ent.
21580 Check_Duplicate_Pragma (Ent);
21581 Record_Rep_Item (Ent, N);
21584 -----------------------------------
21585 -- Priority_Specific_Dispatching --
21586 -----------------------------------
21588 -- pragma Priority_Specific_Dispatching (
21589 -- policy_IDENTIFIER,
21590 -- first_priority_EXPRESSION,
21591 -- last_priority_EXPRESSION);
21593 when Pragma_Priority_Specific_Dispatching =>
21594 Priority_Specific_Dispatching : declare
21595 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
21596 -- This is the entity System.Any_Priority;
21599 Lower_Bound : Node_Id;
21600 Upper_Bound : Node_Id;
21606 Check_Arg_Count (3);
21607 Check_No_Identifiers;
21608 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21609 Check_Valid_Configuration_Pragma;
21610 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21611 DP := Fold_Upper (Name_Buffer (1));
21613 Lower_Bound := Get_Pragma_Arg (Arg2);
21614 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
21615 Lower_Val := Expr_Value (Lower_Bound);
21617 Upper_Bound := Get_Pragma_Arg (Arg3);
21618 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
21619 Upper_Val := Expr_Value (Upper_Bound);
21621 -- It is not allowed to use Task_Dispatching_Policy and
21622 -- Priority_Specific_Dispatching in the same partition.
21624 if Task_Dispatching_Policy /= ' ' then
21625 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21627 ("pragma% incompatible with Task_Dispatching_Policy#");
21629 -- Check lower bound in range
21631 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21633 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
21636 ("first_priority is out of range", Arg2);
21638 -- Check upper bound in range
21640 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
21642 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
21645 ("last_priority is out of range", Arg3);
21647 -- Check that the priority range is valid
21649 elsif Lower_Val > Upper_Val then
21651 ("last_priority_expression must be greater than or equal to "
21652 & "first_priority_expression");
21654 -- Store the new policy, but always preserve System_Location since
21655 -- we like the error message with the run-time name.
21658 -- Check overlapping in the priority ranges specified in other
21659 -- Priority_Specific_Dispatching pragmas within the same
21660 -- partition. We can only check those we know about.
21663 Specific_Dispatching.First .. Specific_Dispatching.Last
21665 if Specific_Dispatching.Table (J).First_Priority in
21666 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21667 or else Specific_Dispatching.Table (J).Last_Priority in
21668 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
21671 Specific_Dispatching.Table (J).Pragma_Loc;
21673 ("priority range overlaps with "
21674 & "Priority_Specific_Dispatching#");
21678 -- The use of Priority_Specific_Dispatching is incompatible
21679 -- with Task_Dispatching_Policy.
21681 if Task_Dispatching_Policy /= ' ' then
21682 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21684 ("Priority_Specific_Dispatching incompatible "
21685 & "with Task_Dispatching_Policy#");
21688 -- The use of Priority_Specific_Dispatching forces ceiling
21691 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
21692 Error_Msg_Sloc := Locking_Policy_Sloc;
21694 ("Priority_Specific_Dispatching incompatible "
21695 & "with Locking_Policy#");
21697 -- Set the Ceiling_Locking policy, but preserve System_Location
21698 -- since we like the error message with the run time name.
21701 Locking_Policy := 'C';
21703 if Locking_Policy_Sloc /= System_Location then
21704 Locking_Policy_Sloc := Loc;
21708 -- Add entry in the table
21710 Specific_Dispatching.Append
21711 ((Dispatching_Policy => DP,
21712 First_Priority => UI_To_Int (Lower_Val),
21713 Last_Priority => UI_To_Int (Upper_Val),
21714 Pragma_Loc => Loc));
21716 end Priority_Specific_Dispatching;
21722 -- pragma Profile (profile_IDENTIFIER);
21724 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21726 when Pragma_Profile =>
21728 Check_Arg_Count (1);
21729 Check_Valid_Configuration_Pragma;
21730 Check_No_Identifiers;
21733 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21736 if Chars (Argx) = Name_Ravenscar then
21737 Set_Ravenscar_Profile (Ravenscar, N);
21739 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
21740 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
21742 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then
21743 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N);
21745 elsif Chars (Argx) = Name_Restricted then
21746 Set_Profile_Restrictions
21748 N, Warn => Treat_Restrictions_As_Warnings);
21750 elsif Chars (Argx) = Name_Rational then
21751 Set_Rational_Profile;
21753 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21754 Set_Profile_Restrictions
21755 (No_Implementation_Extensions,
21756 N, Warn => Treat_Restrictions_As_Warnings);
21759 Error_Pragma_Arg ("& is not a valid profile", Argx);
21763 ----------------------
21764 -- Profile_Warnings --
21765 ----------------------
21767 -- pragma Profile_Warnings (profile_IDENTIFIER);
21769 -- profile_IDENTIFIER => Restricted | Ravenscar
21771 when Pragma_Profile_Warnings =>
21773 Check_Arg_Count (1);
21774 Check_Valid_Configuration_Pragma;
21775 Check_No_Identifiers;
21778 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21781 if Chars (Argx) = Name_Ravenscar then
21782 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
21784 elsif Chars (Argx) = Name_Restricted then
21785 Set_Profile_Restrictions (Restricted, N, Warn => True);
21787 elsif Chars (Argx) = Name_No_Implementation_Extensions then
21788 Set_Profile_Restrictions
21789 (No_Implementation_Extensions, N, Warn => True);
21792 Error_Pragma_Arg ("& is not a valid profile", Argx);
21796 --------------------------
21797 -- Propagate_Exceptions --
21798 --------------------------
21800 -- pragma Propagate_Exceptions;
21802 -- Note: this pragma is obsolete and has no effect
21804 when Pragma_Propagate_Exceptions =>
21806 Check_Arg_Count (0);
21808 if Warn_On_Obsolescent_Feature then
21810 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21811 "and has no effect?j?", N);
21814 -----------------------------
21815 -- Provide_Shift_Operators --
21816 -----------------------------
21818 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21820 when Pragma_Provide_Shift_Operators =>
21821 Provide_Shift_Operators : declare
21824 procedure Declare_Shift_Operator (Nam : Name_Id);
21825 -- Insert declaration and pragma Instrinsic for named shift op
21827 ----------------------------
21828 -- Declare_Shift_Operator --
21829 ----------------------------
21831 procedure Declare_Shift_Operator (Nam : Name_Id) is
21837 Make_Subprogram_Declaration (Loc,
21838 Make_Function_Specification (Loc,
21839 Defining_Unit_Name =>
21840 Make_Defining_Identifier (Loc, Chars => Nam),
21842 Result_Definition =>
21843 Make_Identifier (Loc, Chars => Chars (Ent)),
21845 Parameter_Specifications => New_List (
21846 Make_Parameter_Specification (Loc,
21847 Defining_Identifier =>
21848 Make_Defining_Identifier (Loc, Name_Value),
21850 Make_Identifier (Loc, Chars => Chars (Ent))),
21852 Make_Parameter_Specification (Loc,
21853 Defining_Identifier =>
21854 Make_Defining_Identifier (Loc, Name_Amount),
21856 New_Occurrence_Of (Standard_Natural, Loc)))));
21860 Chars => Name_Import,
21861 Pragma_Argument_Associations => New_List (
21862 Make_Pragma_Argument_Association (Loc,
21863 Expression => Make_Identifier (Loc, Name_Intrinsic)),
21864 Make_Pragma_Argument_Association (Loc,
21865 Expression => Make_Identifier (Loc, Nam))));
21867 Insert_After (N, Import);
21868 Insert_After (N, Func);
21869 end Declare_Shift_Operator;
21871 -- Start of processing for Provide_Shift_Operators
21875 Check_Arg_Count (1);
21876 Check_Arg_Is_Local_Name (Arg1);
21878 Arg1 := Get_Pragma_Arg (Arg1);
21880 -- We must have an entity name
21882 if not Is_Entity_Name (Arg1) then
21884 ("pragma % must apply to integer first subtype", Arg1);
21887 -- If no Entity, means there was a prior error so ignore
21889 if Present (Entity (Arg1)) then
21890 Ent := Entity (Arg1);
21892 -- Apply error checks
21894 if not Is_First_Subtype (Ent) then
21896 ("cannot apply pragma %",
21897 "\& is not a first subtype",
21900 elsif not Is_Integer_Type (Ent) then
21902 ("cannot apply pragma %",
21903 "\& is not an integer type",
21906 elsif Has_Shift_Operator (Ent) then
21908 ("cannot apply pragma %",
21909 "\& already has declared shift operators",
21912 elsif Is_Frozen (Ent) then
21914 ("pragma % appears too late",
21915 "\& is already frozen",
21919 -- Now declare the operators. We do this during analysis rather
21920 -- than expansion, since we want the operators available if we
21921 -- are operating in -gnatc or ASIS mode.
21923 Declare_Shift_Operator (Name_Rotate_Left);
21924 Declare_Shift_Operator (Name_Rotate_Right);
21925 Declare_Shift_Operator (Name_Shift_Left);
21926 Declare_Shift_Operator (Name_Shift_Right);
21927 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
21929 end Provide_Shift_Operators;
21935 -- pragma Psect_Object (
21936 -- [Internal =>] LOCAL_NAME,
21937 -- [, [External =>] EXTERNAL_SYMBOL]
21938 -- [, [Size =>] EXTERNAL_SYMBOL]);
21940 when Pragma_Common_Object
21941 | Pragma_Psect_Object
21943 Psect_Object : declare
21944 Args : Args_List (1 .. 3);
21945 Names : constant Name_List (1 .. 3) := (
21950 Internal : Node_Id renames Args (1);
21951 External : Node_Id renames Args (2);
21952 Size : Node_Id renames Args (3);
21954 Def_Id : Entity_Id;
21956 procedure Check_Arg (Arg : Node_Id);
21957 -- Checks that argument is either a string literal or an
21958 -- identifier, and posts error message if not.
21964 procedure Check_Arg (Arg : Node_Id) is
21966 if not Nkind_In (Original_Node (Arg),
21971 ("inappropriate argument for pragma %", Arg);
21975 -- Start of processing for Common_Object/Psect_Object
21979 Gather_Associations (Names, Args);
21980 Process_Extended_Import_Export_Internal_Arg (Internal);
21982 Def_Id := Entity (Internal);
21984 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
21986 ("pragma% must designate an object", Internal);
21989 Check_Arg (Internal);
21991 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
21993 ("cannot use pragma% for imported/exported object",
21997 if Is_Concurrent_Type (Etype (Internal)) then
21999 ("cannot specify pragma % for task/protected object",
22003 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
22005 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
22007 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
22010 if Ekind (Def_Id) = E_Constant then
22012 ("cannot specify pragma % for a constant", Internal);
22015 if Is_Record_Type (Etype (Internal)) then
22021 Ent := First_Entity (Etype (Internal));
22022 while Present (Ent) loop
22023 Decl := Declaration_Node (Ent);
22025 if Ekind (Ent) = E_Component
22026 and then Nkind (Decl) = N_Component_Declaration
22027 and then Present (Expression (Decl))
22028 and then Warn_On_Export_Import
22031 ("?x?object for pragma % has defaults", Internal);
22041 if Present (Size) then
22045 if Present (External) then
22046 Check_Arg_Is_External_Name (External);
22049 -- If all error tests pass, link pragma on to the rep item chain
22051 Record_Rep_Item (Def_Id, N);
22058 -- pragma Pure [(library_unit_NAME)];
22060 when Pragma_Pure => Pure : declare
22064 Check_Ada_83_Warning;
22066 -- If the pragma comes from a subprogram instantiation, nothing to
22067 -- check, this can happen at any level of nesting.
22069 if Is_Wrapper_Package (Current_Scope) then
22072 Check_Valid_Library_Unit_Pragma;
22075 if Nkind (N) = N_Null_Statement then
22079 Ent := Find_Lib_Unit_Name;
22081 -- A pragma that applies to a Ghost entity becomes Ghost for the
22082 -- purposes of legality checks and removal of ignored Ghost code.
22084 Mark_Ghost_Pragma (N, Ent);
22086 if not Debug_Flag_U then
22088 Set_Has_Pragma_Pure (Ent);
22090 if Legacy_Elaboration_Checks then
22091 Set_Suppress_Elaboration_Warnings (Ent);
22096 -------------------
22097 -- Pure_Function --
22098 -------------------
22100 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22102 when Pragma_Pure_Function => Pure_Function : declare
22103 Def_Id : Entity_Id;
22106 Effective : Boolean := False;
22107 Orig_Def : Entity_Id;
22108 Same_Decl : Boolean := False;
22112 Check_Arg_Count (1);
22113 Check_Optional_Identifier (Arg1, Name_Entity);
22114 Check_Arg_Is_Local_Name (Arg1);
22115 E_Id := Get_Pragma_Arg (Arg1);
22117 if Etype (E_Id) = Any_Type then
22121 -- Loop through homonyms (overloadings) of referenced entity
22123 E := Entity (E_Id);
22125 -- A pragma that applies to a Ghost entity becomes Ghost for the
22126 -- purposes of legality checks and removal of ignored Ghost code.
22128 Mark_Ghost_Pragma (N, E);
22130 if Present (E) then
22132 Def_Id := Get_Base_Subprogram (E);
22134 if not Ekind_In (Def_Id, E_Function,
22135 E_Generic_Function,
22139 ("pragma% requires a function name", Arg1);
22142 -- When we have a generic function we must jump up a level
22143 -- to the declaration of the wrapper package itself.
22145 Orig_Def := Def_Id;
22147 if Is_Generic_Instance (Def_Id) then
22148 while Nkind (Orig_Def) /= N_Package_Declaration loop
22149 Orig_Def := Parent (Orig_Def);
22153 if In_Same_Declarative_Part (Parent (N), Orig_Def) then
22155 Set_Is_Pure (Def_Id);
22157 if not Has_Pragma_Pure_Function (Def_Id) then
22158 Set_Has_Pragma_Pure_Function (Def_Id);
22163 exit when From_Aspect_Specification (N);
22165 exit when No (E) or else Scope (E) /= Current_Scope;
22169 and then Warn_On_Redundant_Constructs
22172 ("pragma Pure_Function on& is redundant?r?",
22175 elsif not Same_Decl then
22177 ("pragma% argument must be in same declarative part",
22183 --------------------
22184 -- Queuing_Policy --
22185 --------------------
22187 -- pragma Queuing_Policy (policy_IDENTIFIER);
22189 when Pragma_Queuing_Policy => declare
22193 Check_Ada_83_Warning;
22194 Check_Arg_Count (1);
22195 Check_No_Identifiers;
22196 Check_Arg_Is_Queuing_Policy (Arg1);
22197 Check_Valid_Configuration_Pragma;
22198 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22199 QP := Fold_Upper (Name_Buffer (1));
22201 if Queuing_Policy /= ' '
22202 and then Queuing_Policy /= QP
22204 Error_Msg_Sloc := Queuing_Policy_Sloc;
22205 Error_Pragma ("queuing policy incompatible with policy#");
22207 -- Set new policy, but always preserve System_Location since we
22208 -- like the error message with the run time name.
22211 Queuing_Policy := QP;
22213 if Queuing_Policy_Sloc /= System_Location then
22214 Queuing_Policy_Sloc := Loc;
22223 -- pragma Rational, for compatibility with foreign compiler
22225 when Pragma_Rational =>
22226 Set_Rational_Profile;
22228 ---------------------
22229 -- Refined_Depends --
22230 ---------------------
22232 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22234 -- DEPENDENCY_RELATION ::=
22236 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22238 -- DEPENDENCY_CLAUSE ::=
22239 -- OUTPUT_LIST =>[+] INPUT_LIST
22240 -- | NULL_DEPENDENCY_CLAUSE
22242 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22244 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22246 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22248 -- OUTPUT ::= NAME | FUNCTION_RESULT
22251 -- where FUNCTION_RESULT is a function Result attribute_reference
22253 -- Characteristics:
22255 -- * Analysis - The annotation undergoes initial checks to verify
22256 -- the legal placement and context. Secondary checks fully analyze
22257 -- the dependency clauses/global list in:
22259 -- Analyze_Refined_Depends_In_Decl_Part
22261 -- * Expansion - None.
22263 -- * Template - The annotation utilizes the generic template of the
22264 -- related subprogram body.
22266 -- * Globals - Capture of global references must occur after full
22269 -- * Instance - The annotation is instantiated automatically when
22270 -- the related generic subprogram body is instantiated.
22272 when Pragma_Refined_Depends => Refined_Depends : declare
22273 Body_Id : Entity_Id;
22275 Spec_Id : Entity_Id;
22278 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22282 -- Chain the pragma on the contract for further processing by
22283 -- Analyze_Refined_Depends_In_Decl_Part.
22285 Add_Contract_Item (N, Body_Id);
22287 -- The legality checks of pragmas Refined_Depends and
22288 -- Refined_Global are affected by the SPARK mode in effect and
22289 -- the volatility of the context. In addition these two pragmas
22290 -- are subject to an inherent order:
22292 -- 1) Refined_Global
22293 -- 2) Refined_Depends
22295 -- Analyze all these pragmas in the order outlined above
22297 Analyze_If_Present (Pragma_SPARK_Mode);
22298 Analyze_If_Present (Pragma_Volatile_Function);
22299 Analyze_If_Present (Pragma_Refined_Global);
22300 Analyze_Refined_Depends_In_Decl_Part (N);
22302 end Refined_Depends;
22304 --------------------
22305 -- Refined_Global --
22306 --------------------
22308 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22310 -- GLOBAL_SPECIFICATION ::=
22313 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22315 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22317 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22318 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22319 -- GLOBAL_ITEM ::= NAME
22321 -- Characteristics:
22323 -- * Analysis - The annotation undergoes initial checks to verify
22324 -- the legal placement and context. Secondary checks fully analyze
22325 -- the dependency clauses/global list in:
22327 -- Analyze_Refined_Global_In_Decl_Part
22329 -- * Expansion - None.
22331 -- * Template - The annotation utilizes the generic template of the
22332 -- related subprogram body.
22334 -- * Globals - Capture of global references must occur after full
22337 -- * Instance - The annotation is instantiated automatically when
22338 -- the related generic subprogram body is instantiated.
22340 when Pragma_Refined_Global => Refined_Global : declare
22341 Body_Id : Entity_Id;
22343 Spec_Id : Entity_Id;
22346 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22350 -- Chain the pragma on the contract for further processing by
22351 -- Analyze_Refined_Global_In_Decl_Part.
22353 Add_Contract_Item (N, Body_Id);
22355 -- The legality checks of pragmas Refined_Depends and
22356 -- Refined_Global are affected by the SPARK mode in effect and
22357 -- the volatility of the context. In addition these two pragmas
22358 -- are subject to an inherent order:
22360 -- 1) Refined_Global
22361 -- 2) Refined_Depends
22363 -- Analyze all these pragmas in the order outlined above
22365 Analyze_If_Present (Pragma_SPARK_Mode);
22366 Analyze_If_Present (Pragma_Volatile_Function);
22367 Analyze_Refined_Global_In_Decl_Part (N);
22368 Analyze_If_Present (Pragma_Refined_Depends);
22370 end Refined_Global;
22376 -- pragma Refined_Post (boolean_EXPRESSION);
22378 -- Characteristics:
22380 -- * Analysis - The annotation is fully analyzed immediately upon
22381 -- elaboration as it cannot forward reference entities.
22383 -- * Expansion - The annotation is expanded during the expansion of
22384 -- the related subprogram body contract as performed in:
22386 -- Expand_Subprogram_Contract
22388 -- * Template - The annotation utilizes the generic template of the
22389 -- related subprogram body.
22391 -- * Globals - Capture of global references must occur after full
22394 -- * Instance - The annotation is instantiated automatically when
22395 -- the related generic subprogram body is instantiated.
22397 when Pragma_Refined_Post => Refined_Post : declare
22398 Body_Id : Entity_Id;
22400 Spec_Id : Entity_Id;
22403 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
22405 -- Fully analyze the pragma when it appears inside a subprogram
22406 -- body because it cannot benefit from forward references.
22410 -- Chain the pragma on the contract for completeness
22412 Add_Contract_Item (N, Body_Id);
22414 -- The legality checks of pragma Refined_Post are affected by
22415 -- the SPARK mode in effect and the volatility of the context.
22416 -- Analyze all pragmas in a specific order.
22418 Analyze_If_Present (Pragma_SPARK_Mode);
22419 Analyze_If_Present (Pragma_Volatile_Function);
22420 Analyze_Pre_Post_Condition_In_Decl_Part (N);
22422 -- Currently it is not possible to inline pre/postconditions on
22423 -- a subprogram subject to pragma Inline_Always.
22425 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
22429 -------------------
22430 -- Refined_State --
22431 -------------------
22433 -- pragma Refined_State (REFINEMENT_LIST);
22435 -- REFINEMENT_LIST ::=
22436 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22438 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22440 -- CONSTITUENT_LIST ::=
22443 -- | (CONSTITUENT {, CONSTITUENT})
22445 -- CONSTITUENT ::= object_NAME | state_NAME
22447 -- Characteristics:
22449 -- * Analysis - The annotation undergoes initial checks to verify
22450 -- the legal placement and context. Secondary checks preanalyze the
22451 -- refinement clauses in:
22453 -- Analyze_Refined_State_In_Decl_Part
22455 -- * Expansion - None.
22457 -- * Template - The annotation utilizes the template of the related
22460 -- * Globals - Capture of global references must occur after full
22463 -- * Instance - The annotation is instantiated automatically when
22464 -- the related generic package body is instantiated.
22466 when Pragma_Refined_State => Refined_State : declare
22467 Pack_Decl : Node_Id;
22468 Spec_Id : Entity_Id;
22472 Check_No_Identifiers;
22473 Check_Arg_Count (1);
22475 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
22477 if Nkind (Pack_Decl) /= N_Package_Body then
22482 Spec_Id := Corresponding_Spec (Pack_Decl);
22484 -- A pragma that applies to a Ghost entity becomes Ghost for the
22485 -- purposes of legality checks and removal of ignored Ghost code.
22487 Mark_Ghost_Pragma (N, Spec_Id);
22489 -- Chain the pragma on the contract for further processing by
22490 -- Analyze_Refined_State_In_Decl_Part.
22492 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
22494 -- The legality checks of pragma Refined_State are affected by the
22495 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22497 Analyze_If_Present (Pragma_SPARK_Mode);
22499 -- State refinement is allowed only when the corresponding package
22500 -- declaration has non-null pragma Abstract_State. Refinement not
22501 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22503 if SPARK_Mode /= Off
22505 (No (Abstract_States (Spec_Id))
22506 or else Has_Null_Abstract_State (Spec_Id))
22509 ("useless refinement, package & does not define abstract "
22510 & "states", N, Spec_Id);
22515 -----------------------
22516 -- Relative_Deadline --
22517 -----------------------
22519 -- pragma Relative_Deadline (time_span_EXPRESSION);
22521 when Pragma_Relative_Deadline => Relative_Deadline : declare
22522 P : constant Node_Id := Parent (N);
22527 Check_No_Identifiers;
22528 Check_Arg_Count (1);
22530 Arg := Get_Pragma_Arg (Arg1);
22532 -- The expression must be analyzed in the special manner described
22533 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22535 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
22539 if Nkind (P) = N_Subprogram_Body then
22540 Check_In_Main_Program;
22542 -- Only Task and subprogram cases allowed
22544 elsif Nkind (P) /= N_Task_Definition then
22548 -- Check duplicate pragma before we set the corresponding flag
22550 if Has_Relative_Deadline_Pragma (P) then
22551 Error_Pragma ("duplicate pragma% not allowed");
22554 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22555 -- Relative_Deadline pragma node cannot be inserted in the Rep
22556 -- Item chain of Ent since it is rewritten by the expander as a
22557 -- procedure call statement that will break the chain.
22559 Set_Has_Relative_Deadline_Pragma (P);
22560 end Relative_Deadline;
22562 ------------------------
22563 -- Remote_Access_Type --
22564 ------------------------
22566 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22568 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
22573 Check_Arg_Count (1);
22574 Check_Optional_Identifier (Arg1, Name_Entity);
22575 Check_Arg_Is_Local_Name (Arg1);
22577 E := Entity (Get_Pragma_Arg (Arg1));
22579 -- A pragma that applies to a Ghost entity becomes Ghost for the
22580 -- purposes of legality checks and removal of ignored Ghost code.
22582 Mark_Ghost_Pragma (N, E);
22584 if Nkind (Parent (E)) = N_Formal_Type_Declaration
22585 and then Ekind (E) = E_General_Access_Type
22586 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
22587 and then Scope (Root_Type (Directly_Designated_Type (E)))
22589 and then Is_Valid_Remote_Object_Type
22590 (Root_Type (Directly_Designated_Type (E)))
22592 Set_Is_Remote_Types (E);
22596 ("pragma% applies only to formal access-to-class-wide types",
22599 end Remote_Access_Type;
22601 ---------------------------
22602 -- Remote_Call_Interface --
22603 ---------------------------
22605 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22607 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
22608 Cunit_Node : Node_Id;
22609 Cunit_Ent : Entity_Id;
22613 Check_Ada_83_Warning;
22614 Check_Valid_Library_Unit_Pragma;
22616 if Nkind (N) = N_Null_Statement then
22620 Cunit_Node := Cunit (Current_Sem_Unit);
22621 K := Nkind (Unit (Cunit_Node));
22622 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22624 -- A pragma that applies to a Ghost entity becomes Ghost for the
22625 -- purposes of legality checks and removal of ignored Ghost code.
22627 Mark_Ghost_Pragma (N, Cunit_Ent);
22629 if K = N_Package_Declaration
22630 or else K = N_Generic_Package_Declaration
22631 or else K = N_Subprogram_Declaration
22632 or else K = N_Generic_Subprogram_Declaration
22633 or else (K = N_Subprogram_Body
22634 and then Acts_As_Spec (Unit (Cunit_Node)))
22639 "pragma% must apply to package or subprogram declaration");
22642 Set_Is_Remote_Call_Interface (Cunit_Ent);
22643 end Remote_Call_Interface;
22649 -- pragma Remote_Types [(library_unit_NAME)];
22651 when Pragma_Remote_Types => Remote_Types : declare
22652 Cunit_Node : Node_Id;
22653 Cunit_Ent : Entity_Id;
22656 Check_Ada_83_Warning;
22657 Check_Valid_Library_Unit_Pragma;
22659 if Nkind (N) = N_Null_Statement then
22663 Cunit_Node := Cunit (Current_Sem_Unit);
22664 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22666 -- A pragma that applies to a Ghost entity becomes Ghost for the
22667 -- purposes of legality checks and removal of ignored Ghost code.
22669 Mark_Ghost_Pragma (N, Cunit_Ent);
22671 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22672 N_Generic_Package_Declaration)
22675 ("pragma% can only apply to a package declaration");
22678 Set_Is_Remote_Types (Cunit_Ent);
22685 -- pragma Ravenscar;
22687 when Pragma_Ravenscar =>
22689 Check_Arg_Count (0);
22690 Check_Valid_Configuration_Pragma;
22691 Set_Ravenscar_Profile (Ravenscar, N);
22693 if Warn_On_Obsolescent_Feature then
22695 ("pragma Ravenscar is an obsolescent feature?j?", N);
22697 ("|use pragma Profile (Ravenscar) instead?j?", N);
22700 -------------------------
22701 -- Restricted_Run_Time --
22702 -------------------------
22704 -- pragma Restricted_Run_Time;
22706 when Pragma_Restricted_Run_Time =>
22708 Check_Arg_Count (0);
22709 Check_Valid_Configuration_Pragma;
22710 Set_Profile_Restrictions
22711 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
22713 if Warn_On_Obsolescent_Feature then
22715 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22718 ("|use pragma Profile (Restricted) instead?j?", N);
22725 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22728 -- restriction_IDENTIFIER
22729 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22731 when Pragma_Restrictions =>
22732 Process_Restrictions_Or_Restriction_Warnings
22733 (Warn => Treat_Restrictions_As_Warnings);
22735 --------------------------
22736 -- Restriction_Warnings --
22737 --------------------------
22739 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22742 -- restriction_IDENTIFIER
22743 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22745 when Pragma_Restriction_Warnings =>
22747 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
22753 -- pragma Reviewable;
22755 when Pragma_Reviewable =>
22756 Check_Ada_83_Warning;
22757 Check_Arg_Count (0);
22759 -- Call dummy debugging function rv. This is done to assist front
22760 -- end debugging. By placing a Reviewable pragma in the source
22761 -- program, a breakpoint on rv catches this place in the source,
22762 -- allowing convenient stepping to the point of interest.
22766 --------------------------
22767 -- Secondary_Stack_Size --
22768 --------------------------
22770 -- pragma Secondary_Stack_Size (EXPRESSION);
22772 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
22773 P : constant Node_Id := Parent (N);
22779 Check_No_Identifiers;
22780 Check_Arg_Count (1);
22782 if Nkind (P) = N_Task_Definition then
22783 Arg := Get_Pragma_Arg (Arg1);
22784 Ent := Defining_Identifier (Parent (P));
22786 -- The expression must be analyzed in the special manner
22787 -- described in "Handling of Default Expressions" in sem.ads.
22789 Preanalyze_Spec_Expression (Arg, Any_Integer);
22791 -- The pragma cannot appear if the No_Secondary_Stack
22792 -- restriction is in effect.
22794 Check_Restriction (No_Secondary_Stack, Arg);
22796 -- Anything else is incorrect
22802 -- Check duplicate pragma before we chain the pragma in the Rep
22803 -- Item chain of Ent.
22805 Check_Duplicate_Pragma (Ent);
22806 Record_Rep_Item (Ent, N);
22807 end Secondary_Stack_Size;
22809 --------------------------
22810 -- Short_Circuit_And_Or --
22811 --------------------------
22813 -- pragma Short_Circuit_And_Or;
22815 when Pragma_Short_Circuit_And_Or =>
22817 Check_Arg_Count (0);
22818 Check_Valid_Configuration_Pragma;
22819 Short_Circuit_And_Or := True;
22821 -------------------
22822 -- Share_Generic --
22823 -------------------
22825 -- pragma Share_Generic (GNAME {, GNAME});
22827 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22829 when Pragma_Share_Generic =>
22831 Process_Generic_List;
22837 -- pragma Shared (LOCAL_NAME);
22839 when Pragma_Shared =>
22841 Process_Atomic_Independent_Shared_Volatile;
22843 --------------------
22844 -- Shared_Passive --
22845 --------------------
22847 -- pragma Shared_Passive [(library_unit_NAME)];
22849 -- Set the flag Is_Shared_Passive of program unit name entity
22851 when Pragma_Shared_Passive => Shared_Passive : declare
22852 Cunit_Node : Node_Id;
22853 Cunit_Ent : Entity_Id;
22856 Check_Ada_83_Warning;
22857 Check_Valid_Library_Unit_Pragma;
22859 if Nkind (N) = N_Null_Statement then
22863 Cunit_Node := Cunit (Current_Sem_Unit);
22864 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
22866 -- A pragma that applies to a Ghost entity becomes Ghost for the
22867 -- purposes of legality checks and removal of ignored Ghost code.
22869 Mark_Ghost_Pragma (N, Cunit_Ent);
22871 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
22872 N_Generic_Package_Declaration)
22875 ("pragma% can only apply to a package declaration");
22878 Set_Is_Shared_Passive (Cunit_Ent);
22879 end Shared_Passive;
22881 -----------------------
22882 -- Short_Descriptors --
22883 -----------------------
22885 -- pragma Short_Descriptors;
22887 -- Recognize and validate, but otherwise ignore
22889 when Pragma_Short_Descriptors =>
22891 Check_Arg_Count (0);
22892 Check_Valid_Configuration_Pragma;
22894 ------------------------------
22895 -- Simple_Storage_Pool_Type --
22896 ------------------------------
22898 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22900 when Pragma_Simple_Storage_Pool_Type =>
22901 Simple_Storage_Pool_Type : declare
22907 Check_Arg_Count (1);
22908 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22910 Type_Id := Get_Pragma_Arg (Arg1);
22911 Find_Type (Type_Id);
22912 Typ := Entity (Type_Id);
22914 if Typ = Any_Type then
22918 -- A pragma that applies to a Ghost entity becomes Ghost for the
22919 -- purposes of legality checks and removal of ignored Ghost code.
22921 Mark_Ghost_Pragma (N, Typ);
22923 -- We require the pragma to apply to a type declared in a package
22924 -- declaration, but not (immediately) within a package body.
22926 if Ekind (Current_Scope) /= E_Package
22927 or else In_Package_Body (Current_Scope)
22930 ("pragma% can only apply to type declared immediately "
22931 & "within a package declaration");
22934 -- A simple storage pool type must be an immutably limited record
22935 -- or private type. If the pragma is given for a private type,
22936 -- the full type is similarly restricted (which is checked later
22937 -- in Freeze_Entity).
22939 if Is_Record_Type (Typ)
22940 and then not Is_Limited_View (Typ)
22943 ("pragma% can only apply to explicitly limited record type");
22945 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
22947 ("pragma% can only apply to a private type that is limited");
22949 elsif not Is_Record_Type (Typ)
22950 and then not Is_Private_Type (Typ)
22953 ("pragma% can only apply to limited record or private type");
22956 Record_Rep_Item (Typ, N);
22957 end Simple_Storage_Pool_Type;
22959 ----------------------
22960 -- Source_File_Name --
22961 ----------------------
22963 -- There are five forms for this pragma:
22965 -- pragma Source_File_Name (
22966 -- [UNIT_NAME =>] unit_NAME,
22967 -- BODY_FILE_NAME => STRING_LITERAL
22968 -- [, [INDEX =>] INTEGER_LITERAL]);
22970 -- pragma Source_File_Name (
22971 -- [UNIT_NAME =>] unit_NAME,
22972 -- SPEC_FILE_NAME => STRING_LITERAL
22973 -- [, [INDEX =>] INTEGER_LITERAL]);
22975 -- pragma Source_File_Name (
22976 -- BODY_FILE_NAME => STRING_LITERAL
22977 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22978 -- [, CASING => CASING_SPEC]);
22980 -- pragma Source_File_Name (
22981 -- SPEC_FILE_NAME => STRING_LITERAL
22982 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22983 -- [, CASING => CASING_SPEC]);
22985 -- pragma Source_File_Name (
22986 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22987 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22988 -- [, CASING => CASING_SPEC]);
22990 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22992 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22993 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22994 -- only be used when no project file is used, while SFNP can only be
22995 -- used when a project file is used.
22997 -- No processing here. Processing was completed during parsing, since
22998 -- we need to have file names set as early as possible. Units are
22999 -- loaded well before semantic processing starts.
23001 -- The only processing we defer to this point is the check for
23002 -- correct placement.
23004 when Pragma_Source_File_Name =>
23006 Check_Valid_Configuration_Pragma;
23008 ------------------------------
23009 -- Source_File_Name_Project --
23010 ------------------------------
23012 -- See Source_File_Name for syntax
23014 -- No processing here. Processing was completed during parsing, since
23015 -- we need to have file names set as early as possible. Units are
23016 -- loaded well before semantic processing starts.
23018 -- The only processing we defer to this point is the check for
23019 -- correct placement.
23021 when Pragma_Source_File_Name_Project =>
23023 Check_Valid_Configuration_Pragma;
23025 -- Check that a pragma Source_File_Name_Project is used only in a
23026 -- configuration pragmas file.
23028 -- Pragmas Source_File_Name_Project should only be generated by
23029 -- the Project Manager in configuration pragmas files.
23031 -- This is really an ugly test. It seems to depend on some
23032 -- accidental and undocumented property. At the very least it
23033 -- needs to be documented, but it would be better to have a
23034 -- clean way of testing if we are in a configuration file???
23036 if Present (Parent (N)) then
23038 ("pragma% can only appear in a configuration pragmas file");
23041 ----------------------
23042 -- Source_Reference --
23043 ----------------------
23045 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
23047 -- Nothing to do, all processing completed in Par.Prag, since we need
23048 -- the information for possible parser messages that are output.
23050 when Pragma_Source_Reference =>
23057 -- pragma SPARK_Mode [(On | Off)];
23059 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
23060 Mode_Id : SPARK_Mode_Type;
23062 procedure Check_Pragma_Conformance
23063 (Context_Pragma : Node_Id;
23064 Entity : Entity_Id;
23065 Entity_Pragma : Node_Id);
23066 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
23067 -- conformance of pragma N depending the following scenarios:
23069 -- If pragma Context_Pragma is not Empty, verify that pragma N is
23070 -- compatible with the pragma Context_Pragma that was inherited
23071 -- from the context:
23072 -- * If the mode of Context_Pragma is ON, then the new mode can
23074 -- * If the mode of Context_Pragma is OFF, then the only allowed
23075 -- new mode is also OFF. Emit error if this is not the case.
23077 -- If Entity is not Empty, verify that pragma N is compatible with
23078 -- pragma Entity_Pragma that belongs to Entity.
23079 -- * If Entity_Pragma is Empty, always issue an error as this
23080 -- corresponds to the case where a previous section of Entity
23081 -- has no SPARK_Mode set.
23082 -- * If the mode of Entity_Pragma is ON, then the new mode can
23084 -- * If the mode of Entity_Pragma is OFF, then the only allowed
23085 -- new mode is also OFF. Emit error if this is not the case.
23087 procedure Check_Library_Level_Entity (E : Entity_Id);
23088 -- Subsidiary to routines Process_xxx. Verify that the related
23089 -- entity E subject to pragma SPARK_Mode is library-level.
23091 procedure Process_Body (Decl : Node_Id);
23092 -- Verify the legality of pragma SPARK_Mode when it appears as the
23093 -- top of the body declarations of entry, package, protected unit,
23094 -- subprogram or task unit body denoted by Decl.
23096 procedure Process_Overloadable (Decl : Node_Id);
23097 -- Verify the legality of pragma SPARK_Mode when it applies to an
23098 -- entry or [generic] subprogram declaration denoted by Decl.
23100 procedure Process_Private_Part (Decl : Node_Id);
23101 -- Verify the legality of pragma SPARK_Mode when it appears at the
23102 -- top of the private declarations of a package spec, protected or
23103 -- task unit declaration denoted by Decl.
23105 procedure Process_Statement_Part (Decl : Node_Id);
23106 -- Verify the legality of pragma SPARK_Mode when it appears at the
23107 -- top of the statement sequence of a package body denoted by node
23110 procedure Process_Visible_Part (Decl : Node_Id);
23111 -- Verify the legality of pragma SPARK_Mode when it appears at the
23112 -- top of the visible declarations of a package spec, protected or
23113 -- task unit declaration denoted by Decl. The routine is also used
23114 -- on protected or task units declared without a definition.
23116 procedure Set_SPARK_Context;
23117 -- Subsidiary to routines Process_xxx. Set the global variables
23118 -- which represent the mode of the context from pragma N. Ensure
23119 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23121 ------------------------------
23122 -- Check_Pragma_Conformance --
23123 ------------------------------
23125 procedure Check_Pragma_Conformance
23126 (Context_Pragma : Node_Id;
23127 Entity : Entity_Id;
23128 Entity_Pragma : Node_Id)
23130 Err_Id : Entity_Id;
23134 -- The current pragma may appear without an argument. If this
23135 -- is the case, associate all error messages with the pragma
23138 if Present (Arg1) then
23144 -- The mode of the current pragma is compared against that of
23145 -- an enclosing context.
23147 if Present (Context_Pragma) then
23148 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
23150 -- Issue an error if the new mode is less restrictive than
23151 -- that of the context.
23153 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
23154 and then Get_SPARK_Mode_From_Annotation (N) = On
23157 ("cannot change SPARK_Mode from Off to On", Err_N);
23158 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
23159 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
23164 -- The mode of the current pragma is compared against that of
23165 -- an initial package, protected type, subprogram or task type
23168 if Present (Entity) then
23170 -- A simple protected or task type is transformed into an
23171 -- anonymous type whose name cannot be used to issue error
23172 -- messages. Recover the original entity of the type.
23174 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
23177 (Original_Node (Unit_Declaration_Node (Entity)));
23182 -- Both the initial declaration and the completion carry
23183 -- SPARK_Mode pragmas.
23185 if Present (Entity_Pragma) then
23186 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
23188 -- Issue an error if the new mode is less restrictive
23189 -- than that of the initial declaration.
23191 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
23192 and then Get_SPARK_Mode_From_Annotation (N) = On
23194 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23195 Error_Msg_Sloc := Sloc (Entity_Pragma);
23197 ("\value Off was set for SPARK_Mode on&#",
23202 -- Otherwise the initial declaration lacks a SPARK_Mode
23203 -- pragma in which case the current pragma is illegal as
23204 -- it cannot "complete".
23207 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
23208 Error_Msg_Sloc := Sloc (Err_Id);
23210 ("\no value was set for SPARK_Mode on&#",
23215 end Check_Pragma_Conformance;
23217 --------------------------------
23218 -- Check_Library_Level_Entity --
23219 --------------------------------
23221 procedure Check_Library_Level_Entity (E : Entity_Id) is
23222 procedure Add_Entity_To_Name_Buffer;
23223 -- Add the E_Kind of entity E to the name buffer
23225 -------------------------------
23226 -- Add_Entity_To_Name_Buffer --
23227 -------------------------------
23229 procedure Add_Entity_To_Name_Buffer is
23231 if Ekind_In (E, E_Entry, E_Entry_Family) then
23232 Add_Str_To_Name_Buffer ("entry");
23234 elsif Ekind_In (E, E_Generic_Package,
23238 Add_Str_To_Name_Buffer ("package");
23240 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
23241 Add_Str_To_Name_Buffer ("protected type");
23243 elsif Ekind_In (E, E_Function,
23244 E_Generic_Function,
23245 E_Generic_Procedure,
23249 Add_Str_To_Name_Buffer ("subprogram");
23252 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
23253 Add_Str_To_Name_Buffer ("task type");
23255 end Add_Entity_To_Name_Buffer;
23259 Msg_1 : constant String := "incorrect placement of pragma%";
23262 -- Start of processing for Check_Library_Level_Entity
23265 -- A SPARK_Mode of On shall only apply to library-level
23266 -- entities, except for those in generic instances, which are
23267 -- ignored (even if the entity gets SPARK_Mode pragma attached
23268 -- in the AST, its effect is not taken into account unless the
23269 -- context already provides SPARK_Mode of On in GNATprove).
23271 if Get_SPARK_Mode_From_Annotation (N) = On
23272 and then not Is_Library_Level_Entity (E)
23273 and then Instantiation_Location (Sloc (N)) = No_Location
23275 Error_Msg_Name_1 := Pname;
23276 Error_Msg_N (Fix_Error (Msg_1), N);
23279 Add_Str_To_Name_Buffer ("\& is not a library-level ");
23280 Add_Entity_To_Name_Buffer;
23282 Msg_2 := Name_Find;
23283 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
23287 end Check_Library_Level_Entity;
23293 procedure Process_Body (Decl : Node_Id) is
23294 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23295 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
23298 -- Ignore pragma when applied to the special body created for
23299 -- inlining, recognized by its internal name _Parent.
23301 if Chars (Body_Id) = Name_uParent then
23305 Check_Library_Level_Entity (Body_Id);
23307 -- For entry bodies, verify the legality against:
23308 -- * The mode of the context
23309 -- * The mode of the spec (if any)
23311 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
23313 -- A stand-alone subprogram body
23315 if Body_Id = Spec_Id then
23316 Check_Pragma_Conformance
23317 (Context_Pragma => SPARK_Pragma (Body_Id),
23319 Entity_Pragma => Empty);
23321 -- An entry or subprogram body that completes a previous
23325 Check_Pragma_Conformance
23326 (Context_Pragma => SPARK_Pragma (Body_Id),
23328 Entity_Pragma => SPARK_Pragma (Spec_Id));
23332 Set_SPARK_Pragma (Body_Id, N);
23333 Set_SPARK_Pragma_Inherited (Body_Id, False);
23335 -- For package bodies, verify the legality against:
23336 -- * The mode of the context
23337 -- * The mode of the private part
23339 -- This case is separated from protected and task bodies
23340 -- because the statement part of the package body inherits
23341 -- the mode of the body declarations.
23343 elsif Nkind (Decl) = N_Package_Body then
23344 Check_Pragma_Conformance
23345 (Context_Pragma => SPARK_Pragma (Body_Id),
23347 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23350 Set_SPARK_Pragma (Body_Id, N);
23351 Set_SPARK_Pragma_Inherited (Body_Id, False);
23352 Set_SPARK_Aux_Pragma (Body_Id, N);
23353 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
23355 -- For protected and task bodies, verify the legality against:
23356 -- * The mode of the context
23357 -- * The mode of the private part
23361 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
23363 Check_Pragma_Conformance
23364 (Context_Pragma => SPARK_Pragma (Body_Id),
23366 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
23369 Set_SPARK_Pragma (Body_Id, N);
23370 Set_SPARK_Pragma_Inherited (Body_Id, False);
23374 --------------------------
23375 -- Process_Overloadable --
23376 --------------------------
23378 procedure Process_Overloadable (Decl : Node_Id) is
23379 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23380 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
23383 Check_Library_Level_Entity (Spec_Id);
23385 -- Verify the legality against:
23386 -- * The mode of the context
23388 Check_Pragma_Conformance
23389 (Context_Pragma => SPARK_Pragma (Spec_Id),
23391 Entity_Pragma => Empty);
23393 Set_SPARK_Pragma (Spec_Id, N);
23394 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23396 -- When the pragma applies to the anonymous object created for
23397 -- a single task type, decorate the type as well. This scenario
23398 -- arises when the single task type lacks a task definition,
23399 -- therefore there is no issue with respect to a potential
23400 -- pragma SPARK_Mode in the private part.
23402 -- task type Anon_Task_Typ;
23403 -- Obj : Anon_Task_Typ;
23404 -- pragma SPARK_Mode ...;
23406 if Is_Single_Task_Object (Spec_Id) then
23407 Set_SPARK_Pragma (Spec_Typ, N);
23408 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
23409 Set_SPARK_Aux_Pragma (Spec_Typ, N);
23410 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
23412 end Process_Overloadable;
23414 --------------------------
23415 -- Process_Private_Part --
23416 --------------------------
23418 procedure Process_Private_Part (Decl : Node_Id) is
23419 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23422 Check_Library_Level_Entity (Spec_Id);
23424 -- Verify the legality against:
23425 -- * The mode of the visible declarations
23427 Check_Pragma_Conformance
23428 (Context_Pragma => Empty,
23430 Entity_Pragma => SPARK_Pragma (Spec_Id));
23433 Set_SPARK_Aux_Pragma (Spec_Id, N);
23434 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
23435 end Process_Private_Part;
23437 ----------------------------
23438 -- Process_Statement_Part --
23439 ----------------------------
23441 procedure Process_Statement_Part (Decl : Node_Id) is
23442 Body_Id : constant Entity_Id := Defining_Entity (Decl);
23445 Check_Library_Level_Entity (Body_Id);
23447 -- Verify the legality against:
23448 -- * The mode of the body declarations
23450 Check_Pragma_Conformance
23451 (Context_Pragma => Empty,
23453 Entity_Pragma => SPARK_Pragma (Body_Id));
23456 Set_SPARK_Aux_Pragma (Body_Id, N);
23457 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
23458 end Process_Statement_Part;
23460 --------------------------
23461 -- Process_Visible_Part --
23462 --------------------------
23464 procedure Process_Visible_Part (Decl : Node_Id) is
23465 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
23466 Obj_Id : Entity_Id;
23469 Check_Library_Level_Entity (Spec_Id);
23471 -- Verify the legality against:
23472 -- * The mode of the context
23474 Check_Pragma_Conformance
23475 (Context_Pragma => SPARK_Pragma (Spec_Id),
23477 Entity_Pragma => Empty);
23479 -- A task unit declared without a definition does not set the
23480 -- SPARK_Mode of the context because the task does not have any
23481 -- entries that could inherit the mode.
23483 if not Nkind_In (Decl, N_Single_Task_Declaration,
23484 N_Task_Type_Declaration)
23489 Set_SPARK_Pragma (Spec_Id, N);
23490 Set_SPARK_Pragma_Inherited (Spec_Id, False);
23491 Set_SPARK_Aux_Pragma (Spec_Id, N);
23492 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
23494 -- When the pragma applies to a single protected or task type,
23495 -- decorate the corresponding anonymous object as well.
23497 -- protected Anon_Prot_Typ is
23498 -- pragma SPARK_Mode ...;
23500 -- end Anon_Prot_Typ;
23502 -- Obj : Anon_Prot_Typ;
23504 if Is_Single_Concurrent_Type (Spec_Id) then
23505 Obj_Id := Anonymous_Object (Spec_Id);
23507 Set_SPARK_Pragma (Obj_Id, N);
23508 Set_SPARK_Pragma_Inherited (Obj_Id, False);
23510 end Process_Visible_Part;
23512 -----------------------
23513 -- Set_SPARK_Context --
23514 -----------------------
23516 procedure Set_SPARK_Context is
23518 SPARK_Mode := Mode_Id;
23519 SPARK_Mode_Pragma := N;
23520 end Set_SPARK_Context;
23528 -- Start of processing for Do_SPARK_Mode
23531 -- When a SPARK_Mode pragma appears inside an instantiation whose
23532 -- enclosing context has SPARK_Mode set to "off", the pragma has
23533 -- no semantic effect.
23535 if Ignore_SPARK_Mode_Pragmas_In_Instance then
23536 Rewrite (N, Make_Null_Statement (Loc));
23542 Check_No_Identifiers;
23543 Check_At_Most_N_Arguments (1);
23545 -- Check the legality of the mode (no argument = ON)
23547 if Arg_Count = 1 then
23548 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23549 Mode := Chars (Get_Pragma_Arg (Arg1));
23554 Mode_Id := Get_SPARK_Mode_Type (Mode);
23555 Context := Parent (N);
23557 -- The pragma appears in a configuration file
23559 if No (Context) then
23560 Check_Valid_Configuration_Pragma;
23562 if Present (SPARK_Mode_Pragma) then
23565 Prev => SPARK_Mode_Pragma);
23571 -- The pragma acts as a configuration pragma in a compilation unit
23573 -- pragma SPARK_Mode ...;
23574 -- package Pack is ...;
23576 elsif Nkind (Context) = N_Compilation_Unit
23577 and then List_Containing (N) = Context_Items (Context)
23579 Check_Valid_Configuration_Pragma;
23582 -- Otherwise the placement of the pragma within the tree dictates
23583 -- its associated construct. Inspect the declarative list where
23584 -- the pragma resides to find a potential construct.
23588 while Present (Stmt) loop
23590 -- Skip prior pragmas, but check for duplicates. Note that
23591 -- this also takes care of pragmas generated for aspects.
23593 if Nkind (Stmt) = N_Pragma then
23594 if Pragma_Name (Stmt) = Pname then
23601 -- The pragma applies to an expression function that has
23602 -- already been rewritten into a subprogram declaration.
23604 -- function Expr_Func return ... is (...);
23605 -- pragma SPARK_Mode ...;
23607 elsif Nkind (Stmt) = N_Subprogram_Declaration
23608 and then Nkind (Original_Node (Stmt)) =
23609 N_Expression_Function
23611 Process_Overloadable (Stmt);
23614 -- The pragma applies to the anonymous object created for a
23615 -- single concurrent type.
23617 -- protected type Anon_Prot_Typ ...;
23618 -- Obj : Anon_Prot_Typ;
23619 -- pragma SPARK_Mode ...;
23621 elsif Nkind (Stmt) = N_Object_Declaration
23622 and then Is_Single_Concurrent_Object
23623 (Defining_Entity (Stmt))
23625 Process_Overloadable (Stmt);
23628 -- Skip internally generated code
23630 elsif not Comes_From_Source (Stmt) then
23633 -- The pragma applies to an entry or [generic] subprogram
23637 -- pragma SPARK_Mode ...;
23640 -- procedure Proc ...;
23641 -- pragma SPARK_Mode ...;
23643 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
23644 N_Subprogram_Declaration)
23645 or else (Nkind (Stmt) = N_Entry_Declaration
23646 and then Is_Protected_Type
23647 (Scope (Defining_Entity (Stmt))))
23649 Process_Overloadable (Stmt);
23652 -- Otherwise the pragma does not apply to a legal construct
23653 -- or it does not appear at the top of a declarative or a
23654 -- statement list. Issue an error and stop the analysis.
23664 -- The pragma applies to a package or a subprogram that acts as
23665 -- a compilation unit.
23667 -- procedure Proc ...;
23668 -- pragma SPARK_Mode ...;
23670 if Nkind (Context) = N_Compilation_Unit_Aux then
23671 Context := Unit (Parent (Context));
23674 -- The pragma appears at the top of entry, package, protected
23675 -- unit, subprogram or task unit body declarations.
23677 -- entry Ent when ... is
23678 -- pragma SPARK_Mode ...;
23680 -- package body Pack is
23681 -- pragma SPARK_Mode ...;
23683 -- procedure Proc ... is
23684 -- pragma SPARK_Mode;
23686 -- protected body Prot is
23687 -- pragma SPARK_Mode ...;
23689 if Nkind_In (Context, N_Entry_Body,
23695 Process_Body (Context);
23697 -- The pragma appears at the top of the visible or private
23698 -- declaration of a package spec, protected or task unit.
23701 -- pragma SPARK_Mode ...;
23703 -- pragma SPARK_Mode ...;
23705 -- protected [type] Prot is
23706 -- pragma SPARK_Mode ...;
23708 -- pragma SPARK_Mode ...;
23710 elsif Nkind_In (Context, N_Package_Specification,
23711 N_Protected_Definition,
23714 if List_Containing (N) = Visible_Declarations (Context) then
23715 Process_Visible_Part (Parent (Context));
23717 Process_Private_Part (Parent (Context));
23720 -- The pragma appears at the top of package body statements
23722 -- package body Pack is
23724 -- pragma SPARK_Mode;
23726 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
23727 and then Nkind (Parent (Context)) = N_Package_Body
23729 Process_Statement_Part (Parent (Context));
23731 -- The pragma appeared as an aspect of a [generic] subprogram
23732 -- declaration that acts as a compilation unit.
23735 -- procedure Proc ...;
23736 -- pragma SPARK_Mode ...;
23738 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
23739 N_Subprogram_Declaration)
23741 Process_Overloadable (Context);
23743 -- The pragma does not apply to a legal construct, issue error
23751 --------------------------------
23752 -- Static_Elaboration_Desired --
23753 --------------------------------
23755 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23757 when Pragma_Static_Elaboration_Desired =>
23759 Check_At_Most_N_Arguments (1);
23761 if Is_Compilation_Unit (Current_Scope)
23762 and then Ekind (Current_Scope) = E_Package
23764 Set_Static_Elaboration_Desired (Current_Scope, True);
23766 Error_Pragma ("pragma% must apply to a library-level package");
23773 -- pragma Storage_Size (EXPRESSION);
23775 when Pragma_Storage_Size => Storage_Size : declare
23776 P : constant Node_Id := Parent (N);
23780 Check_No_Identifiers;
23781 Check_Arg_Count (1);
23783 -- The expression must be analyzed in the special manner described
23784 -- in "Handling of Default Expressions" in sem.ads.
23786 Arg := Get_Pragma_Arg (Arg1);
23787 Preanalyze_Spec_Expression (Arg, Any_Integer);
23789 if not Is_OK_Static_Expression (Arg) then
23790 Check_Restriction (Static_Storage_Size, Arg);
23793 if Nkind (P) /= N_Task_Definition then
23798 if Has_Storage_Size_Pragma (P) then
23799 Error_Pragma ("duplicate pragma% not allowed");
23801 Set_Has_Storage_Size_Pragma (P, True);
23804 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
23812 -- pragma Storage_Unit (NUMERIC_LITERAL);
23814 -- Only permitted argument is System'Storage_Unit value
23816 when Pragma_Storage_Unit =>
23817 Check_No_Identifiers;
23818 Check_Arg_Count (1);
23819 Check_Arg_Is_Integer_Literal (Arg1);
23821 if Intval (Get_Pragma_Arg (Arg1)) /=
23822 UI_From_Int (Ttypes.System_Storage_Unit)
23824 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
23826 ("the only allowed argument for pragma% is ^", Arg1);
23829 --------------------
23830 -- Stream_Convert --
23831 --------------------
23833 -- pragma Stream_Convert (
23834 -- [Entity =>] type_LOCAL_NAME,
23835 -- [Read =>] function_NAME,
23836 -- [Write =>] function NAME);
23838 when Pragma_Stream_Convert => Stream_Convert : declare
23839 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
23840 -- Check that the given argument is the name of a local function
23841 -- of one argument that is not overloaded earlier in the current
23842 -- local scope. A check is also made that the argument is a
23843 -- function with one parameter.
23845 --------------------------------------
23846 -- Check_OK_Stream_Convert_Function --
23847 --------------------------------------
23849 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
23853 Check_Arg_Is_Local_Name (Arg);
23854 Ent := Entity (Get_Pragma_Arg (Arg));
23856 if Has_Homonym (Ent) then
23858 ("argument for pragma% may not be overloaded", Arg);
23861 if Ekind (Ent) /= E_Function
23862 or else No (First_Formal (Ent))
23863 or else Present (Next_Formal (First_Formal (Ent)))
23866 ("argument for pragma% must be function of one argument",
23869 end Check_OK_Stream_Convert_Function;
23871 -- Start of processing for Stream_Convert
23875 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
23876 Check_Arg_Count (3);
23877 Check_Optional_Identifier (Arg1, Name_Entity);
23878 Check_Optional_Identifier (Arg2, Name_Read);
23879 Check_Optional_Identifier (Arg3, Name_Write);
23880 Check_Arg_Is_Local_Name (Arg1);
23881 Check_OK_Stream_Convert_Function (Arg2);
23882 Check_OK_Stream_Convert_Function (Arg3);
23885 Typ : constant Entity_Id :=
23886 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
23887 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
23888 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
23891 Check_First_Subtype (Arg1);
23893 -- Check for too early or too late. Note that we don't enforce
23894 -- the rule about primitive operations in this case, since, as
23895 -- is the case for explicit stream attributes themselves, these
23896 -- restrictions are not appropriate. Note that the chaining of
23897 -- the pragma by Rep_Item_Too_Late is actually the critical
23898 -- processing done for this pragma.
23900 if Rep_Item_Too_Early (Typ, N)
23902 Rep_Item_Too_Late (Typ, N, FOnly => True)
23907 -- Return if previous error
23909 if Etype (Typ) = Any_Type
23911 Etype (Read) = Any_Type
23913 Etype (Write) = Any_Type
23920 if Underlying_Type (Etype (Read)) /= Typ then
23922 ("incorrect return type for function&", Arg2);
23925 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
23927 ("incorrect parameter type for function&", Arg3);
23930 if Underlying_Type (Etype (First_Formal (Read))) /=
23931 Underlying_Type (Etype (Write))
23934 ("result type of & does not match Read parameter type",
23938 end Stream_Convert;
23944 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23946 -- This is processed by the parser since some of the style checks
23947 -- take place during source scanning and parsing. This means that
23948 -- we don't need to issue error messages here.
23950 when Pragma_Style_Checks => Style_Checks : declare
23951 A : constant Node_Id := Get_Pragma_Arg (Arg1);
23957 Check_No_Identifiers;
23959 -- Two argument form
23961 if Arg_Count = 2 then
23962 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23969 E_Id := Get_Pragma_Arg (Arg2);
23972 if not Is_Entity_Name (E_Id) then
23974 ("second argument of pragma% must be entity name",
23978 E := Entity (E_Id);
23980 if not Ignore_Style_Checks_Pragmas then
23985 Set_Suppress_Style_Checks
23986 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
23987 exit when No (Homonym (E));
23994 -- One argument form
23997 Check_Arg_Count (1);
23999 if Nkind (A) = N_String_Literal then
24003 Slen : constant Natural := Natural (String_Length (S));
24004 Options : String (1 .. Slen);
24010 C := Get_String_Char (S, Pos (J));
24011 exit when not In_Character_Range (C);
24012 Options (J) := Get_Character (C);
24014 -- If at end of string, set options. As per discussion
24015 -- above, no need to check for errors, since we issued
24016 -- them in the parser.
24019 if not Ignore_Style_Checks_Pragmas then
24020 Set_Style_Check_Options (Options);
24030 elsif Nkind (A) = N_Identifier then
24031 if Chars (A) = Name_All_Checks then
24032 if not Ignore_Style_Checks_Pragmas then
24034 Set_GNAT_Style_Check_Options;
24036 Set_Default_Style_Check_Options;
24040 elsif Chars (A) = Name_On then
24041 if not Ignore_Style_Checks_Pragmas then
24042 Style_Check := True;
24045 elsif Chars (A) = Name_Off then
24046 if not Ignore_Style_Checks_Pragmas then
24047 Style_Check := False;
24058 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24060 when Pragma_Subtitle =>
24062 Check_Arg_Count (1);
24063 Check_Optional_Identifier (Arg1, Name_Subtitle);
24064 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24071 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24073 when Pragma_Suppress =>
24074 Process_Suppress_Unsuppress (Suppress_Case => True);
24080 -- pragma Suppress_All;
24082 -- The only check made here is that the pragma has no arguments.
24083 -- There are no placement rules, and the processing required (setting
24084 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24085 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24086 -- then creates and inserts a pragma Suppress (All_Checks).
24088 when Pragma_Suppress_All =>
24090 Check_Arg_Count (0);
24092 -------------------------
24093 -- Suppress_Debug_Info --
24094 -------------------------
24096 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24098 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
24099 Nam_Id : Entity_Id;
24103 Check_Arg_Count (1);
24104 Check_Optional_Identifier (Arg1, Name_Entity);
24105 Check_Arg_Is_Local_Name (Arg1);
24107 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
24109 -- A pragma that applies to a Ghost entity becomes Ghost for the
24110 -- purposes of legality checks and removal of ignored Ghost code.
24112 Mark_Ghost_Pragma (N, Nam_Id);
24113 Set_Debug_Info_Off (Nam_Id);
24114 end Suppress_Debug_Info;
24116 ----------------------------------
24117 -- Suppress_Exception_Locations --
24118 ----------------------------------
24120 -- pragma Suppress_Exception_Locations;
24122 when Pragma_Suppress_Exception_Locations =>
24124 Check_Arg_Count (0);
24125 Check_Valid_Configuration_Pragma;
24126 Exception_Locations_Suppressed := True;
24128 -----------------------------
24129 -- Suppress_Initialization --
24130 -----------------------------
24132 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24134 when Pragma_Suppress_Initialization => Suppress_Init : declare
24140 Check_Arg_Count (1);
24141 Check_Optional_Identifier (Arg1, Name_Entity);
24142 Check_Arg_Is_Local_Name (Arg1);
24144 E_Id := Get_Pragma_Arg (Arg1);
24146 if Etype (E_Id) = Any_Type then
24150 E := Entity (E_Id);
24152 -- A pragma that applies to a Ghost entity becomes Ghost for the
24153 -- purposes of legality checks and removal of ignored Ghost code.
24155 Mark_Ghost_Pragma (N, E);
24157 if not Is_Type (E) and then Ekind (E) /= E_Variable then
24159 ("pragma% requires variable, type or subtype", Arg1);
24162 if Rep_Item_Too_Early (E, N)
24164 Rep_Item_Too_Late (E, N, FOnly => True)
24169 -- For incomplete/private type, set flag on full view
24171 if Is_Incomplete_Or_Private_Type (E) then
24172 if No (Full_View (Base_Type (E))) then
24174 ("argument of pragma% cannot be an incomplete type", Arg1);
24176 Set_Suppress_Initialization (Full_View (E));
24179 -- For first subtype, set flag on base type
24181 elsif Is_First_Subtype (E) then
24182 Set_Suppress_Initialization (Base_Type (E));
24184 -- For other than first subtype, set flag on subtype or variable
24187 Set_Suppress_Initialization (E);
24195 -- pragma System_Name (DIRECT_NAME);
24197 -- Syntax check: one argument, which must be the identifier GNAT or
24198 -- the identifier GCC, no other identifiers are acceptable.
24200 when Pragma_System_Name =>
24202 Check_No_Identifiers;
24203 Check_Arg_Count (1);
24204 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
24206 -----------------------------
24207 -- Task_Dispatching_Policy --
24208 -----------------------------
24210 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24212 when Pragma_Task_Dispatching_Policy => declare
24216 Check_Ada_83_Warning;
24217 Check_Arg_Count (1);
24218 Check_No_Identifiers;
24219 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
24220 Check_Valid_Configuration_Pragma;
24221 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24222 DP := Fold_Upper (Name_Buffer (1));
24224 if Task_Dispatching_Policy /= ' '
24225 and then Task_Dispatching_Policy /= DP
24227 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
24229 ("task dispatching policy incompatible with policy#");
24231 -- Set new policy, but always preserve System_Location since we
24232 -- like the error message with the run time name.
24235 Task_Dispatching_Policy := DP;
24237 if Task_Dispatching_Policy_Sloc /= System_Location then
24238 Task_Dispatching_Policy_Sloc := Loc;
24247 -- pragma Task_Info (EXPRESSION);
24249 when Pragma_Task_Info => Task_Info : declare
24250 P : constant Node_Id := Parent (N);
24256 if Warn_On_Obsolescent_Feature then
24258 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24259 & "instead?j?", N);
24262 if Nkind (P) /= N_Task_Definition then
24263 Error_Pragma ("pragma% must appear in task definition");
24266 Check_No_Identifiers;
24267 Check_Arg_Count (1);
24269 Analyze_And_Resolve
24270 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
24272 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
24276 Ent := Defining_Identifier (Parent (P));
24278 -- Check duplicate pragma before we chain the pragma in the Rep
24279 -- Item chain of Ent.
24282 (Ent, Name_Task_Info, Check_Parents => False)
24284 Error_Pragma ("duplicate pragma% not allowed");
24287 Record_Rep_Item (Ent, N);
24294 -- pragma Task_Name (string_EXPRESSION);
24296 when Pragma_Task_Name => Task_Name : declare
24297 P : constant Node_Id := Parent (N);
24302 Check_No_Identifiers;
24303 Check_Arg_Count (1);
24305 Arg := Get_Pragma_Arg (Arg1);
24307 -- The expression is used in the call to Create_Task, and must be
24308 -- expanded there, not in the context of the current spec. It must
24309 -- however be analyzed to capture global references, in case it
24310 -- appears in a generic context.
24312 Preanalyze_And_Resolve (Arg, Standard_String);
24314 if Nkind (P) /= N_Task_Definition then
24318 Ent := Defining_Identifier (Parent (P));
24320 -- Check duplicate pragma before we chain the pragma in the Rep
24321 -- Item chain of Ent.
24324 (Ent, Name_Task_Name, Check_Parents => False)
24326 Error_Pragma ("duplicate pragma% not allowed");
24329 Record_Rep_Item (Ent, N);
24336 -- pragma Task_Storage (
24337 -- [Task_Type =>] LOCAL_NAME,
24338 -- [Top_Guard =>] static_integer_EXPRESSION);
24340 when Pragma_Task_Storage => Task_Storage : declare
24341 Args : Args_List (1 .. 2);
24342 Names : constant Name_List (1 .. 2) := (
24346 Task_Type : Node_Id renames Args (1);
24347 Top_Guard : Node_Id renames Args (2);
24353 Gather_Associations (Names, Args);
24355 if No (Task_Type) then
24357 ("missing task_type argument for pragma%");
24360 Check_Arg_Is_Local_Name (Task_Type);
24362 Ent := Entity (Task_Type);
24364 if not Is_Task_Type (Ent) then
24366 ("argument for pragma% must be task type", Task_Type);
24369 if No (Top_Guard) then
24371 ("pragma% takes two arguments", Task_Type);
24373 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
24376 Check_First_Subtype (Task_Type);
24378 if Rep_Item_Too_Late (Ent, N) then
24387 -- pragma Test_Case
24388 -- ([Name =>] Static_String_EXPRESSION
24389 -- ,[Mode =>] MODE_TYPE
24390 -- [, Requires => Boolean_EXPRESSION]
24391 -- [, Ensures => Boolean_EXPRESSION]);
24393 -- MODE_TYPE ::= Nominal | Robustness
24395 -- Characteristics:
24397 -- * Analysis - The annotation undergoes initial checks to verify
24398 -- the legal placement and context. Secondary checks preanalyze the
24401 -- Analyze_Test_Case_In_Decl_Part
24403 -- * Expansion - None.
24405 -- * Template - The annotation utilizes the generic template of the
24406 -- related subprogram when it is:
24408 -- aspect on subprogram declaration
24410 -- The annotation must prepare its own template when it is:
24412 -- pragma on subprogram declaration
24414 -- * Globals - Capture of global references must occur after full
24417 -- * Instance - The annotation is instantiated automatically when
24418 -- the related generic subprogram is instantiated except for the
24419 -- "pragma on subprogram declaration" case. In that scenario the
24420 -- annotation must instantiate itself.
24422 when Pragma_Test_Case => Test_Case : declare
24423 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
24424 -- Ensure that the contract of subprogram Subp_Id does not contain
24425 -- another Test_Case pragma with the same Name as the current one.
24427 -------------------------
24428 -- Check_Distinct_Name --
24429 -------------------------
24431 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
24432 Items : constant Node_Id := Contract (Subp_Id);
24433 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
24437 -- Inspect all Test_Case pragma of the related subprogram
24438 -- looking for one with a duplicate "Name" argument.
24440 if Present (Items) then
24441 Prag := Contract_Test_Cases (Items);
24442 while Present (Prag) loop
24443 if Pragma_Name (Prag) = Name_Test_Case
24445 and then String_Equal
24446 (Name, Get_Name_From_CTC_Pragma (Prag))
24448 Error_Msg_Sloc := Sloc (Prag);
24449 Error_Pragma ("name for pragma % is already used #");
24452 Prag := Next_Pragma (Prag);
24455 end Check_Distinct_Name;
24459 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
24462 Subp_Decl : Node_Id;
24463 Subp_Id : Entity_Id;
24465 -- Start of processing for Test_Case
24469 Check_At_Least_N_Arguments (2);
24470 Check_At_Most_N_Arguments (4);
24472 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
24476 Check_Optional_Identifier (Arg1, Name_Name);
24477 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
24481 Check_Optional_Identifier (Arg2, Name_Mode);
24482 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
24484 -- Arguments "Requires" and "Ensures"
24486 if Present (Arg3) then
24487 if Present (Arg4) then
24488 Check_Identifier (Arg3, Name_Requires);
24489 Check_Identifier (Arg4, Name_Ensures);
24491 Check_Identifier_Is_One_Of
24492 (Arg3, Name_Requires, Name_Ensures);
24496 -- Pragma Test_Case must be associated with a subprogram declared
24497 -- in a library-level package. First determine whether the current
24498 -- compilation unit is a legal context.
24500 if Nkind_In (Pack_Decl, N_Package_Declaration,
24501 N_Generic_Package_Declaration)
24505 -- Otherwise the placement is illegal
24509 ("pragma % must be specified within a package declaration");
24513 Subp_Decl := Find_Related_Declaration_Or_Body (N);
24515 -- Find the enclosing context
24517 Context := Parent (Subp_Decl);
24519 if Present (Context) then
24520 Context := Parent (Context);
24523 -- Verify the placement of the pragma
24525 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
24527 ("pragma % cannot be applied to abstract subprogram");
24530 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
24531 Error_Pragma ("pragma % cannot be applied to entry");
24534 -- The context is a [generic] subprogram declared at the top level
24535 -- of the [generic] package unit.
24537 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
24538 N_Subprogram_Declaration)
24539 and then Present (Context)
24540 and then Nkind_In (Context, N_Generic_Package_Declaration,
24541 N_Package_Declaration)
24545 -- Otherwise the placement is illegal
24549 ("pragma % must be applied to a library-level subprogram "
24554 Subp_Id := Defining_Entity (Subp_Decl);
24556 -- A pragma that applies to a Ghost entity becomes Ghost for the
24557 -- purposes of legality checks and removal of ignored Ghost code.
24559 Mark_Ghost_Pragma (N, Subp_Id);
24561 -- Chain the pragma on the contract for further processing by
24562 -- Analyze_Test_Case_In_Decl_Part.
24564 Add_Contract_Item (N, Subp_Id);
24566 -- Preanalyze the original aspect argument "Name" for ASIS or for
24567 -- a generic subprogram to properly capture global references.
24569 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
24570 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
24572 if Present (Asp_Arg) then
24574 -- The argument appears with an identifier in association
24577 if Nkind (Asp_Arg) = N_Component_Association then
24578 Asp_Arg := Expression (Asp_Arg);
24581 Check_Expr_Is_OK_Static_Expression
24582 (Asp_Arg, Standard_String);
24586 -- Ensure that the all Test_Case pragmas of the related subprogram
24587 -- have distinct names.
24589 Check_Distinct_Name (Subp_Id);
24591 -- Fully analyze the pragma when it appears inside an entry
24592 -- or subprogram body because it cannot benefit from forward
24595 if Nkind_In (Subp_Decl, N_Entry_Body,
24597 N_Subprogram_Body_Stub)
24599 -- The legality checks of pragma Test_Case are affected by the
24600 -- SPARK mode in effect and the volatility of the context.
24601 -- Analyze all pragmas in a specific order.
24603 Analyze_If_Present (Pragma_SPARK_Mode);
24604 Analyze_If_Present (Pragma_Volatile_Function);
24605 Analyze_Test_Case_In_Decl_Part (N);
24609 --------------------------
24610 -- Thread_Local_Storage --
24611 --------------------------
24613 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24615 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
24621 Check_Arg_Count (1);
24622 Check_Optional_Identifier (Arg1, Name_Entity);
24623 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24625 Id := Get_Pragma_Arg (Arg1);
24628 if not Is_Entity_Name (Id)
24629 or else Ekind (Entity (Id)) /= E_Variable
24631 Error_Pragma_Arg ("local variable name required", Arg1);
24636 -- A pragma that applies to a Ghost entity becomes Ghost for the
24637 -- purposes of legality checks and removal of ignored Ghost code.
24639 Mark_Ghost_Pragma (N, E);
24641 if Rep_Item_Too_Early (E, N)
24643 Rep_Item_Too_Late (E, N)
24648 Set_Has_Pragma_Thread_Local_Storage (E);
24649 Set_Has_Gigi_Rep_Item (E);
24650 end Thread_Local_Storage;
24656 -- pragma Time_Slice (static_duration_EXPRESSION);
24658 when Pragma_Time_Slice => Time_Slice : declare
24664 Check_Arg_Count (1);
24665 Check_No_Identifiers;
24666 Check_In_Main_Program;
24667 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
24669 if not Error_Posted (Arg1) then
24671 while Present (Nod) loop
24672 if Nkind (Nod) = N_Pragma
24673 and then Pragma_Name (Nod) = Name_Time_Slice
24675 Error_Msg_Name_1 := Pname;
24676 Error_Msg_N ("duplicate pragma% not permitted", Nod);
24683 -- Process only if in main unit
24685 if Get_Source_Unit (Loc) = Main_Unit then
24686 Opt.Time_Slice_Set := True;
24687 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
24689 if Val <= Ureal_0 then
24690 Opt.Time_Slice_Value := 0;
24692 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
24693 Opt.Time_Slice_Value := 1_000_000_000;
24696 Opt.Time_Slice_Value :=
24697 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
24706 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24708 -- TITLING_OPTION ::=
24709 -- [Title =>] STRING_LITERAL
24710 -- | [Subtitle =>] STRING_LITERAL
24712 when Pragma_Title => Title : declare
24713 Args : Args_List (1 .. 2);
24714 Names : constant Name_List (1 .. 2) := (
24720 Gather_Associations (Names, Args);
24723 for J in 1 .. 2 loop
24724 if Present (Args (J)) then
24725 Check_Arg_Is_OK_Static_Expression
24726 (Args (J), Standard_String);
24731 ----------------------------
24732 -- Type_Invariant[_Class] --
24733 ----------------------------
24735 -- pragma Type_Invariant[_Class]
24736 -- ([Entity =>] type_LOCAL_NAME,
24737 -- [Check =>] EXPRESSION);
24739 when Pragma_Type_Invariant
24740 | Pragma_Type_Invariant_Class
24742 Type_Invariant : declare
24743 I_Pragma : Node_Id;
24746 Check_Arg_Count (2);
24748 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24749 -- setting Class_Present for the Type_Invariant_Class case.
24751 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
24752 I_Pragma := New_Copy (N);
24753 Set_Pragma_Identifier
24754 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
24755 Rewrite (N, I_Pragma);
24756 Set_Analyzed (N, False);
24758 end Type_Invariant;
24760 ---------------------
24761 -- Unchecked_Union --
24762 ---------------------
24764 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24766 when Pragma_Unchecked_Union => Unchecked_Union : declare
24767 Assoc : constant Node_Id := Arg1;
24768 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
24778 Check_No_Identifiers;
24779 Check_Arg_Count (1);
24780 Check_Arg_Is_Local_Name (Arg1);
24782 Find_Type (Type_Id);
24784 Typ := Entity (Type_Id);
24786 -- A pragma that applies to a Ghost entity becomes Ghost for the
24787 -- purposes of legality checks and removal of ignored Ghost code.
24789 Mark_Ghost_Pragma (N, Typ);
24792 or else Rep_Item_Too_Early (Typ, N)
24796 Typ := Underlying_Type (Typ);
24799 if Rep_Item_Too_Late (Typ, N) then
24803 Check_First_Subtype (Arg1);
24805 -- Note remaining cases are references to a type in the current
24806 -- declarative part. If we find an error, we post the error on
24807 -- the relevant type declaration at an appropriate point.
24809 if not Is_Record_Type (Typ) then
24810 Error_Msg_N ("unchecked union must be record type", Typ);
24813 elsif Is_Tagged_Type (Typ) then
24814 Error_Msg_N ("unchecked union must not be tagged", Typ);
24817 elsif not Has_Discriminants (Typ) then
24819 ("unchecked union must have one discriminant", Typ);
24822 -- Note: in previous versions of GNAT we used to check for limited
24823 -- types and give an error, but in fact the standard does allow
24824 -- Unchecked_Union on limited types, so this check was removed.
24826 -- Similarly, GNAT used to require that all discriminants have
24827 -- default values, but this is not mandated by the RM.
24829 -- Proceed with basic error checks completed
24832 Tdef := Type_Definition (Declaration_Node (Typ));
24833 Clist := Component_List (Tdef);
24835 -- Check presence of component list and variant part
24837 if No (Clist) or else No (Variant_Part (Clist)) then
24839 ("unchecked union must have variant part", Tdef);
24843 -- Check components
24845 Comp := First_Non_Pragma (Component_Items (Clist));
24846 while Present (Comp) loop
24847 Check_Component (Comp, Typ);
24848 Next_Non_Pragma (Comp);
24851 -- Check variant part
24853 Vpart := Variant_Part (Clist);
24855 Variant := First_Non_Pragma (Variants (Vpart));
24856 while Present (Variant) loop
24857 Check_Variant (Variant, Typ);
24858 Next_Non_Pragma (Variant);
24862 Set_Is_Unchecked_Union (Typ);
24863 Set_Convention (Typ, Convention_C);
24864 Set_Has_Unchecked_Union (Base_Type (Typ));
24865 Set_Is_Unchecked_Union (Base_Type (Typ));
24866 end Unchecked_Union;
24868 ----------------------------
24869 -- Unevaluated_Use_Of_Old --
24870 ----------------------------
24872 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24874 when Pragma_Unevaluated_Use_Of_Old =>
24876 Check_Arg_Count (1);
24877 Check_No_Identifiers;
24878 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
24880 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24881 -- a declarative part or a package spec.
24883 if not Is_Configuration_Pragma then
24884 Check_Is_In_Decl_Part_Or_Package_Spec;
24887 -- Store proper setting of Uneval_Old
24889 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
24890 Uneval_Old := Fold_Upper (Name_Buffer (1));
24892 ------------------------
24893 -- Unimplemented_Unit --
24894 ------------------------
24896 -- pragma Unimplemented_Unit;
24898 -- Note: this only gives an error if we are generating code, or if
24899 -- we are in a generic library unit (where the pragma appears in the
24900 -- body, not in the spec).
24902 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
24903 Cunitent : constant Entity_Id :=
24904 Cunit_Entity (Get_Source_Unit (Loc));
24905 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
24909 Check_Arg_Count (0);
24911 if Operating_Mode = Generate_Code
24912 or else Ent_Kind = E_Generic_Function
24913 or else Ent_Kind = E_Generic_Procedure
24914 or else Ent_Kind = E_Generic_Package
24916 Get_Name_String (Chars (Cunitent));
24917 Set_Casing (Mixed_Case);
24918 Write_Str (Name_Buffer (1 .. Name_Len));
24919 Write_Str (" is not supported in this configuration");
24921 raise Unrecoverable_Error;
24923 end Unimplemented_Unit;
24925 ------------------------
24926 -- Universal_Aliasing --
24927 ------------------------
24929 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24931 when Pragma_Universal_Aliasing => Universal_Alias : declare
24937 Check_Arg_Count (1);
24938 Check_Optional_Identifier (Arg2, Name_Entity);
24939 Check_Arg_Is_Local_Name (Arg1);
24940 E_Id := Get_Pragma_Arg (Arg1);
24942 if Etype (E_Id) = Any_Type then
24946 E := Entity (E_Id);
24948 if not Is_Type (E) then
24949 Error_Pragma_Arg ("pragma% requires type", Arg1);
24952 -- A pragma that applies to a Ghost entity becomes Ghost for the
24953 -- purposes of legality checks and removal of ignored Ghost code.
24955 Mark_Ghost_Pragma (N, E);
24956 Set_Universal_Aliasing (Base_Type (E));
24957 Record_Rep_Item (E, N);
24958 end Universal_Alias;
24960 --------------------
24961 -- Universal_Data --
24962 --------------------
24964 -- pragma Universal_Data [(library_unit_NAME)];
24966 when Pragma_Universal_Data =>
24968 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
24974 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24976 when Pragma_Unmodified =>
24977 Analyze_Unmodified_Or_Unused;
24983 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24985 -- or when used in a context clause:
24987 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24989 when Pragma_Unreferenced =>
24990 Analyze_Unreferenced_Or_Unused;
24992 --------------------------
24993 -- Unreferenced_Objects --
24994 --------------------------
24996 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24998 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
25000 Arg_Expr : Node_Id;
25001 Arg_Id : Entity_Id;
25003 Ghost_Error_Posted : Boolean := False;
25004 -- Flag set when an error concerning the illegal mix of Ghost and
25005 -- non-Ghost types is emitted.
25007 Ghost_Id : Entity_Id := Empty;
25008 -- The entity of the first Ghost type encountered while processing
25009 -- the arguments of the pragma.
25013 Check_At_Least_N_Arguments (1);
25016 while Present (Arg) loop
25017 Check_No_Identifier (Arg);
25018 Check_Arg_Is_Local_Name (Arg);
25019 Arg_Expr := Get_Pragma_Arg (Arg);
25021 if Is_Entity_Name (Arg_Expr) then
25022 Arg_Id := Entity (Arg_Expr);
25024 if Is_Type (Arg_Id) then
25025 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
25027 -- A pragma that applies to a Ghost entity becomes Ghost
25028 -- for the purposes of legality checks and removal of
25029 -- ignored Ghost code.
25031 Mark_Ghost_Pragma (N, Arg_Id);
25033 -- Capture the entity of the first Ghost type being
25034 -- processed for error detection purposes.
25036 if Is_Ghost_Entity (Arg_Id) then
25037 if No (Ghost_Id) then
25038 Ghost_Id := Arg_Id;
25041 -- Otherwise the type is non-Ghost. It is illegal to mix
25042 -- references to Ghost and non-Ghost entities
25045 elsif Present (Ghost_Id)
25046 and then not Ghost_Error_Posted
25048 Ghost_Error_Posted := True;
25050 Error_Msg_Name_1 := Pname;
25052 ("pragma % cannot mention ghost and non-ghost types",
25055 Error_Msg_Sloc := Sloc (Ghost_Id);
25056 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
25058 Error_Msg_Sloc := Sloc (Arg_Id);
25059 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
25063 ("argument for pragma% must be type or subtype", Arg);
25067 ("argument for pragma% must be type or subtype", Arg);
25072 end Unreferenced_Objects;
25074 ------------------------------
25075 -- Unreserve_All_Interrupts --
25076 ------------------------------
25078 -- pragma Unreserve_All_Interrupts;
25080 when Pragma_Unreserve_All_Interrupts =>
25082 Check_Arg_Count (0);
25084 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
25085 Unreserve_All_Interrupts := True;
25092 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25094 when Pragma_Unsuppress =>
25096 Process_Suppress_Unsuppress (Suppress_Case => False);
25102 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25104 when Pragma_Unused =>
25105 Analyze_Unmodified_Or_Unused (Is_Unused => True);
25106 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
25108 -------------------
25109 -- Use_VADS_Size --
25110 -------------------
25112 -- pragma Use_VADS_Size;
25114 when Pragma_Use_VADS_Size =>
25116 Check_Arg_Count (0);
25117 Check_Valid_Configuration_Pragma;
25118 Use_VADS_Size := True;
25120 ---------------------
25121 -- Validity_Checks --
25122 ---------------------
25124 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25126 when Pragma_Validity_Checks => Validity_Checks : declare
25127 A : constant Node_Id := Get_Pragma_Arg (Arg1);
25133 Check_Arg_Count (1);
25134 Check_No_Identifiers;
25136 -- Pragma always active unless in CodePeer or GNATprove modes,
25137 -- which use a fixed configuration of validity checks.
25139 if not (CodePeer_Mode or GNATprove_Mode) then
25140 if Nkind (A) = N_String_Literal then
25144 Slen : constant Natural := Natural (String_Length (S));
25145 Options : String (1 .. Slen);
25149 -- Couldn't we use a for loop here over Options'Range???
25153 C := Get_String_Char (S, Pos (J));
25155 -- This is a weird test, it skips setting validity
25156 -- checks entirely if any element of S is out of
25157 -- range of Character, what is that about ???
25159 exit when not In_Character_Range (C);
25160 Options (J) := Get_Character (C);
25163 Set_Validity_Check_Options (Options);
25171 elsif Nkind (A) = N_Identifier then
25172 if Chars (A) = Name_All_Checks then
25173 Set_Validity_Check_Options ("a");
25174 elsif Chars (A) = Name_On then
25175 Validity_Checks_On := True;
25176 elsif Chars (A) = Name_Off then
25177 Validity_Checks_On := False;
25181 end Validity_Checks;
25187 -- pragma Volatile (LOCAL_NAME);
25189 when Pragma_Volatile =>
25190 Process_Atomic_Independent_Shared_Volatile;
25192 -------------------------
25193 -- Volatile_Components --
25194 -------------------------
25196 -- pragma Volatile_Components (array_LOCAL_NAME);
25198 -- Volatile is handled by the same circuit as Atomic_Components
25200 --------------------------
25201 -- Volatile_Full_Access --
25202 --------------------------
25204 -- pragma Volatile_Full_Access (LOCAL_NAME);
25206 when Pragma_Volatile_Full_Access =>
25208 Process_Atomic_Independent_Shared_Volatile;
25210 -----------------------
25211 -- Volatile_Function --
25212 -----------------------
25214 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25216 when Pragma_Volatile_Function => Volatile_Function : declare
25217 Over_Id : Entity_Id;
25218 Spec_Id : Entity_Id;
25219 Subp_Decl : Node_Id;
25223 Check_No_Identifiers;
25224 Check_At_Most_N_Arguments (1);
25227 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
25229 -- Generic subprogram
25231 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
25234 -- Body acts as spec
25236 elsif Nkind (Subp_Decl) = N_Subprogram_Body
25237 and then No (Corresponding_Spec (Subp_Decl))
25241 -- Body stub acts as spec
25243 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
25244 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
25250 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
25258 Spec_Id := Unique_Defining_Entity (Subp_Decl);
25260 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
25265 -- A pragma that applies to a Ghost entity becomes Ghost for the
25266 -- purposes of legality checks and removal of ignored Ghost code.
25268 Mark_Ghost_Pragma (N, Spec_Id);
25270 -- Chain the pragma on the contract for completeness
25272 Add_Contract_Item (N, Spec_Id);
25274 -- The legality checks of pragma Volatile_Function are affected by
25275 -- the SPARK mode in effect. Analyze all pragmas in a specific
25278 Analyze_If_Present (Pragma_SPARK_Mode);
25280 -- A volatile function cannot override a non-volatile function
25281 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25282 -- in New_Overloaded_Entity, however at that point the pragma has
25283 -- not been processed yet.
25285 Over_Id := Overridden_Operation (Spec_Id);
25287 if Present (Over_Id)
25288 and then not Is_Volatile_Function (Over_Id)
25291 ("incompatible volatile function values in effect", Spec_Id);
25293 Error_Msg_Sloc := Sloc (Over_Id);
25295 ("\& declared # with Volatile_Function value False",
25298 Error_Msg_Sloc := Sloc (Spec_Id);
25300 ("\overridden # with Volatile_Function value True",
25304 -- Analyze the Boolean expression (if any)
25306 if Present (Arg1) then
25307 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
25309 end Volatile_Function;
25311 ----------------------
25312 -- Warning_As_Error --
25313 ----------------------
25315 -- pragma Warning_As_Error (static_string_EXPRESSION);
25317 when Pragma_Warning_As_Error =>
25319 Check_Arg_Count (1);
25320 Check_No_Identifiers;
25321 Check_Valid_Configuration_Pragma;
25323 if not Is_Static_String_Expression (Arg1) then
25325 ("argument of pragma% must be static string expression",
25328 -- OK static string expression
25331 Acquire_Warning_Match_String (Arg1);
25332 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
25333 Warnings_As_Errors (Warnings_As_Errors_Count) :=
25334 new String'(Name_Buffer (1 .. Name_Len));
25341 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25343 -- DETAILS ::= On | Off
25344 -- DETAILS ::= On | Off, local_NAME
25345 -- DETAILS ::= static_string_EXPRESSION
25346 -- DETAILS ::= On | Off, static_string_EXPRESSION
25348 -- TOOL_NAME ::= GNAT | GNATProve
25350 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25352 -- Note: If the first argument matches an allowed tool name, it is
25353 -- always considered to be a tool name, even if there is a string
25354 -- variable of that name.
25356 -- Note if the second argument of DETAILS is a local_NAME then the
25357 -- second form is always understood. If the intention is to use
25358 -- the fourth form, then you can write NAME & "" to force the
25359 -- intepretation as a static_string_EXPRESSION.
25361 when Pragma_Warnings => Warnings : declare
25362 Reason : String_Id;
25366 Check_At_Least_N_Arguments (1);
25368 -- See if last argument is labeled Reason. If so, make sure we
25369 -- have a string literal or a concatenation of string literals,
25370 -- and acquire the REASON string. Then remove the REASON argument
25371 -- by decreasing Num_Args by one; Remaining processing looks only
25372 -- at first Num_Args arguments).
25375 Last_Arg : constant Node_Id :=
25376 Last (Pragma_Argument_Associations (N));
25379 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25380 and then Chars (Last_Arg) = Name_Reason
25383 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25384 Reason := End_String;
25385 Arg_Count := Arg_Count - 1;
25387 -- Not allowed in compiler units (bootstrap issues)
25389 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25391 -- No REASON string, set null string as reason
25394 Reason := Null_String_Id;
25398 -- Now proceed with REASON taken care of and eliminated
25400 Check_No_Identifiers;
25402 -- If debug flag -gnatd.i is set, pragma is ignored
25404 if Debug_Flag_Dot_I then
25408 -- Process various forms of the pragma
25411 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25412 Shifted_Args : List_Id;
25415 -- See if first argument is a tool name, currently either
25416 -- GNAT or GNATprove. If so, either ignore the pragma if the
25417 -- tool used does not match, or continue as if no tool name
25418 -- was given otherwise, by shifting the arguments.
25420 if Nkind (Argx) = N_Identifier
25421 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25423 if Chars (Argx) = Name_Gnat then
25424 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25425 Rewrite (N, Make_Null_Statement (Loc));
25430 elsif Chars (Argx) = Name_Gnatprove then
25431 if not GNATprove_Mode then
25432 Rewrite (N, Make_Null_Statement (Loc));
25438 raise Program_Error;
25441 -- At this point, the pragma Warnings applies to the tool,
25442 -- so continue with shifted arguments.
25444 Arg_Count := Arg_Count - 1;
25446 if Arg_Count = 1 then
25447 Shifted_Args := New_List (New_Copy (Arg2));
25448 elsif Arg_Count = 2 then
25449 Shifted_Args := New_List (New_Copy (Arg2),
25451 elsif Arg_Count = 3 then
25452 Shifted_Args := New_List (New_Copy (Arg2),
25456 raise Program_Error;
25461 Chars => Name_Warnings,
25462 Pragma_Argument_Associations => Shifted_Args));
25467 -- One argument case
25469 if Arg_Count = 1 then
25471 -- On/Off one argument case was processed by parser
25473 if Nkind (Argx) = N_Identifier
25474 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25478 -- One argument case must be ON/OFF or static string expr
25480 elsif not Is_Static_String_Expression (Arg1) then
25482 ("argument of pragma% must be On/Off or static string "
25483 & "expression", Arg1);
25485 -- One argument string expression case
25489 Lit : constant Node_Id := Expr_Value_S (Argx);
25490 Str : constant String_Id := Strval (Lit);
25491 Len : constant Nat := String_Length (Str);
25499 while J <= Len loop
25500 C := Get_String_Char (Str, J);
25501 OK := In_Character_Range (C);
25504 Chr := Get_Character (C);
25506 -- Dash case: only -Wxxx is accepted
25513 C := Get_String_Char (Str, J);
25514 Chr := Get_Character (C);
25515 exit when Chr = 'W';
25520 elsif J < Len and then Chr = '.' then
25522 C := Get_String_Char (Str, J);
25523 Chr := Get_Character (C);
25525 if not Set_Dot_Warning_Switch (Chr) then
25527 ("invalid warning switch character "
25528 & '.' & Chr, Arg1);
25534 OK := Set_Warning_Switch (Chr);
25539 ("invalid warning switch character " & Chr,
25545 ("invalid wide character in warning switch ",
25554 -- Two or more arguments (must be two)
25557 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25558 Check_Arg_Count (2);
25566 E_Id := Get_Pragma_Arg (Arg2);
25569 -- In the expansion of an inlined body, a reference to
25570 -- the formal may be wrapped in a conversion if the
25571 -- actual is a conversion. Retrieve the real entity name.
25573 if (In_Instance_Body or In_Inlined_Body)
25574 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25576 E_Id := Expression (E_Id);
25579 -- Entity name case
25581 if Is_Entity_Name (E_Id) then
25582 E := Entity (E_Id);
25589 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25592 -- Suppress elaboration warnings if the entity
25593 -- denotes an elaboration target.
25595 if Is_Elaboration_Target (E) then
25596 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25599 -- For OFF case, make entry in warnings off
25600 -- pragma table for later processing. But we do
25601 -- not do that within an instance, since these
25602 -- warnings are about what is needed in the
25603 -- template, not an instance of it.
25605 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25606 and then Warn_On_Warnings_Off
25607 and then not In_Instance
25609 Warnings_Off_Pragmas.Append ((N, E, Reason));
25612 if Is_Enumeration_Type (E) then
25616 Lit := First_Literal (E);
25617 while Present (Lit) loop
25618 Set_Warnings_Off (Lit);
25619 Next_Literal (Lit);
25624 exit when No (Homonym (E));
25629 -- Error if not entity or static string expression case
25631 elsif not Is_Static_String_Expression (Arg2) then
25633 ("second argument of pragma% must be entity name "
25634 & "or static string expression", Arg2);
25636 -- Static string expression case
25639 Acquire_Warning_Match_String (Arg2);
25641 -- Note on configuration pragma case: If this is a
25642 -- configuration pragma, then for an OFF pragma, we
25643 -- just set Config True in the call, which is all
25644 -- that needs to be done. For the case of ON, this
25645 -- is normally an error, unless it is canceling the
25646 -- effect of a previous OFF pragma in the same file.
25647 -- In any other case, an error will be signalled (ON
25648 -- with no matching OFF).
25650 -- Note: We set Used if we are inside a generic to
25651 -- disable the test that the non-config case actually
25652 -- cancels a warning. That's because we can't be sure
25653 -- there isn't an instantiation in some other unit
25654 -- where a warning is suppressed.
25656 -- We could do a little better here by checking if the
25657 -- generic unit we are inside is public, but for now
25658 -- we don't bother with that refinement.
25660 if Chars (Argx) = Name_Off then
25661 Set_Specific_Warning_Off
25662 (Loc, Name_Buffer (1 .. Name_Len), Reason,
25663 Config => Is_Configuration_Pragma,
25664 Used => Inside_A_Generic or else In_Instance);
25666 elsif Chars (Argx) = Name_On then
25667 Set_Specific_Warning_On
25668 (Loc, Name_Buffer (1 .. Name_Len), Err);
25672 ("??pragma Warnings On with no matching "
25673 & "Warnings Off", Loc);
25682 -------------------
25683 -- Weak_External --
25684 -------------------
25686 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25688 when Pragma_Weak_External => Weak_External : declare
25693 Check_Arg_Count (1);
25694 Check_Optional_Identifier (Arg1, Name_Entity);
25695 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25696 Ent := Entity (Get_Pragma_Arg (Arg1));
25698 if Rep_Item_Too_Early (Ent, N) then
25701 Ent := Underlying_Type (Ent);
25704 -- The pragma applies to entities with addresses
25706 if Is_Type (Ent) then
25707 Error_Pragma ("pragma applies to objects and subprograms");
25710 -- The only processing required is to link this item on to the
25711 -- list of rep items for the given entity. This is accomplished
25712 -- by the call to Rep_Item_Too_Late (when no error is detected
25713 -- and False is returned).
25715 if Rep_Item_Too_Late (Ent, N) then
25718 Set_Has_Gigi_Rep_Item (Ent);
25722 -----------------------------
25723 -- Wide_Character_Encoding --
25724 -----------------------------
25726 -- pragma Wide_Character_Encoding (IDENTIFIER);
25728 when Pragma_Wide_Character_Encoding =>
25731 -- Nothing to do, handled in parser. Note that we do not enforce
25732 -- configuration pragma placement, this pragma can appear at any
25733 -- place in the source, allowing mixed encodings within a single
25738 --------------------
25739 -- Unknown_Pragma --
25740 --------------------
25742 -- Should be impossible, since the case of an unknown pragma is
25743 -- separately processed before the case statement is entered.
25745 when Unknown_Pragma =>
25746 raise Program_Error;
25749 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25750 -- until AI is formally approved.
25752 -- Check_Order_Dependence;
25755 when Pragma_Exit => null;
25756 end Analyze_Pragma;
25758 ---------------------------------------------
25759 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25760 ---------------------------------------------
25762 -- WARNING: This routine manages Ghost regions. Return statements must be
25763 -- replaced by gotos which jump to the end of the routine and restore the
25766 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25768 Freeze_Id : Entity_Id := Empty)
25770 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25771 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25773 Disp_Typ : Entity_Id;
25774 -- The dispatching type of the subprogram subject to the pre- or
25777 function Check_References (Nod : Node_Id) return Traverse_Result;
25778 -- Check that expression Nod does not mention non-primitives of the
25779 -- type, global objects of the type, or other illegalities described
25780 -- and implied by AI12-0113.
25782 ----------------------
25783 -- Check_References --
25784 ----------------------
25786 function Check_References (Nod : Node_Id) return Traverse_Result is
25788 if Nkind (Nod) = N_Function_Call
25789 and then Is_Entity_Name (Name (Nod))
25792 Func : constant Entity_Id := Entity (Name (Nod));
25796 -- An operation of the type must be a primitive
25798 if No (Find_Dispatching_Type (Func)) then
25799 Form := First_Formal (Func);
25800 while Present (Form) loop
25801 if Etype (Form) = Disp_Typ then
25803 ("operation in class-wide condition must be "
25804 & "primitive of &", Nod, Disp_Typ);
25807 Next_Formal (Form);
25810 -- A return object of the type is illegal as well
25812 if Etype (Func) = Disp_Typ
25813 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25816 ("operation in class-wide condition must be primitive "
25817 & "of &", Nod, Disp_Typ);
25820 -- Otherwise we have a call to an overridden primitive, and we
25821 -- will create a common class-wide clone for the body of
25822 -- original operation and its eventual inherited versions. If
25823 -- the original operation dispatches on result it is never
25824 -- inherited and there is no need for a clone. There is not
25825 -- need for a clone either in GNATprove mode, as cases that
25826 -- would require it are rejected (when an inherited primitive
25827 -- calls an overridden operation in a class-wide contract), and
25828 -- the clone would make proof impossible in some cases.
25830 elsif not Is_Abstract_Subprogram (Spec_Id)
25831 and then No (Class_Wide_Clone (Spec_Id))
25832 and then not Has_Controlling_Result (Spec_Id)
25833 and then not GNATprove_Mode
25835 Build_Class_Wide_Clone_Decl (Spec_Id);
25839 elsif Is_Entity_Name (Nod)
25841 (Etype (Nod) = Disp_Typ
25842 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25843 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25846 ("object in class-wide condition must be formal of type &",
25849 elsif Nkind (Nod) = N_Explicit_Dereference
25850 and then (Etype (Nod) = Disp_Typ
25851 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25852 and then (not Is_Entity_Name (Prefix (Nod))
25853 or else not Is_Formal (Entity (Prefix (Nod))))
25856 ("operation in class-wide condition must be primitive of &",
25861 end Check_References;
25863 procedure Check_Class_Wide_Condition is
25864 new Traverse_Proc (Check_References);
25868 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25870 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25871 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25872 -- Save the Ghost-related attributes to restore on exit
25875 Restore_Scope : Boolean := False;
25877 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25880 -- Do not analyze the pragma multiple times
25882 if Is_Analyzed_Pragma (N) then
25886 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25887 -- analysis of the pragma, the Ghost mode at point of declaration and
25888 -- point of analysis may not necessarily be the same. Use the mode in
25889 -- effect at the point of declaration.
25891 Set_Ghost_Mode (N);
25893 -- Ensure that the subprogram and its formals are visible when analyzing
25894 -- the expression of the pragma.
25896 if not In_Open_Scopes (Spec_Id) then
25897 Restore_Scope := True;
25898 Push_Scope (Spec_Id);
25900 if Is_Generic_Subprogram (Spec_Id) then
25901 Install_Generic_Formals (Spec_Id);
25903 Install_Formals (Spec_Id);
25907 Errors := Serious_Errors_Detected;
25908 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25910 -- Emit a clarification message when the expression contains at least
25911 -- one undefined reference, possibly due to contract freezing.
25913 if Errors /= Serious_Errors_Detected
25914 and then Present (Freeze_Id)
25915 and then Has_Undefined_Reference (Expr)
25917 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25920 if Class_Present (N) then
25922 -- Verify that a class-wide condition is legal, i.e. the operation is
25923 -- a primitive of a tagged type. Note that a generic subprogram is
25924 -- not a primitive operation.
25926 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25928 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25929 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25931 if From_Aspect_Specification (N) then
25933 ("aspect % can only be specified for a primitive operation "
25934 & "of a tagged type", Corresponding_Aspect (N));
25936 -- The pragma is a source construct
25940 ("pragma % can only be specified for a primitive operation "
25941 & "of a tagged type", N);
25944 -- Remaining semantic checks require a full tree traversal
25947 Check_Class_Wide_Condition (Expr);
25952 if Restore_Scope then
25956 -- If analysis of the condition indicates that a class-wide clone
25957 -- has been created, build and analyze its declaration.
25959 if Is_Subprogram (Spec_Id)
25960 and then Present (Class_Wide_Clone (Spec_Id))
25962 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25965 -- Currently it is not possible to inline pre/postconditions on a
25966 -- subprogram subject to pragma Inline_Always.
25968 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25969 Set_Is_Analyzed_Pragma (N);
25971 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25972 end Analyze_Pre_Post_Condition_In_Decl_Part;
25974 ------------------------------------------
25975 -- Analyze_Refined_Depends_In_Decl_Part --
25976 ------------------------------------------
25978 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25979 procedure Check_Dependency_Clause
25980 (Spec_Id : Entity_Id;
25981 Dep_Clause : Node_Id;
25982 Dep_States : Elist_Id;
25983 Refinements : List_Id;
25984 Matched_Items : in out Elist_Id);
25985 -- Try to match a single dependency clause Dep_Clause against one or
25986 -- more refinement clauses found in list Refinements. Each successful
25987 -- match eliminates at least one refinement clause from Refinements.
25988 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25989 -- denotes the entities of all abstract states which appear in pragma
25990 -- Depends. Matched_Items contains the entities of all successfully
25991 -- matched items found in pragma Depends.
25993 procedure Check_Output_States
25994 (Spec_Id : Entity_Id;
25995 Spec_Inputs : Elist_Id;
25996 Spec_Outputs : Elist_Id;
25997 Body_Inputs : Elist_Id;
25998 Body_Outputs : Elist_Id);
25999 -- Determine whether pragma Depends contains an output state with a
26000 -- visible refinement and if so, ensure that pragma Refined_Depends
26001 -- mentions all its constituents as outputs. Spec_Id is the entity of
26002 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
26003 -- inputs and outputs of the subprogram spec synthesized from pragma
26004 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
26005 -- of the subprogram body synthesized from pragma Refined_Depends.
26007 function Collect_States (Clauses : List_Id) return Elist_Id;
26008 -- Given a normalized list of dependencies obtained from calling
26009 -- Normalize_Clauses, return a list containing the entities of all
26010 -- states appearing in dependencies. It helps in checking refinements
26011 -- involving a state and a corresponding constituent which is not a
26012 -- direct constituent of the state.
26014 procedure Normalize_Clauses (Clauses : List_Id);
26015 -- Given a list of dependence or refinement clauses Clauses, normalize
26016 -- each clause by creating multiple dependencies with exactly one input
26019 procedure Remove_Extra_Clauses
26020 (Clauses : List_Id;
26021 Matched_Items : Elist_Id);
26022 -- Given a list of refinement clauses Clauses, remove all clauses whose
26023 -- inputs and/or outputs have been previously matched. See the body for
26024 -- all special cases. Matched_Items contains the entities of all matched
26025 -- items found in pragma Depends.
26027 procedure Report_Extra_Clauses
26028 (Spec_Id : Entity_Id;
26029 Clauses : List_Id);
26030 -- Emit an error for each extra clause found in list Clauses. Spec_Id
26031 -- denotes the entity of the related subprogram.
26033 -----------------------------
26034 -- Check_Dependency_Clause --
26035 -----------------------------
26037 procedure Check_Dependency_Clause
26038 (Spec_Id : Entity_Id;
26039 Dep_Clause : Node_Id;
26040 Dep_States : Elist_Id;
26041 Refinements : List_Id;
26042 Matched_Items : in out Elist_Id)
26044 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26045 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26047 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26048 -- Determine whether dependency item Dep_Item has been matched in a
26049 -- previous clause.
26051 function Is_In_Out_State_Clause return Boolean;
26052 -- Determine whether dependence clause Dep_Clause denotes an abstract
26053 -- state that depends on itself (State => State).
26055 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26056 -- Determine whether item Item denotes an abstract state with visible
26057 -- null refinement.
26059 procedure Match_Items
26060 (Dep_Item : Node_Id;
26061 Ref_Item : Node_Id;
26062 Matched : out Boolean);
26063 -- Try to match dependence item Dep_Item against refinement item
26064 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26065 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26066 -- the following conformance scenarios is in effect:
26067 -- 1) Both items denote null
26068 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26069 -- 3) Both items denote attribute 'Result
26070 -- 4) Both items denote the same object
26071 -- 5) Both items denote the same formal parameter
26072 -- 6) Both items denote the same current instance of a type
26073 -- 7) Both items denote the same discriminant
26074 -- 8) Dep_Item is an abstract state with visible null refinement
26075 -- and Ref_Item denotes null.
26076 -- 9) Dep_Item is an abstract state with visible null refinement
26077 -- and Ref_Item is Empty (special case).
26078 -- 10) Dep_Item is an abstract state with full or partial visible
26079 -- non-null refinement and Ref_Item denotes one of its
26081 -- 11) Dep_Item is an abstract state without a full visible
26082 -- refinement and Ref_Item denotes the same state.
26083 -- When scenario 10 is in effect, the entity of the abstract state
26084 -- denoted by Dep_Item is added to list Refined_States.
26086 procedure Record_Item (Item_Id : Entity_Id);
26087 -- Store the entity of an item denoted by Item_Id in Matched_Items
26089 ------------------------
26090 -- Is_Already_Matched --
26091 ------------------------
26093 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
26094 Item_Id : Entity_Id := Empty;
26097 -- When the dependency item denotes attribute 'Result, check for
26098 -- the entity of the related subprogram.
26100 if Is_Attribute_Result (Dep_Item) then
26101 Item_Id := Spec_Id;
26103 elsif Is_Entity_Name (Dep_Item) then
26104 Item_Id := Available_View (Entity_Of (Dep_Item));
26108 Present (Item_Id) and then Contains (Matched_Items, Item_Id);
26109 end Is_Already_Matched;
26111 ----------------------------
26112 -- Is_In_Out_State_Clause --
26113 ----------------------------
26115 function Is_In_Out_State_Clause return Boolean is
26116 Dep_Input_Id : Entity_Id;
26117 Dep_Output_Id : Entity_Id;
26120 -- Detect the following clause:
26123 if Is_Entity_Name (Dep_Input)
26124 and then Is_Entity_Name (Dep_Output)
26126 -- Handle abstract views generated for limited with clauses
26128 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
26129 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
26132 Ekind (Dep_Input_Id) = E_Abstract_State
26133 and then Dep_Input_Id = Dep_Output_Id;
26137 end Is_In_Out_State_Clause;
26139 ---------------------------
26140 -- Is_Null_Refined_State --
26141 ---------------------------
26143 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
26144 Item_Id : Entity_Id;
26147 if Is_Entity_Name (Item) then
26149 -- Handle abstract views generated for limited with clauses
26151 Item_Id := Available_View (Entity_Of (Item));
26154 Ekind (Item_Id) = E_Abstract_State
26155 and then Has_Null_Visible_Refinement (Item_Id);
26159 end Is_Null_Refined_State;
26165 procedure Match_Items
26166 (Dep_Item : Node_Id;
26167 Ref_Item : Node_Id;
26168 Matched : out Boolean)
26170 Dep_Item_Id : Entity_Id;
26171 Ref_Item_Id : Entity_Id;
26174 -- Assume that the two items do not match
26178 -- A null matches null or Empty (special case)
26180 if Nkind (Dep_Item) = N_Null
26181 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26185 -- Attribute 'Result matches attribute 'Result
26187 elsif Is_Attribute_Result (Dep_Item)
26188 and then Is_Attribute_Result (Ref_Item)
26190 -- Put the entity of the related function on the list of
26191 -- matched items because attribute 'Result does not carry
26192 -- an entity similar to states and constituents.
26194 Record_Item (Spec_Id);
26197 -- Abstract states, current instances of concurrent types,
26198 -- discriminants, formal parameters and objects.
26200 elsif Is_Entity_Name (Dep_Item) then
26202 -- Handle abstract views generated for limited with clauses
26204 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
26206 if Ekind (Dep_Item_Id) = E_Abstract_State then
26208 -- An abstract state with visible null refinement matches
26209 -- null or Empty (special case).
26211 if Has_Null_Visible_Refinement (Dep_Item_Id)
26212 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
26214 Record_Item (Dep_Item_Id);
26217 -- An abstract state with visible non-null refinement
26218 -- matches one of its constituents, or itself for an
26219 -- abstract state with partial visible refinement.
26221 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
26222 if Is_Entity_Name (Ref_Item) then
26223 Ref_Item_Id := Entity_Of (Ref_Item);
26225 if Ekind_In (Ref_Item_Id, E_Abstract_State,
26228 and then Present (Encapsulating_State (Ref_Item_Id))
26229 and then Find_Encapsulating_State
26230 (Dep_States, Ref_Item_Id) = Dep_Item_Id
26232 Record_Item (Dep_Item_Id);
26235 elsif not Has_Visible_Refinement (Dep_Item_Id)
26236 and then Ref_Item_Id = Dep_Item_Id
26238 Record_Item (Dep_Item_Id);
26243 -- An abstract state without a visible refinement matches
26246 elsif Is_Entity_Name (Ref_Item)
26247 and then Entity_Of (Ref_Item) = Dep_Item_Id
26249 Record_Item (Dep_Item_Id);
26253 -- A current instance of a concurrent type, discriminant,
26254 -- formal parameter or an object matches itself.
26256 elsif Is_Entity_Name (Ref_Item)
26257 and then Entity_Of (Ref_Item) = Dep_Item_Id
26259 Record_Item (Dep_Item_Id);
26269 procedure Record_Item (Item_Id : Entity_Id) is
26271 if No (Matched_Items) then
26272 Matched_Items := New_Elmt_List;
26275 Append_Unique_Elmt (Item_Id, Matched_Items);
26280 Clause_Matched : Boolean := False;
26281 Dummy : Boolean := False;
26282 Inputs_Match : Boolean;
26283 Next_Ref_Clause : Node_Id;
26284 Outputs_Match : Boolean;
26285 Ref_Clause : Node_Id;
26286 Ref_Input : Node_Id;
26287 Ref_Output : Node_Id;
26289 -- Start of processing for Check_Dependency_Clause
26292 -- Do not perform this check in an instance because it was already
26293 -- performed successfully in the generic template.
26295 if Is_Generic_Instance (Spec_Id) then
26299 -- Examine all refinement clauses and compare them against the
26300 -- dependence clause.
26302 Ref_Clause := First (Refinements);
26303 while Present (Ref_Clause) loop
26304 Next_Ref_Clause := Next (Ref_Clause);
26306 -- Obtain the attributes of the current refinement clause
26308 Ref_Input := Expression (Ref_Clause);
26309 Ref_Output := First (Choices (Ref_Clause));
26311 -- The current refinement clause matches the dependence clause
26312 -- when both outputs match and both inputs match. See routine
26313 -- Match_Items for all possible conformance scenarios.
26315 -- Depends Dep_Output => Dep_Input
26319 -- Refined_Depends Ref_Output => Ref_Input
26322 (Dep_Item => Dep_Input,
26323 Ref_Item => Ref_Input,
26324 Matched => Inputs_Match);
26327 (Dep_Item => Dep_Output,
26328 Ref_Item => Ref_Output,
26329 Matched => Outputs_Match);
26331 -- An In_Out state clause may be matched against a refinement with
26332 -- a null input or null output as long as the non-null side of the
26333 -- relation contains a valid constituent of the In_Out_State.
26335 if Is_In_Out_State_Clause then
26337 -- Depends => (State => State)
26338 -- Refined_Depends => (null => Constit) -- OK
26341 and then not Outputs_Match
26342 and then Nkind (Ref_Output) = N_Null
26344 Outputs_Match := True;
26347 -- Depends => (State => State)
26348 -- Refined_Depends => (Constit => null) -- OK
26350 if not Inputs_Match
26351 and then Outputs_Match
26352 and then Nkind (Ref_Input) = N_Null
26354 Inputs_Match := True;
26358 -- The current refinement clause is legally constructed following
26359 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26360 -- the pool of candidates. The seach continues because a single
26361 -- dependence clause may have multiple matching refinements.
26363 if Inputs_Match and Outputs_Match then
26364 Clause_Matched := True;
26365 Remove (Ref_Clause);
26368 Ref_Clause := Next_Ref_Clause;
26371 -- Depending on the order or composition of refinement clauses, an
26372 -- In_Out state clause may not be directly refinable.
26374 -- Refined_State => (State => (Constit_1, Constit_2))
26375 -- Depends => ((Output, State) => (Input, State))
26376 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26378 -- Matching normalized clause (State => State) fails because there is
26379 -- no direct refinement capable of satisfying this relation. Another
26380 -- similar case arises when clauses (Constit_1 => Input) and (Output
26381 -- => Constit_2) are matched first, leaving no candidates for clause
26382 -- (State => State). Both scenarios are legal as long as one of the
26383 -- previous clauses mentioned a valid constituent of State.
26385 if not Clause_Matched
26386 and then Is_In_Out_State_Clause
26387 and then Is_Already_Matched (Dep_Input)
26389 Clause_Matched := True;
26392 -- A clause where the input is an abstract state with visible null
26393 -- refinement or a 'Result attribute is implicitly matched when the
26394 -- output has already been matched in a previous clause.
26396 -- Refined_State => (State => null)
26397 -- Depends => (Output => State) -- implicitly OK
26398 -- Refined_Depends => (Output => ...)
26399 -- Depends => (...'Result => State) -- implicitly OK
26400 -- Refined_Depends => (...'Result => ...)
26402 if not Clause_Matched
26403 and then Is_Null_Refined_State (Dep_Input)
26404 and then Is_Already_Matched (Dep_Output)
26406 Clause_Matched := True;
26409 -- A clause where the output is an abstract state with visible null
26410 -- refinement is implicitly matched when the input has already been
26411 -- matched in a previous clause.
26413 -- Refined_State => (State => null)
26414 -- Depends => (State => Input) -- implicitly OK
26415 -- Refined_Depends => (... => Input)
26417 if not Clause_Matched
26418 and then Is_Null_Refined_State (Dep_Output)
26419 and then Is_Already_Matched (Dep_Input)
26421 Clause_Matched := True;
26424 -- At this point either all refinement clauses have been examined or
26425 -- pragma Refined_Depends contains a solitary null. Only an abstract
26426 -- state with null refinement can possibly match these cases.
26428 -- Refined_State => (State => null)
26429 -- Depends => (State => null)
26430 -- Refined_Depends => null -- OK
26432 if not Clause_Matched then
26434 (Dep_Item => Dep_Input,
26436 Matched => Inputs_Match);
26439 (Dep_Item => Dep_Output,
26441 Matched => Outputs_Match);
26443 Clause_Matched := Inputs_Match and Outputs_Match;
26446 -- If the contents of Refined_Depends are legal, then the current
26447 -- dependence clause should be satisfied either by an explicit match
26448 -- or by one of the special cases.
26450 if not Clause_Matched then
26452 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
26453 & "matching refinement in body"), Dep_Clause, Spec_Id);
26455 end Check_Dependency_Clause;
26457 -------------------------
26458 -- Check_Output_States --
26459 -------------------------
26461 procedure Check_Output_States
26462 (Spec_Id : Entity_Id;
26463 Spec_Inputs : Elist_Id;
26464 Spec_Outputs : Elist_Id;
26465 Body_Inputs : Elist_Id;
26466 Body_Outputs : Elist_Id)
26468 procedure Check_Constituent_Usage (State_Id : Entity_Id);
26469 -- Determine whether all constituents of state State_Id with full
26470 -- visible refinement are used as outputs in pragma Refined_Depends.
26471 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26473 -----------------------------
26474 -- Check_Constituent_Usage --
26475 -----------------------------
26477 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
26478 Constits : constant Elist_Id :=
26479 Partial_Refinement_Constituents (State_Id);
26480 Constit_Elmt : Elmt_Id;
26481 Constit_Id : Entity_Id;
26482 Only_Partial : constant Boolean :=
26483 not Has_Visible_Refinement (State_Id);
26484 Posted : Boolean := False;
26487 if Present (Constits) then
26488 Constit_Elmt := First_Elmt (Constits);
26489 while Present (Constit_Elmt) loop
26490 Constit_Id := Node (Constit_Elmt);
26492 -- Issue an error when a constituent of State_Id is used,
26493 -- and State_Id has only partial visible refinement
26494 -- (SPARK RM 7.2.4(3d)).
26496 if Only_Partial then
26497 if (Present (Body_Inputs)
26498 and then Appears_In (Body_Inputs, Constit_Id))
26500 (Present (Body_Outputs)
26501 and then Appears_In (Body_Outputs, Constit_Id))
26503 Error_Msg_Name_1 := Chars (State_Id);
26505 ("constituent & of state % cannot be used in "
26506 & "dependence refinement", N, Constit_Id);
26507 Error_Msg_Name_1 := Chars (State_Id);
26508 SPARK_Msg_N ("\use state % instead", N);
26511 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26513 elsif Present (Body_Inputs)
26514 and then Appears_In (Body_Inputs, Constit_Id)
26516 Error_Msg_Name_1 := Chars (State_Id);
26518 ("constituent & of state % must act as output in "
26519 & "dependence refinement", N, Constit_Id);
26521 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26523 elsif No (Body_Outputs)
26524 or else not Appears_In (Body_Outputs, Constit_Id)
26529 ("output state & must be replaced by all its "
26530 & "constituents in dependence refinement",
26535 ("\constituent & is missing in output list",
26539 Next_Elmt (Constit_Elmt);
26542 end Check_Constituent_Usage;
26547 Item_Elmt : Elmt_Id;
26548 Item_Id : Entity_Id;
26550 -- Start of processing for Check_Output_States
26553 -- Do not perform this check in an instance because it was already
26554 -- performed successfully in the generic template.
26556 if Is_Generic_Instance (Spec_Id) then
26559 -- Inspect the outputs of pragma Depends looking for a state with a
26560 -- visible refinement.
26562 elsif Present (Spec_Outputs) then
26563 Item_Elmt := First_Elmt (Spec_Outputs);
26564 while Present (Item_Elmt) loop
26565 Item := Node (Item_Elmt);
26567 -- Deal with the mixed nature of the input and output lists
26569 if Nkind (Item) = N_Defining_Identifier then
26572 Item_Id := Available_View (Entity_Of (Item));
26575 if Ekind (Item_Id) = E_Abstract_State then
26577 -- The state acts as an input-output, skip it
26579 if Present (Spec_Inputs)
26580 and then Appears_In (Spec_Inputs, Item_Id)
26584 -- Ensure that all of the constituents are utilized as
26585 -- outputs in pragma Refined_Depends.
26587 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
26588 Check_Constituent_Usage (Item_Id);
26592 Next_Elmt (Item_Elmt);
26595 end Check_Output_States;
26597 --------------------
26598 -- Collect_States --
26599 --------------------
26601 function Collect_States (Clauses : List_Id) return Elist_Id is
26602 procedure Collect_State
26604 States : in out Elist_Id);
26605 -- Add the entity of Item to list States when it denotes to a state
26607 -------------------
26608 -- Collect_State --
26609 -------------------
26611 procedure Collect_State
26613 States : in out Elist_Id)
26618 if Is_Entity_Name (Item) then
26619 Id := Entity_Of (Item);
26621 if Ekind (Id) = E_Abstract_State then
26622 if No (States) then
26623 States := New_Elmt_List;
26626 Append_Unique_Elmt (Id, States);
26636 States : Elist_Id := No_Elist;
26638 -- Start of processing for Collect_States
26641 Clause := First (Clauses);
26642 while Present (Clause) loop
26643 Input := Expression (Clause);
26644 Output := First (Choices (Clause));
26646 Collect_State (Input, States);
26647 Collect_State (Output, States);
26653 end Collect_States;
26655 -----------------------
26656 -- Normalize_Clauses --
26657 -----------------------
26659 procedure Normalize_Clauses (Clauses : List_Id) is
26660 procedure Normalize_Inputs (Clause : Node_Id);
26661 -- Normalize clause Clause by creating multiple clauses for each
26662 -- input item of Clause. It is assumed that Clause has exactly one
26663 -- output. The transformation is as follows:
26665 -- Output => (Input_1, Input_2) -- original
26667 -- Output => Input_1 -- normalizations
26668 -- Output => Input_2
26670 procedure Normalize_Outputs (Clause : Node_Id);
26671 -- Normalize clause Clause by creating multiple clause for each
26672 -- output item of Clause. The transformation is as follows:
26674 -- (Output_1, Output_2) => Input -- original
26676 -- Output_1 => Input -- normalization
26677 -- Output_2 => Input
26679 ----------------------
26680 -- Normalize_Inputs --
26681 ----------------------
26683 procedure Normalize_Inputs (Clause : Node_Id) is
26684 Inputs : constant Node_Id := Expression (Clause);
26685 Loc : constant Source_Ptr := Sloc (Clause);
26686 Output : constant List_Id := Choices (Clause);
26687 Last_Input : Node_Id;
26689 New_Clause : Node_Id;
26690 Next_Input : Node_Id;
26693 -- Normalization is performed only when the original clause has
26694 -- more than one input. Multiple inputs appear as an aggregate.
26696 if Nkind (Inputs) = N_Aggregate then
26697 Last_Input := Last (Expressions (Inputs));
26699 -- Create a new clause for each input
26701 Input := First (Expressions (Inputs));
26702 while Present (Input) loop
26703 Next_Input := Next (Input);
26705 -- Unhook the current input from the original input list
26706 -- because it will be relocated to a new clause.
26710 -- Special processing for the last input. At this point the
26711 -- original aggregate has been stripped down to one element.
26712 -- Replace the aggregate by the element itself.
26714 if Input = Last_Input then
26715 Rewrite (Inputs, Input);
26717 -- Generate a clause of the form:
26722 Make_Component_Association (Loc,
26723 Choices => New_Copy_List_Tree (Output),
26724 Expression => Input);
26726 -- The new clause contains replicated content that has
26727 -- already been analyzed, mark the clause as analyzed.
26729 Set_Analyzed (New_Clause);
26730 Insert_After (Clause, New_Clause);
26733 Input := Next_Input;
26736 end Normalize_Inputs;
26738 -----------------------
26739 -- Normalize_Outputs --
26740 -----------------------
26742 procedure Normalize_Outputs (Clause : Node_Id) is
26743 Inputs : constant Node_Id := Expression (Clause);
26744 Loc : constant Source_Ptr := Sloc (Clause);
26745 Outputs : constant Node_Id := First (Choices (Clause));
26746 Last_Output : Node_Id;
26747 New_Clause : Node_Id;
26748 Next_Output : Node_Id;
26752 -- Multiple outputs appear as an aggregate. Nothing to do when
26753 -- the clause has exactly one output.
26755 if Nkind (Outputs) = N_Aggregate then
26756 Last_Output := Last (Expressions (Outputs));
26758 -- Create a clause for each output. Note that each time a new
26759 -- clause is created, the original output list slowly shrinks
26760 -- until there is one item left.
26762 Output := First (Expressions (Outputs));
26763 while Present (Output) loop
26764 Next_Output := Next (Output);
26766 -- Unhook the output from the original output list as it
26767 -- will be relocated to a new clause.
26771 -- Special processing for the last output. At this point
26772 -- the original aggregate has been stripped down to one
26773 -- element. Replace the aggregate by the element itself.
26775 if Output = Last_Output then
26776 Rewrite (Outputs, Output);
26779 -- Generate a clause of the form:
26780 -- (Output => Inputs)
26783 Make_Component_Association (Loc,
26784 Choices => New_List (Output),
26785 Expression => New_Copy_Tree (Inputs));
26787 -- The new clause contains replicated content that has
26788 -- already been analyzed. There is not need to reanalyze
26791 Set_Analyzed (New_Clause);
26792 Insert_After (Clause, New_Clause);
26795 Output := Next_Output;
26798 end Normalize_Outputs;
26804 -- Start of processing for Normalize_Clauses
26807 Clause := First (Clauses);
26808 while Present (Clause) loop
26809 Normalize_Outputs (Clause);
26813 Clause := First (Clauses);
26814 while Present (Clause) loop
26815 Normalize_Inputs (Clause);
26818 end Normalize_Clauses;
26820 --------------------------
26821 -- Remove_Extra_Clauses --
26822 --------------------------
26824 procedure Remove_Extra_Clauses
26825 (Clauses : List_Id;
26826 Matched_Items : Elist_Id)
26830 Input_Id : Entity_Id;
26831 Next_Clause : Node_Id;
26833 State_Id : Entity_Id;
26836 Clause := First (Clauses);
26837 while Present (Clause) loop
26838 Next_Clause := Next (Clause);
26840 Input := Expression (Clause);
26841 Output := First (Choices (Clause));
26843 -- Recognize a clause of the form
26847 -- where Input is a constituent of a state which was already
26848 -- successfully matched. This clause must be removed because it
26849 -- simply indicates that some of the constituents of the state
26852 -- Refined_State => (State => (Constit_1, Constit_2))
26853 -- Depends => (Output => State)
26854 -- Refined_Depends => ((Output => Constit_1), -- State matched
26855 -- (null => Constit_2)) -- OK
26857 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
26859 -- Handle abstract views generated for limited with clauses
26861 Input_Id := Available_View (Entity_Of (Input));
26863 -- The input must be a constituent of a state
26865 if Ekind_In (Input_Id, E_Abstract_State,
26868 and then Present (Encapsulating_State (Input_Id))
26870 State_Id := Encapsulating_State (Input_Id);
26872 -- The state must have a non-null visible refinement and be
26873 -- matched in a previous clause.
26875 if Has_Non_Null_Visible_Refinement (State_Id)
26876 and then Contains (Matched_Items, State_Id)
26882 -- Recognize a clause of the form
26886 -- where Output is an arbitrary item. This clause must be removed
26887 -- because a null input legitimately matches anything.
26889 elsif Nkind (Input) = N_Null then
26893 Clause := Next_Clause;
26895 end Remove_Extra_Clauses;
26897 --------------------------
26898 -- Report_Extra_Clauses --
26899 --------------------------
26901 procedure Report_Extra_Clauses
26902 (Spec_Id : Entity_Id;
26908 -- Do not perform this check in an instance because it was already
26909 -- performed successfully in the generic template.
26911 if Is_Generic_Instance (Spec_Id) then
26914 elsif Present (Clauses) then
26915 Clause := First (Clauses);
26916 while Present (Clause) loop
26918 ("unmatched or extra clause in dependence refinement",
26924 end Report_Extra_Clauses;
26928 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26929 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
26930 Errors : constant Nat := Serious_Errors_Detected;
26937 Body_Inputs : Elist_Id := No_Elist;
26938 Body_Outputs : Elist_Id := No_Elist;
26939 -- The inputs and outputs of the subprogram body synthesized from pragma
26940 -- Refined_Depends.
26942 Dependencies : List_Id := No_List;
26944 -- The corresponding Depends pragma along with its clauses
26946 Matched_Items : Elist_Id := No_Elist;
26947 -- A list containing the entities of all successfully matched items
26948 -- found in pragma Depends.
26950 Refinements : List_Id := No_List;
26951 -- The clauses of pragma Refined_Depends
26953 Spec_Id : Entity_Id;
26954 -- The entity of the subprogram subject to pragma Refined_Depends
26956 Spec_Inputs : Elist_Id := No_Elist;
26957 Spec_Outputs : Elist_Id := No_Elist;
26958 -- The inputs and outputs of the subprogram spec synthesized from pragma
26961 States : Elist_Id := No_Elist;
26962 -- A list containing the entities of all states whose constituents
26963 -- appear in pragma Depends.
26965 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26968 -- Do not analyze the pragma multiple times
26970 if Is_Analyzed_Pragma (N) then
26974 Spec_Id := Unique_Defining_Entity (Body_Decl);
26976 -- Use the anonymous object as the proper spec when Refined_Depends
26977 -- applies to the body of a single task type. The object carries the
26978 -- proper Chars as well as all non-refined versions of pragmas.
26980 if Is_Single_Concurrent_Type (Spec_Id) then
26981 Spec_Id := Anonymous_Object (Spec_Id);
26984 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
26986 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26987 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26989 if No (Depends) then
26991 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
26992 & "& lacks aspect or pragma Depends"), N, Spec_Id);
26996 Deps := Expression (Get_Argument (Depends, Spec_Id));
26998 -- A null dependency relation renders the refinement useless because it
26999 -- cannot possibly mention abstract states with visible refinement. Note
27000 -- that the inverse is not true as states may be refined to null
27001 -- (SPARK RM 7.2.5(2)).
27003 if Nkind (Deps) = N_Null then
27005 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
27006 & "depend on abstract state with visible refinement"), N, Spec_Id);
27010 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
27011 -- This ensures that the categorization of all refined dependency items
27012 -- is consistent with their role.
27014 Analyze_Depends_In_Decl_Part (N);
27016 -- Do not match dependencies against refinements if Refined_Depends is
27017 -- illegal to avoid emitting misleading error.
27019 if Serious_Errors_Detected = Errors then
27021 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
27022 -- the inputs and outputs of the subprogram spec and body to verify
27023 -- the use of states with visible refinement and their constituents.
27025 if No (Get_Pragma (Spec_Id, Pragma_Global))
27026 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
27028 Collect_Subprogram_Inputs_Outputs
27029 (Subp_Id => Spec_Id,
27030 Synthesize => True,
27031 Subp_Inputs => Spec_Inputs,
27032 Subp_Outputs => Spec_Outputs,
27033 Global_Seen => Dummy);
27035 Collect_Subprogram_Inputs_Outputs
27036 (Subp_Id => Body_Id,
27037 Synthesize => True,
27038 Subp_Inputs => Body_Inputs,
27039 Subp_Outputs => Body_Outputs,
27040 Global_Seen => Dummy);
27042 -- For an output state with a visible refinement, ensure that all
27043 -- constituents appear as outputs in the dependency refinement.
27045 Check_Output_States
27046 (Spec_Id => Spec_Id,
27047 Spec_Inputs => Spec_Inputs,
27048 Spec_Outputs => Spec_Outputs,
27049 Body_Inputs => Body_Inputs,
27050 Body_Outputs => Body_Outputs);
27053 -- Matching is disabled in ASIS because clauses are not normalized as
27054 -- this is a tree altering activity similar to expansion.
27060 -- Multiple dependency clauses appear as component associations of an
27061 -- aggregate. Note that the clauses are copied because the algorithm
27062 -- modifies them and this should not be visible in Depends.
27064 pragma Assert (Nkind (Deps) = N_Aggregate);
27065 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
27066 Normalize_Clauses (Dependencies);
27068 -- Gather all states which appear in Depends
27070 States := Collect_States (Dependencies);
27072 Refs := Expression (Get_Argument (N, Spec_Id));
27074 if Nkind (Refs) = N_Null then
27075 Refinements := No_List;
27077 -- Multiple dependency clauses appear as component associations of an
27078 -- aggregate. Note that the clauses are copied because the algorithm
27079 -- modifies them and this should not be visible in Refined_Depends.
27081 else pragma Assert (Nkind (Refs) = N_Aggregate);
27082 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
27083 Normalize_Clauses (Refinements);
27086 -- At this point the clauses of pragmas Depends and Refined_Depends
27087 -- have been normalized into simple dependencies between one output
27088 -- and one input. Examine all clauses of pragma Depends looking for
27089 -- matching clauses in pragma Refined_Depends.
27091 Clause := First (Dependencies);
27092 while Present (Clause) loop
27093 Check_Dependency_Clause
27094 (Spec_Id => Spec_Id,
27095 Dep_Clause => Clause,
27096 Dep_States => States,
27097 Refinements => Refinements,
27098 Matched_Items => Matched_Items);
27103 -- Pragma Refined_Depends may contain multiple clarification clauses
27104 -- which indicate that certain constituents do not influence the data
27105 -- flow in any way. Such clauses must be removed as long as the state
27106 -- has been matched, otherwise they will be incorrectly flagged as
27109 -- Refined_State => (State => (Constit_1, Constit_2))
27110 -- Depends => (Output => State)
27111 -- Refined_Depends => ((Output => Constit_1), -- State matched
27112 -- (null => Constit_2)) -- must be removed
27114 Remove_Extra_Clauses (Refinements, Matched_Items);
27116 if Serious_Errors_Detected = Errors then
27117 Report_Extra_Clauses (Spec_Id, Refinements);
27122 Set_Is_Analyzed_Pragma (N);
27123 end Analyze_Refined_Depends_In_Decl_Part;
27125 -----------------------------------------
27126 -- Analyze_Refined_Global_In_Decl_Part --
27127 -----------------------------------------
27129 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
27131 -- The corresponding Global pragma
27133 Has_In_State : Boolean := False;
27134 Has_In_Out_State : Boolean := False;
27135 Has_Out_State : Boolean := False;
27136 Has_Proof_In_State : Boolean := False;
27137 -- These flags are set when the corresponding Global pragma has a state
27138 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27141 Has_Null_State : Boolean := False;
27142 -- This flag is set when the corresponding Global pragma has at least
27143 -- one state with a null refinement.
27145 In_Constits : Elist_Id := No_Elist;
27146 In_Out_Constits : Elist_Id := No_Elist;
27147 Out_Constits : Elist_Id := No_Elist;
27148 Proof_In_Constits : Elist_Id := No_Elist;
27149 -- These lists contain the entities of all Input, In_Out, Output and
27150 -- Proof_In constituents that appear in Refined_Global and participate
27151 -- in state refinement.
27153 In_Items : Elist_Id := No_Elist;
27154 In_Out_Items : Elist_Id := No_Elist;
27155 Out_Items : Elist_Id := No_Elist;
27156 Proof_In_Items : Elist_Id := No_Elist;
27157 -- These lists contain the entities of all Input, In_Out, Output and
27158 -- Proof_In items defined in the corresponding Global pragma.
27160 Repeat_Items : Elist_Id := No_Elist;
27161 -- A list of all global items without full visible refinement found
27162 -- in pragma Global. These states should be repeated in the global
27163 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27164 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27166 Spec_Id : Entity_Id;
27167 -- The entity of the subprogram subject to pragma Refined_Global
27169 States : Elist_Id := No_Elist;
27170 -- A list of all states with full or partial visible refinement found in
27173 procedure Check_In_Out_States;
27174 -- Determine whether the corresponding Global pragma mentions In_Out
27175 -- states with visible refinement and if so, ensure that one of the
27176 -- following completions apply to the constituents of the state:
27177 -- 1) there is at least one constituent of mode In_Out
27178 -- 2) there is at least one Input and one Output constituent
27179 -- 3) not all constituents are present and one of them is of mode
27181 -- This routine may remove elements from In_Constits, In_Out_Constits,
27182 -- Out_Constits and Proof_In_Constits.
27184 procedure Check_Input_States;
27185 -- Determine whether the corresponding Global pragma mentions Input
27186 -- states with visible refinement and if so, ensure that at least one of
27187 -- its constituents appears as an Input item in Refined_Global.
27188 -- This routine may remove elements from In_Constits, In_Out_Constits,
27189 -- Out_Constits and Proof_In_Constits.
27191 procedure Check_Output_States;
27192 -- Determine whether the corresponding Global pragma mentions Output
27193 -- states with visible refinement and if so, ensure that all of its
27194 -- constituents appear as Output items in Refined_Global.
27195 -- This routine may remove elements from In_Constits, In_Out_Constits,
27196 -- Out_Constits and Proof_In_Constits.
27198 procedure Check_Proof_In_States;
27199 -- Determine whether the corresponding Global pragma mentions Proof_In
27200 -- states with visible refinement and if so, ensure that at least one of
27201 -- its constituents appears as a Proof_In item in Refined_Global.
27202 -- This routine may remove elements from In_Constits, In_Out_Constits,
27203 -- Out_Constits and Proof_In_Constits.
27205 procedure Check_Refined_Global_List
27207 Global_Mode : Name_Id := Name_Input);
27208 -- Verify the legality of a single global list declaration. Global_Mode
27209 -- denotes the current mode in effect.
27211 procedure Collect_Global_Items
27213 Mode : Name_Id := Name_Input);
27214 -- Gather all Input, In_Out, Output and Proof_In items from node List
27215 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27216 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27217 -- and Has_Proof_In_State are set when there is at least one abstract
27218 -- state with full or partial visible refinement available in the
27219 -- corresponding mode. Flag Has_Null_State is set when at least state
27220 -- has a null refinement. Mode denotes the current global mode in
27223 function Present_Then_Remove
27225 Item : Entity_Id) return Boolean;
27226 -- Search List for a particular entity Item. If Item has been found,
27227 -- remove it from List. This routine is used to strip lists In_Constits,
27228 -- In_Out_Constits and Out_Constits of valid constituents.
27230 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
27231 -- Same as function Present_Then_Remove, but do not report the presence
27232 -- of Item in List.
27234 procedure Report_Extra_Constituents;
27235 -- Emit an error for each constituent found in lists In_Constits,
27236 -- In_Out_Constits and Out_Constits.
27238 procedure Report_Missing_Items;
27239 -- Emit an error for each global item not repeated found in list
27242 -------------------------
27243 -- Check_In_Out_States --
27244 -------------------------
27246 procedure Check_In_Out_States is
27247 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27248 -- Determine whether one of the following coverage scenarios is in
27250 -- 1) there is at least one constituent of mode In_Out or Output
27251 -- 2) there is at least one pair of constituents with modes Input
27252 -- and Output, or Proof_In and Output.
27253 -- 3) there is at least one constituent of mode Output and not all
27254 -- constituents are present.
27255 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27257 -----------------------------
27258 -- Check_Constituent_Usage --
27259 -----------------------------
27261 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27262 Constits : constant Elist_Id :=
27263 Partial_Refinement_Constituents (State_Id);
27264 Constit_Elmt : Elmt_Id;
27265 Constit_Id : Entity_Id;
27266 Has_Missing : Boolean := False;
27267 In_Out_Seen : Boolean := False;
27268 Input_Seen : Boolean := False;
27269 Output_Seen : Boolean := False;
27270 Proof_In_Seen : Boolean := False;
27273 -- Process all the constituents of the state and note their modes
27274 -- within the global refinement.
27276 if Present (Constits) then
27277 Constit_Elmt := First_Elmt (Constits);
27278 while Present (Constit_Elmt) loop
27279 Constit_Id := Node (Constit_Elmt);
27281 if Present_Then_Remove (In_Constits, Constit_Id) then
27282 Input_Seen := True;
27284 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
27285 In_Out_Seen := True;
27287 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27288 Output_Seen := True;
27290 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27292 Proof_In_Seen := True;
27295 Has_Missing := True;
27298 Next_Elmt (Constit_Elmt);
27302 -- An In_Out constituent is a valid completion
27304 if In_Out_Seen then
27307 -- A pair of one Input/Proof_In and one Output constituent is a
27308 -- valid completion.
27310 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
27313 elsif Output_Seen then
27315 -- A single Output constituent is a valid completion only when
27316 -- some of the other constituents are missing.
27318 if Has_Missing then
27321 -- Otherwise all constituents are of mode Output
27325 ("global refinement of state & must include at least one "
27326 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27330 -- The state lacks a completion. When full refinement is visible,
27331 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27332 -- refinement is visible, emit an error if the abstract state
27333 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27334 -- both are utilized, Check_State_And_Constituent_Use. will issue
27337 elsif not Input_Seen
27338 and then not In_Out_Seen
27339 and then not Output_Seen
27340 and then not Proof_In_Seen
27342 if Has_Visible_Refinement (State_Id)
27343 or else Contains (Repeat_Items, State_Id)
27346 ("missing global refinement of state &", N, State_Id);
27349 -- Otherwise the state has a malformed completion where at least
27350 -- one of the constituents has a different mode.
27354 ("global refinement of state & redefines the mode of its "
27355 & "constituents", N, State_Id);
27357 end Check_Constituent_Usage;
27361 Item_Elmt : Elmt_Id;
27362 Item_Id : Entity_Id;
27364 -- Start of processing for Check_In_Out_States
27367 -- Do not perform this check in an instance because it was already
27368 -- performed successfully in the generic template.
27370 if Is_Generic_Instance (Spec_Id) then
27373 -- Inspect the In_Out items of the corresponding Global pragma
27374 -- looking for a state with a visible refinement.
27376 elsif Has_In_Out_State and then Present (In_Out_Items) then
27377 Item_Elmt := First_Elmt (In_Out_Items);
27378 while Present (Item_Elmt) loop
27379 Item_Id := Node (Item_Elmt);
27381 -- Ensure that one of the three coverage variants is satisfied
27383 if Ekind (Item_Id) = E_Abstract_State
27384 and then Has_Non_Null_Visible_Refinement (Item_Id)
27386 Check_Constituent_Usage (Item_Id);
27389 Next_Elmt (Item_Elmt);
27392 end Check_In_Out_States;
27394 ------------------------
27395 -- Check_Input_States --
27396 ------------------------
27398 procedure Check_Input_States is
27399 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27400 -- Determine whether at least one constituent of state State_Id with
27401 -- full or partial visible refinement is used and has mode Input.
27402 -- Ensure that the remaining constituents do not have In_Out or
27403 -- Output modes. Emit an error if this is not the case
27404 -- (SPARK RM 7.2.4(5)).
27406 -----------------------------
27407 -- Check_Constituent_Usage --
27408 -----------------------------
27410 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27411 Constits : constant Elist_Id :=
27412 Partial_Refinement_Constituents (State_Id);
27413 Constit_Elmt : Elmt_Id;
27414 Constit_Id : Entity_Id;
27415 In_Seen : Boolean := False;
27418 if Present (Constits) then
27419 Constit_Elmt := First_Elmt (Constits);
27420 while Present (Constit_Elmt) loop
27421 Constit_Id := Node (Constit_Elmt);
27423 -- At least one of the constituents appears as an Input
27425 if Present_Then_Remove (In_Constits, Constit_Id) then
27428 -- A Proof_In constituent can refine an Input state as long
27429 -- as there is at least one Input constituent present.
27431 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
27435 -- The constituent appears in the global refinement, but has
27436 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27438 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
27439 or else Present_Then_Remove (Out_Constits, Constit_Id)
27441 Error_Msg_Name_1 := Chars (State_Id);
27443 ("constituent & of state % must have mode `Input` in "
27444 & "global refinement", N, Constit_Id);
27447 Next_Elmt (Constit_Elmt);
27451 -- Not one of the constituents appeared as Input. Always emit an
27452 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27453 -- When only partial refinement is visible, emit an error if the
27454 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27455 -- the case where both are utilized, an error will be issued in
27456 -- Check_State_And_Constituent_Use.
27459 and then (Has_Visible_Refinement (State_Id)
27460 or else Contains (Repeat_Items, State_Id))
27463 ("global refinement of state & must include at least one "
27464 & "constituent of mode `Input`", N, State_Id);
27466 end Check_Constituent_Usage;
27470 Item_Elmt : Elmt_Id;
27471 Item_Id : Entity_Id;
27473 -- Start of processing for Check_Input_States
27476 -- Do not perform this check in an instance because it was already
27477 -- performed successfully in the generic template.
27479 if Is_Generic_Instance (Spec_Id) then
27482 -- Inspect the Input items of the corresponding Global pragma looking
27483 -- for a state with a visible refinement.
27485 elsif Has_In_State and then Present (In_Items) then
27486 Item_Elmt := First_Elmt (In_Items);
27487 while Present (Item_Elmt) loop
27488 Item_Id := Node (Item_Elmt);
27490 -- When full refinement is visible, ensure that at least one of
27491 -- the constituents is utilized and is of mode Input. When only
27492 -- partial refinement is visible, ensure that either one of
27493 -- the constituents is utilized and is of mode Input, or the
27494 -- abstract state is repeated and no constituent is utilized.
27496 if Ekind (Item_Id) = E_Abstract_State
27497 and then Has_Non_Null_Visible_Refinement (Item_Id)
27499 Check_Constituent_Usage (Item_Id);
27502 Next_Elmt (Item_Elmt);
27505 end Check_Input_States;
27507 -------------------------
27508 -- Check_Output_States --
27509 -------------------------
27511 procedure Check_Output_States is
27512 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27513 -- Determine whether all constituents of state State_Id with full
27514 -- visible refinement are used and have mode Output. Emit an error
27515 -- if this is not the case (SPARK RM 7.2.4(5)).
27517 -----------------------------
27518 -- Check_Constituent_Usage --
27519 -----------------------------
27521 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27522 Constits : constant Elist_Id :=
27523 Partial_Refinement_Constituents (State_Id);
27524 Only_Partial : constant Boolean :=
27525 not Has_Visible_Refinement (State_Id);
27526 Constit_Elmt : Elmt_Id;
27527 Constit_Id : Entity_Id;
27528 Posted : Boolean := False;
27531 if Present (Constits) then
27532 Constit_Elmt := First_Elmt (Constits);
27533 while Present (Constit_Elmt) loop
27534 Constit_Id := Node (Constit_Elmt);
27536 -- Issue an error when a constituent of State_Id is utilized
27537 -- and State_Id has only partial visible refinement
27538 -- (SPARK RM 7.2.4(3d)).
27540 if Only_Partial then
27541 if Present_Then_Remove (Out_Constits, Constit_Id)
27542 or else Present_Then_Remove (In_Constits, Constit_Id)
27544 Present_Then_Remove (In_Out_Constits, Constit_Id)
27546 Present_Then_Remove (Proof_In_Constits, Constit_Id)
27548 Error_Msg_Name_1 := Chars (State_Id);
27550 ("constituent & of state % cannot be used in global "
27551 & "refinement", N, Constit_Id);
27552 Error_Msg_Name_1 := Chars (State_Id);
27553 SPARK_Msg_N ("\use state % instead", N);
27556 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
27559 -- The constituent appears in the global refinement, but has
27560 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27562 elsif Present_Then_Remove (In_Constits, Constit_Id)
27563 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27564 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
27566 Error_Msg_Name_1 := Chars (State_Id);
27568 ("constituent & of state % must have mode `Output` in "
27569 & "global refinement", N, Constit_Id);
27571 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27577 ("`Output` state & must be replaced by all its "
27578 & "constituents in global refinement", N, State_Id);
27582 ("\constituent & is missing in output list",
27586 Next_Elmt (Constit_Elmt);
27589 end Check_Constituent_Usage;
27593 Item_Elmt : Elmt_Id;
27594 Item_Id : Entity_Id;
27596 -- Start of processing for Check_Output_States
27599 -- Do not perform this check in an instance because it was already
27600 -- performed successfully in the generic template.
27602 if Is_Generic_Instance (Spec_Id) then
27605 -- Inspect the Output items of the corresponding Global pragma
27606 -- looking for a state with a visible refinement.
27608 elsif Has_Out_State and then Present (Out_Items) then
27609 Item_Elmt := First_Elmt (Out_Items);
27610 while Present (Item_Elmt) loop
27611 Item_Id := Node (Item_Elmt);
27613 -- When full refinement is visible, ensure that all of the
27614 -- constituents are utilized and they have mode Output. When
27615 -- only partial refinement is visible, ensure that no
27616 -- constituent is utilized.
27618 if Ekind (Item_Id) = E_Abstract_State
27619 and then Has_Non_Null_Visible_Refinement (Item_Id)
27621 Check_Constituent_Usage (Item_Id);
27624 Next_Elmt (Item_Elmt);
27627 end Check_Output_States;
27629 ---------------------------
27630 -- Check_Proof_In_States --
27631 ---------------------------
27633 procedure Check_Proof_In_States is
27634 procedure Check_Constituent_Usage (State_Id : Entity_Id);
27635 -- Determine whether at least one constituent of state State_Id with
27636 -- full or partial visible refinement is used and has mode Proof_In.
27637 -- Ensure that the remaining constituents do not have Input, In_Out,
27638 -- or Output modes. Emit an error if this is not the case
27639 -- (SPARK RM 7.2.4(5)).
27641 -----------------------------
27642 -- Check_Constituent_Usage --
27643 -----------------------------
27645 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
27646 Constits : constant Elist_Id :=
27647 Partial_Refinement_Constituents (State_Id);
27648 Constit_Elmt : Elmt_Id;
27649 Constit_Id : Entity_Id;
27650 Proof_In_Seen : Boolean := False;
27653 if Present (Constits) then
27654 Constit_Elmt := First_Elmt (Constits);
27655 while Present (Constit_Elmt) loop
27656 Constit_Id := Node (Constit_Elmt);
27658 -- At least one of the constituents appears as Proof_In
27660 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
27661 Proof_In_Seen := True;
27663 -- The constituent appears in the global refinement, but has
27664 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27666 elsif Present_Then_Remove (In_Constits, Constit_Id)
27667 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
27668 or else Present_Then_Remove (Out_Constits, Constit_Id)
27670 Error_Msg_Name_1 := Chars (State_Id);
27672 ("constituent & of state % must have mode `Proof_In` "
27673 & "in global refinement", N, Constit_Id);
27676 Next_Elmt (Constit_Elmt);
27680 -- Not one of the constituents appeared as Proof_In. Always emit
27681 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27682 -- When only partial refinement is visible, emit an error if the
27683 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27684 -- the case where both are utilized, an error will be issued by
27685 -- Check_State_And_Constituent_Use.
27687 if not Proof_In_Seen
27688 and then (Has_Visible_Refinement (State_Id)
27689 or else Contains (Repeat_Items, State_Id))
27692 ("global refinement of state & must include at least one "
27693 & "constituent of mode `Proof_In`", N, State_Id);
27695 end Check_Constituent_Usage;
27699 Item_Elmt : Elmt_Id;
27700 Item_Id : Entity_Id;
27702 -- Start of processing for Check_Proof_In_States
27705 -- Do not perform this check in an instance because it was already
27706 -- performed successfully in the generic template.
27708 if Is_Generic_Instance (Spec_Id) then
27711 -- Inspect the Proof_In items of the corresponding Global pragma
27712 -- looking for a state with a visible refinement.
27714 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
27715 Item_Elmt := First_Elmt (Proof_In_Items);
27716 while Present (Item_Elmt) loop
27717 Item_Id := Node (Item_Elmt);
27719 -- Ensure that at least one of the constituents is utilized
27720 -- and is of mode Proof_In. When only partial refinement is
27721 -- visible, ensure that either one of the constituents is
27722 -- utilized and is of mode Proof_In, or the abstract state
27723 -- is repeated and no constituent is utilized.
27725 if Ekind (Item_Id) = E_Abstract_State
27726 and then Has_Non_Null_Visible_Refinement (Item_Id)
27728 Check_Constituent_Usage (Item_Id);
27731 Next_Elmt (Item_Elmt);
27734 end Check_Proof_In_States;
27736 -------------------------------
27737 -- Check_Refined_Global_List --
27738 -------------------------------
27740 procedure Check_Refined_Global_List
27742 Global_Mode : Name_Id := Name_Input)
27744 procedure Check_Refined_Global_Item
27746 Global_Mode : Name_Id);
27747 -- Verify the legality of a single global item declaration. Parameter
27748 -- Global_Mode denotes the current mode in effect.
27750 -------------------------------
27751 -- Check_Refined_Global_Item --
27752 -------------------------------
27754 procedure Check_Refined_Global_Item
27756 Global_Mode : Name_Id)
27758 Item_Id : constant Entity_Id := Entity_Of (Item);
27760 procedure Inconsistent_Mode_Error (Expect : Name_Id);
27761 -- Issue a common error message for all mode mismatches. Expect
27762 -- denotes the expected mode.
27764 -----------------------------
27765 -- Inconsistent_Mode_Error --
27766 -----------------------------
27768 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
27771 ("global item & has inconsistent modes", Item, Item_Id);
27773 Error_Msg_Name_1 := Global_Mode;
27774 Error_Msg_Name_2 := Expect;
27775 SPARK_Msg_N ("\expected mode %, found mode %", Item);
27776 end Inconsistent_Mode_Error;
27780 Enc_State : Entity_Id := Empty;
27781 -- Encapsulating state for constituent, Empty otherwise
27783 -- Start of processing for Check_Refined_Global_Item
27786 if Ekind_In (Item_Id, E_Abstract_State,
27790 Enc_State := Find_Encapsulating_State (States, Item_Id);
27793 -- When the state or object acts as a constituent of another
27794 -- state with a visible refinement, collect it for the state
27795 -- completeness checks performed later on. Note that the item
27796 -- acts as a constituent only when the encapsulating state is
27797 -- present in pragma Global.
27799 if Present (Enc_State)
27800 and then (Has_Visible_Refinement (Enc_State)
27801 or else Has_Partial_Visible_Refinement (Enc_State))
27802 and then Contains (States, Enc_State)
27804 -- If the state has only partial visible refinement, remove it
27805 -- from the list of items that should be repeated from pragma
27808 if not Has_Visible_Refinement (Enc_State) then
27809 Present_Then_Remove (Repeat_Items, Enc_State);
27812 if Global_Mode = Name_Input then
27813 Append_New_Elmt (Item_Id, In_Constits);
27815 elsif Global_Mode = Name_In_Out then
27816 Append_New_Elmt (Item_Id, In_Out_Constits);
27818 elsif Global_Mode = Name_Output then
27819 Append_New_Elmt (Item_Id, Out_Constits);
27821 elsif Global_Mode = Name_Proof_In then
27822 Append_New_Elmt (Item_Id, Proof_In_Constits);
27825 -- When not a constituent, ensure that both occurrences of the
27826 -- item in pragmas Global and Refined_Global match. Also remove
27827 -- it when present from the list of items that should be repeated
27828 -- from pragma Global.
27831 Present_Then_Remove (Repeat_Items, Item_Id);
27833 if Contains (In_Items, Item_Id) then
27834 if Global_Mode /= Name_Input then
27835 Inconsistent_Mode_Error (Name_Input);
27838 elsif Contains (In_Out_Items, Item_Id) then
27839 if Global_Mode /= Name_In_Out then
27840 Inconsistent_Mode_Error (Name_In_Out);
27843 elsif Contains (Out_Items, Item_Id) then
27844 if Global_Mode /= Name_Output then
27845 Inconsistent_Mode_Error (Name_Output);
27848 elsif Contains (Proof_In_Items, Item_Id) then
27851 -- The item does not appear in the corresponding Global pragma,
27852 -- it must be an extra (SPARK RM 7.2.4(3)).
27855 pragma Assert (Present (Global));
27856 Error_Msg_Sloc := Sloc (Global);
27858 ("extra global item & does not refine or repeat any "
27859 & "global item #", Item, Item_Id);
27862 end Check_Refined_Global_Item;
27868 -- Start of processing for Check_Refined_Global_List
27871 -- Do not perform this check in an instance because it was already
27872 -- performed successfully in the generic template.
27874 if Is_Generic_Instance (Spec_Id) then
27877 elsif Nkind (List) = N_Null then
27880 -- Single global item declaration
27882 elsif Nkind_In (List, N_Expanded_Name,
27884 N_Selected_Component)
27886 Check_Refined_Global_Item (List, Global_Mode);
27888 -- Simple global list or moded global list declaration
27890 elsif Nkind (List) = N_Aggregate then
27892 -- The declaration of a simple global list appear as a collection
27895 if Present (Expressions (List)) then
27896 Item := First (Expressions (List));
27897 while Present (Item) loop
27898 Check_Refined_Global_Item (Item, Global_Mode);
27902 -- The declaration of a moded global list appears as a collection
27903 -- of component associations where individual choices denote
27906 elsif Present (Component_Associations (List)) then
27907 Item := First (Component_Associations (List));
27908 while Present (Item) loop
27909 Check_Refined_Global_List
27910 (List => Expression (Item),
27911 Global_Mode => Chars (First (Choices (Item))));
27919 raise Program_Error;
27925 raise Program_Error;
27927 end Check_Refined_Global_List;
27929 --------------------------
27930 -- Collect_Global_Items --
27931 --------------------------
27933 procedure Collect_Global_Items
27935 Mode : Name_Id := Name_Input)
27937 procedure Collect_Global_Item
27939 Item_Mode : Name_Id);
27940 -- Add a single item to the appropriate list. Item_Mode denotes the
27941 -- current mode in effect.
27943 -------------------------
27944 -- Collect_Global_Item --
27945 -------------------------
27947 procedure Collect_Global_Item
27949 Item_Mode : Name_Id)
27951 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
27952 -- The above handles abstract views of variables and states built
27953 -- for limited with clauses.
27956 -- Signal that the global list contains at least one abstract
27957 -- state with a visible refinement. Note that the refinement may
27958 -- be null in which case there are no constituents.
27960 if Ekind (Item_Id) = E_Abstract_State then
27961 if Has_Null_Visible_Refinement (Item_Id) then
27962 Has_Null_State := True;
27964 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
27965 Append_New_Elmt (Item_Id, States);
27967 if Item_Mode = Name_Input then
27968 Has_In_State := True;
27969 elsif Item_Mode = Name_In_Out then
27970 Has_In_Out_State := True;
27971 elsif Item_Mode = Name_Output then
27972 Has_Out_State := True;
27973 elsif Item_Mode = Name_Proof_In then
27974 Has_Proof_In_State := True;
27979 -- Record global items without full visible refinement found in
27980 -- pragma Global which should be repeated in the global refinement
27981 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27983 if Ekind (Item_Id) /= E_Abstract_State
27984 or else not Has_Visible_Refinement (Item_Id)
27986 Append_New_Elmt (Item_Id, Repeat_Items);
27989 -- Add the item to the proper list
27991 if Item_Mode = Name_Input then
27992 Append_New_Elmt (Item_Id, In_Items);
27993 elsif Item_Mode = Name_In_Out then
27994 Append_New_Elmt (Item_Id, In_Out_Items);
27995 elsif Item_Mode = Name_Output then
27996 Append_New_Elmt (Item_Id, Out_Items);
27997 elsif Item_Mode = Name_Proof_In then
27998 Append_New_Elmt (Item_Id, Proof_In_Items);
28000 end Collect_Global_Item;
28006 -- Start of processing for Collect_Global_Items
28009 if Nkind (List) = N_Null then
28012 -- Single global item declaration
28014 elsif Nkind_In (List, N_Expanded_Name,
28016 N_Selected_Component)
28018 Collect_Global_Item (List, Mode);
28020 -- Single global list or moded global list declaration
28022 elsif Nkind (List) = N_Aggregate then
28024 -- The declaration of a simple global list appear as a collection
28027 if Present (Expressions (List)) then
28028 Item := First (Expressions (List));
28029 while Present (Item) loop
28030 Collect_Global_Item (Item, Mode);
28034 -- The declaration of a moded global list appears as a collection
28035 -- of component associations where individual choices denote mode.
28037 elsif Present (Component_Associations (List)) then
28038 Item := First (Component_Associations (List));
28039 while Present (Item) loop
28040 Collect_Global_Items
28041 (List => Expression (Item),
28042 Mode => Chars (First (Choices (Item))));
28050 raise Program_Error;
28053 -- To accommodate partial decoration of disabled SPARK features, this
28054 -- routine may be called with illegal input. If this is the case, do
28055 -- not raise Program_Error.
28060 end Collect_Global_Items;
28062 -------------------------
28063 -- Present_Then_Remove --
28064 -------------------------
28066 function Present_Then_Remove
28068 Item : Entity_Id) return Boolean
28073 if Present (List) then
28074 Elmt := First_Elmt (List);
28075 while Present (Elmt) loop
28076 if Node (Elmt) = Item then
28077 Remove_Elmt (List, Elmt);
28086 end Present_Then_Remove;
28088 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
28091 Ignore := Present_Then_Remove (List, Item);
28092 end Present_Then_Remove;
28094 -------------------------------
28095 -- Report_Extra_Constituents --
28096 -------------------------------
28098 procedure Report_Extra_Constituents is
28099 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
28100 -- Emit an error for every element of List
28102 ---------------------------------------
28103 -- Report_Extra_Constituents_In_List --
28104 ---------------------------------------
28106 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
28107 Constit_Elmt : Elmt_Id;
28110 if Present (List) then
28111 Constit_Elmt := First_Elmt (List);
28112 while Present (Constit_Elmt) loop
28113 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
28114 Next_Elmt (Constit_Elmt);
28117 end Report_Extra_Constituents_In_List;
28119 -- Start of processing for Report_Extra_Constituents
28122 -- Do not perform this check in an instance because it was already
28123 -- performed successfully in the generic template.
28125 if Is_Generic_Instance (Spec_Id) then
28129 Report_Extra_Constituents_In_List (In_Constits);
28130 Report_Extra_Constituents_In_List (In_Out_Constits);
28131 Report_Extra_Constituents_In_List (Out_Constits);
28132 Report_Extra_Constituents_In_List (Proof_In_Constits);
28134 end Report_Extra_Constituents;
28136 --------------------------
28137 -- Report_Missing_Items --
28138 --------------------------
28140 procedure Report_Missing_Items is
28141 Item_Elmt : Elmt_Id;
28142 Item_Id : Entity_Id;
28145 -- Do not perform this check in an instance because it was already
28146 -- performed successfully in the generic template.
28148 if Is_Generic_Instance (Spec_Id) then
28152 if Present (Repeat_Items) then
28153 Item_Elmt := First_Elmt (Repeat_Items);
28154 while Present (Item_Elmt) loop
28155 Item_Id := Node (Item_Elmt);
28156 SPARK_Msg_NE ("missing global item &", N, Item_Id);
28157 Next_Elmt (Item_Elmt);
28161 end Report_Missing_Items;
28165 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
28166 Errors : constant Nat := Serious_Errors_Detected;
28168 No_Constit : Boolean;
28170 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28173 -- Do not analyze the pragma multiple times
28175 if Is_Analyzed_Pragma (N) then
28179 Spec_Id := Unique_Defining_Entity (Body_Decl);
28181 -- Use the anonymous object as the proper spec when Refined_Global
28182 -- applies to the body of a single task type. The object carries the
28183 -- proper Chars as well as all non-refined versions of pragmas.
28185 if Is_Single_Concurrent_Type (Spec_Id) then
28186 Spec_Id := Anonymous_Object (Spec_Id);
28189 Global := Get_Pragma (Spec_Id, Pragma_Global);
28190 Items := Expression (Get_Argument (N, Spec_Id));
28192 -- The subprogram declaration lacks pragma Global. This renders
28193 -- Refined_Global useless as there is nothing to refine.
28195 if No (Global) then
28197 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
28198 & "& lacks aspect or pragma Global"), N, Spec_Id);
28202 -- Extract all relevant items from the corresponding Global pragma
28204 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
28206 -- Package and subprogram bodies are instantiated individually in
28207 -- a separate compiler pass. Due to this mode of instantiation, the
28208 -- refinement of a state may no longer be visible when a subprogram
28209 -- body contract is instantiated. Since the generic template is legal,
28210 -- do not perform this check in the instance to circumvent this oddity.
28212 if Is_Generic_Instance (Spec_Id) then
28215 -- Non-instance case
28218 -- The corresponding Global pragma must mention at least one
28219 -- state with a visible refinement at the point Refined_Global
28220 -- is processed. States with null refinements need Refined_Global
28221 -- pragma (SPARK RM 7.2.4(2)).
28223 if not Has_In_State
28224 and then not Has_In_Out_State
28225 and then not Has_Out_State
28226 and then not Has_Proof_In_State
28227 and then not Has_Null_State
28230 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
28231 & "depend on abstract state with visible refinement"),
28235 -- The global refinement of inputs and outputs cannot be null when
28236 -- the corresponding Global pragma contains at least one item except
28237 -- in the case where we have states with null refinements.
28239 elsif Nkind (Items) = N_Null
28241 (Present (In_Items)
28242 or else Present (In_Out_Items)
28243 or else Present (Out_Items)
28244 or else Present (Proof_In_Items))
28245 and then not Has_Null_State
28248 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
28249 & "global items"), N, Spec_Id);
28254 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28255 -- This ensures that the categorization of all refined global items is
28256 -- consistent with their role.
28258 Analyze_Global_In_Decl_Part (N);
28260 -- Perform all refinement checks with respect to completeness and mode
28263 if Serious_Errors_Detected = Errors then
28264 Check_Refined_Global_List (Items);
28267 -- Store the information that no constituent is used in the global
28268 -- refinement, prior to calling checking procedures which remove items
28269 -- from the list of constituents.
28273 and then No (In_Out_Constits)
28274 and then No (Out_Constits)
28275 and then No (Proof_In_Constits);
28277 -- For Input states with visible refinement, at least one constituent
28278 -- must be used as an Input in the global refinement.
28280 if Serious_Errors_Detected = Errors then
28281 Check_Input_States;
28284 -- Verify all possible completion variants for In_Out states with
28285 -- visible refinement.
28287 if Serious_Errors_Detected = Errors then
28288 Check_In_Out_States;
28291 -- For Output states with visible refinement, all constituents must be
28292 -- used as Outputs in the global refinement.
28294 if Serious_Errors_Detected = Errors then
28295 Check_Output_States;
28298 -- For Proof_In states with visible refinement, at least one constituent
28299 -- must be used as Proof_In in the global refinement.
28301 if Serious_Errors_Detected = Errors then
28302 Check_Proof_In_States;
28305 -- Emit errors for all constituents that belong to other states with
28306 -- visible refinement that do not appear in Global.
28308 if Serious_Errors_Detected = Errors then
28309 Report_Extra_Constituents;
28312 -- Emit errors for all items in Global that are not repeated in the
28313 -- global refinement and for which there is no full visible refinement
28314 -- and, in the case of states with partial visible refinement, no
28315 -- constituent is mentioned in the global refinement.
28317 if Serious_Errors_Detected = Errors then
28318 Report_Missing_Items;
28321 -- Emit an error if no constituent is used in the global refinement
28322 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28323 -- one may be issued by the checking procedures. Do not perform this
28324 -- check in an instance because it was already performed successfully
28325 -- in the generic template.
28327 if Serious_Errors_Detected = Errors
28328 and then not Is_Generic_Instance (Spec_Id)
28329 and then not Has_Null_State
28330 and then No_Constit
28332 SPARK_Msg_N ("missing refinement", N);
28336 Set_Is_Analyzed_Pragma (N);
28337 end Analyze_Refined_Global_In_Decl_Part;
28339 ----------------------------------------
28340 -- Analyze_Refined_State_In_Decl_Part --
28341 ----------------------------------------
28343 procedure Analyze_Refined_State_In_Decl_Part
28345 Freeze_Id : Entity_Id := Empty)
28347 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
28348 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
28349 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
28351 Available_States : Elist_Id := No_Elist;
28352 -- A list of all abstract states defined in the package declaration that
28353 -- are available for refinement. The list is used to report unrefined
28356 Body_States : Elist_Id := No_Elist;
28357 -- A list of all hidden states that appear in the body of the related
28358 -- package. The list is used to report unused hidden states.
28360 Constituents_Seen : Elist_Id := No_Elist;
28361 -- A list that contains all constituents processed so far. The list is
28362 -- used to detect multiple uses of the same constituent.
28364 Freeze_Posted : Boolean := False;
28365 -- A flag that controls the output of a freezing-related error (see use
28368 Refined_States_Seen : Elist_Id := No_Elist;
28369 -- A list that contains all refined states processed so far. The list is
28370 -- used to detect duplicate refinements.
28372 procedure Analyze_Refinement_Clause (Clause : Node_Id);
28373 -- Perform full analysis of a single refinement clause
28375 procedure Report_Unrefined_States (States : Elist_Id);
28376 -- Emit errors for all unrefined abstract states found in list States
28378 -------------------------------
28379 -- Analyze_Refinement_Clause --
28380 -------------------------------
28382 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
28383 AR_Constit : Entity_Id := Empty;
28384 AW_Constit : Entity_Id := Empty;
28385 ER_Constit : Entity_Id := Empty;
28386 EW_Constit : Entity_Id := Empty;
28387 -- The entities of external constituents that contain one of the
28388 -- following enabled properties: Async_Readers, Async_Writers,
28389 -- Effective_Reads and Effective_Writes.
28391 External_Constit_Seen : Boolean := False;
28392 -- Flag used to mark when at least one external constituent is part
28393 -- of the state refinement.
28395 Non_Null_Seen : Boolean := False;
28396 Null_Seen : Boolean := False;
28397 -- Flags used to detect multiple uses of null in a single clause or a
28398 -- mixture of null and non-null constituents.
28400 Part_Of_Constits : Elist_Id := No_Elist;
28401 -- A list of all candidate constituents subject to indicator Part_Of
28402 -- where the encapsulating state is the current state.
28405 State_Id : Entity_Id;
28406 -- The current state being refined
28408 procedure Analyze_Constituent (Constit : Node_Id);
28409 -- Perform full analysis of a single constituent
28411 procedure Check_External_Property
28412 (Prop_Nam : Name_Id;
28414 Constit : Entity_Id);
28415 -- Determine whether a property denoted by name Prop_Nam is present
28416 -- in the refined state. Emit an error if this is not the case. Flag
28417 -- Enabled should be set when the property applies to the refined
28418 -- state. Constit denotes the constituent (if any) which introduces
28419 -- the property in the refinement.
28421 procedure Match_State;
28422 -- Determine whether the state being refined appears in list
28423 -- Available_States. Emit an error when attempting to re-refine the
28424 -- state or when the state is not defined in the package declaration,
28425 -- otherwise remove the state from Available_States.
28427 procedure Report_Unused_Constituents (Constits : Elist_Id);
28428 -- Emit errors for all unused Part_Of constituents in list Constits
28430 -------------------------
28431 -- Analyze_Constituent --
28432 -------------------------
28434 procedure Analyze_Constituent (Constit : Node_Id) is
28435 procedure Match_Constituent (Constit_Id : Entity_Id);
28436 -- Determine whether constituent Constit denoted by its entity
28437 -- Constit_Id appears in Body_States. Emit an error when the
28438 -- constituent is not a valid hidden state of the related package
28439 -- or when it is used more than once. Otherwise remove the
28440 -- constituent from Body_States.
28442 -----------------------
28443 -- Match_Constituent --
28444 -----------------------
28446 procedure Match_Constituent (Constit_Id : Entity_Id) is
28447 procedure Collect_Constituent;
28448 -- Verify the legality of constituent Constit_Id and add it to
28449 -- the refinements of State_Id.
28451 -------------------------
28452 -- Collect_Constituent --
28453 -------------------------
28455 procedure Collect_Constituent is
28456 Constits : Elist_Id;
28459 -- The Ghost policy in effect at the point of abstract state
28460 -- declaration and constituent must match (SPARK RM 6.9(15))
28462 Check_Ghost_Refinement
28463 (State, State_Id, Constit, Constit_Id);
28465 -- A synchronized state must be refined by a synchronized
28466 -- object or another synchronized state (SPARK RM 9.6).
28468 if Is_Synchronized_State (State_Id)
28469 and then not Is_Synchronized_Object (Constit_Id)
28470 and then not Is_Synchronized_State (Constit_Id)
28473 ("constituent of synchronized state & must be "
28474 & "synchronized", Constit, State_Id);
28477 -- Add the constituent to the list of processed items to aid
28478 -- with the detection of duplicates.
28480 Append_New_Elmt (Constit_Id, Constituents_Seen);
28482 -- Collect the constituent in the list of refinement items
28483 -- and establish a relation between the refined state and
28486 Constits := Refinement_Constituents (State_Id);
28488 if No (Constits) then
28489 Constits := New_Elmt_List;
28490 Set_Refinement_Constituents (State_Id, Constits);
28493 Append_Elmt (Constit_Id, Constits);
28494 Set_Encapsulating_State (Constit_Id, State_Id);
28496 -- The state has at least one legal constituent, mark the
28497 -- start of the refinement region. The region ends when the
28498 -- body declarations end (see routine Analyze_Declarations).
28500 Set_Has_Visible_Refinement (State_Id);
28502 -- When the constituent is external, save its relevant
28503 -- property for further checks.
28505 if Async_Readers_Enabled (Constit_Id) then
28506 AR_Constit := Constit_Id;
28507 External_Constit_Seen := True;
28510 if Async_Writers_Enabled (Constit_Id) then
28511 AW_Constit := Constit_Id;
28512 External_Constit_Seen := True;
28515 if Effective_Reads_Enabled (Constit_Id) then
28516 ER_Constit := Constit_Id;
28517 External_Constit_Seen := True;
28520 if Effective_Writes_Enabled (Constit_Id) then
28521 EW_Constit := Constit_Id;
28522 External_Constit_Seen := True;
28524 end Collect_Constituent;
28528 State_Elmt : Elmt_Id;
28530 -- Start of processing for Match_Constituent
28533 -- Detect a duplicate use of a constituent
28535 if Contains (Constituents_Seen, Constit_Id) then
28537 ("duplicate use of constituent &", Constit, Constit_Id);
28541 -- The constituent is subject to a Part_Of indicator
28543 if Present (Encapsulating_State (Constit_Id)) then
28544 if Encapsulating_State (Constit_Id) = State_Id then
28545 Remove (Part_Of_Constits, Constit_Id);
28546 Collect_Constituent;
28548 -- The constituent is part of another state and is used
28549 -- incorrectly in the refinement of the current state.
28552 Error_Msg_Name_1 := Chars (State_Id);
28554 ("& cannot act as constituent of state %",
28555 Constit, Constit_Id);
28557 ("\Part_Of indicator specifies encapsulator &",
28558 Constit, Encapsulating_State (Constit_Id));
28561 -- The only other source of legal constituents is the body
28562 -- state space of the related package.
28565 if Present (Body_States) then
28566 State_Elmt := First_Elmt (Body_States);
28567 while Present (State_Elmt) loop
28569 -- Consume a valid constituent to signal that it has
28570 -- been encountered.
28572 if Node (State_Elmt) = Constit_Id then
28573 Remove_Elmt (Body_States, State_Elmt);
28574 Collect_Constituent;
28578 Next_Elmt (State_Elmt);
28582 -- At this point it is known that the constituent is not
28583 -- part of the package hidden state and cannot be used in
28584 -- a refinement (SPARK RM 7.2.2(9)).
28586 Error_Msg_Name_1 := Chars (Spec_Id);
28588 ("cannot use & in refinement, constituent is not a hidden "
28589 & "state of package %", Constit, Constit_Id);
28591 end Match_Constituent;
28595 Constit_Id : Entity_Id;
28596 Constits : Elist_Id;
28598 -- Start of processing for Analyze_Constituent
28601 -- Detect multiple uses of null in a single refinement clause or a
28602 -- mixture of null and non-null constituents.
28604 if Nkind (Constit) = N_Null then
28607 ("multiple null constituents not allowed", Constit);
28609 elsif Non_Null_Seen then
28611 ("cannot mix null and non-null constituents", Constit);
28616 -- Collect the constituent in the list of refinement items
28618 Constits := Refinement_Constituents (State_Id);
28620 if No (Constits) then
28621 Constits := New_Elmt_List;
28622 Set_Refinement_Constituents (State_Id, Constits);
28625 Append_Elmt (Constit, Constits);
28627 -- The state has at least one legal constituent, mark the
28628 -- start of the refinement region. The region ends when the
28629 -- body declarations end (see Analyze_Declarations).
28631 Set_Has_Visible_Refinement (State_Id);
28634 -- Non-null constituents
28637 Non_Null_Seen := True;
28641 ("cannot mix null and non-null constituents", Constit);
28645 Resolve_State (Constit);
28647 -- Ensure that the constituent denotes a valid state or a
28648 -- whole object (SPARK RM 7.2.2(5)).
28650 if Is_Entity_Name (Constit) then
28651 Constit_Id := Entity_Of (Constit);
28653 -- When a constituent is declared after a subprogram body
28654 -- that caused freezing of the related contract where
28655 -- pragma Refined_State resides, the constituent appears
28656 -- undefined and carries Any_Id as its entity.
28658 -- package body Pack
28659 -- with Refined_State => (State => Constit)
28662 -- with Refined_Global => (Input => Constit)
28670 if Constit_Id = Any_Id then
28671 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
28673 -- Emit a specialized info message when the contract of
28674 -- the related package body was "frozen" by another body.
28675 -- Note that it is not possible to precisely identify why
28676 -- the constituent is undefined because it is not visible
28677 -- when pragma Refined_State is analyzed. This message is
28678 -- a reasonable approximation.
28680 if Present (Freeze_Id) and then not Freeze_Posted then
28681 Freeze_Posted := True;
28683 Error_Msg_Name_1 := Chars (Body_Id);
28684 Error_Msg_Sloc := Sloc (Freeze_Id);
28686 ("body & declared # freezes the contract of %",
28689 ("\all constituents must be declared before body #",
28692 -- A misplaced constituent is a critical error because
28693 -- pragma Refined_Depends or Refined_Global depends on
28694 -- the proper link between a state and a constituent.
28695 -- Stop the compilation, as this leads to a multitude
28696 -- of misleading cascaded errors.
28698 raise Unrecoverable_Error;
28701 -- The constituent is a valid state or object
28703 elsif Ekind_In (Constit_Id, E_Abstract_State,
28707 Match_Constituent (Constit_Id);
28709 -- The variable may eventually become a constituent of a
28710 -- single protected/task type. Record the reference now
28711 -- and verify its legality when analyzing the contract of
28712 -- the variable (SPARK RM 9.3).
28714 if Ekind (Constit_Id) = E_Variable then
28715 Record_Possible_Part_Of_Reference
28716 (Var_Id => Constit_Id,
28720 -- Otherwise the constituent is illegal
28724 ("constituent & must denote object or state",
28725 Constit, Constit_Id);
28728 -- The constituent is illegal
28731 SPARK_Msg_N ("malformed constituent", Constit);
28734 end Analyze_Constituent;
28736 -----------------------------
28737 -- Check_External_Property --
28738 -----------------------------
28740 procedure Check_External_Property
28741 (Prop_Nam : Name_Id;
28743 Constit : Entity_Id)
28746 -- The property is missing in the declaration of the state, but
28747 -- a constituent is introducing it in the state refinement
28748 -- (SPARK RM 7.2.8(2)).
28750 if not Enabled and then Present (Constit) then
28751 Error_Msg_Name_1 := Prop_Nam;
28752 Error_Msg_Name_2 := Chars (State_Id);
28754 ("constituent & introduces external property % in refinement "
28755 & "of state %", State, Constit);
28757 Error_Msg_Sloc := Sloc (State_Id);
28759 ("\property is missing in abstract state declaration #",
28762 end Check_External_Property;
28768 procedure Match_State is
28769 State_Elmt : Elmt_Id;
28772 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28774 if Contains (Refined_States_Seen, State_Id) then
28776 ("duplicate refinement of state &", State, State_Id);
28780 -- Inspect the abstract states defined in the package declaration
28781 -- looking for a match.
28783 State_Elmt := First_Elmt (Available_States);
28784 while Present (State_Elmt) loop
28786 -- A valid abstract state is being refined in the body. Add
28787 -- the state to the list of processed refined states to aid
28788 -- with the detection of duplicate refinements. Remove the
28789 -- state from Available_States to signal that it has already
28792 if Node (State_Elmt) = State_Id then
28793 Append_New_Elmt (State_Id, Refined_States_Seen);
28794 Remove_Elmt (Available_States, State_Elmt);
28798 Next_Elmt (State_Elmt);
28801 -- If we get here, we are refining a state that is not defined in
28802 -- the package declaration.
28804 Error_Msg_Name_1 := Chars (Spec_Id);
28806 ("cannot refine state, & is not defined in package %",
28810 --------------------------------
28811 -- Report_Unused_Constituents --
28812 --------------------------------
28814 procedure Report_Unused_Constituents (Constits : Elist_Id) is
28815 Constit_Elmt : Elmt_Id;
28816 Constit_Id : Entity_Id;
28817 Posted : Boolean := False;
28820 if Present (Constits) then
28821 Constit_Elmt := First_Elmt (Constits);
28822 while Present (Constit_Elmt) loop
28823 Constit_Id := Node (Constit_Elmt);
28825 -- Generate an error message of the form:
28827 -- state ... has unused Part_Of constituents
28828 -- abstract state ... defined at ...
28829 -- constant ... defined at ...
28830 -- variable ... defined at ...
28835 ("state & has unused Part_Of constituents",
28839 Error_Msg_Sloc := Sloc (Constit_Id);
28841 if Ekind (Constit_Id) = E_Abstract_State then
28843 ("\abstract state & defined #", State, Constit_Id);
28845 elsif Ekind (Constit_Id) = E_Constant then
28847 ("\constant & defined #", State, Constit_Id);
28850 pragma Assert (Ekind (Constit_Id) = E_Variable);
28851 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
28854 Next_Elmt (Constit_Elmt);
28857 end Report_Unused_Constituents;
28859 -- Local declarations
28861 Body_Ref : Node_Id;
28862 Body_Ref_Elmt : Elmt_Id;
28864 Extra_State : Node_Id;
28866 -- Start of processing for Analyze_Refinement_Clause
28869 -- A refinement clause appears as a component association where the
28870 -- sole choice is the state and the expressions are the constituents.
28871 -- This is a syntax error, always report.
28873 if Nkind (Clause) /= N_Component_Association then
28874 Error_Msg_N ("malformed state refinement clause", Clause);
28878 -- Analyze the state name of a refinement clause
28880 State := First (Choices (Clause));
28883 Resolve_State (State);
28885 -- Ensure that the state name denotes a valid abstract state that is
28886 -- defined in the spec of the related package.
28888 if Is_Entity_Name (State) then
28889 State_Id := Entity_Of (State);
28891 -- When the abstract state is undefined, it appears as Any_Id. Do
28892 -- not continue with the analysis of the clause.
28894 if State_Id = Any_Id then
28897 -- Catch any attempts to re-refine a state or refine a state that
28898 -- is not defined in the package declaration.
28900 elsif Ekind (State_Id) = E_Abstract_State then
28904 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
28908 -- References to a state with visible refinement are illegal.
28909 -- When nested packages are involved, detecting such references is
28910 -- tricky because pragma Refined_State is analyzed later than the
28911 -- offending pragma Depends or Global. References that occur in
28912 -- such nested context are stored in a list. Emit errors for all
28913 -- references found in Body_References (SPARK RM 6.1.4(8)).
28915 if Present (Body_References (State_Id)) then
28916 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
28917 while Present (Body_Ref_Elmt) loop
28918 Body_Ref := Node (Body_Ref_Elmt);
28920 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
28921 Error_Msg_Sloc := Sloc (State);
28922 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
28924 Next_Elmt (Body_Ref_Elmt);
28928 -- The state name is illegal. This is a syntax error, always report.
28931 Error_Msg_N ("malformed state name in refinement clause", State);
28935 -- A refinement clause may only refine one state at a time
28937 Extra_State := Next (State);
28939 if Present (Extra_State) then
28941 ("refinement clause cannot cover multiple states", Extra_State);
28944 -- Replicate the Part_Of constituents of the refined state because
28945 -- the algorithm will consume items.
28947 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
28949 -- Analyze all constituents of the refinement. Multiple constituents
28950 -- appear as an aggregate.
28952 Constit := Expression (Clause);
28954 if Nkind (Constit) = N_Aggregate then
28955 if Present (Component_Associations (Constit)) then
28957 ("constituents of refinement clause must appear in "
28958 & "positional form", Constit);
28960 else pragma Assert (Present (Expressions (Constit)));
28961 Constit := First (Expressions (Constit));
28962 while Present (Constit) loop
28963 Analyze_Constituent (Constit);
28968 -- Various forms of a single constituent. Note that these may include
28969 -- malformed constituents.
28972 Analyze_Constituent (Constit);
28975 -- Verify that external constituents do not introduce new external
28976 -- property in the state refinement (SPARK RM 7.2.8(2)).
28978 if Is_External_State (State_Id) then
28979 Check_External_Property
28980 (Prop_Nam => Name_Async_Readers,
28981 Enabled => Async_Readers_Enabled (State_Id),
28982 Constit => AR_Constit);
28984 Check_External_Property
28985 (Prop_Nam => Name_Async_Writers,
28986 Enabled => Async_Writers_Enabled (State_Id),
28987 Constit => AW_Constit);
28989 Check_External_Property
28990 (Prop_Nam => Name_Effective_Reads,
28991 Enabled => Effective_Reads_Enabled (State_Id),
28992 Constit => ER_Constit);
28994 Check_External_Property
28995 (Prop_Nam => Name_Effective_Writes,
28996 Enabled => Effective_Writes_Enabled (State_Id),
28997 Constit => EW_Constit);
28999 -- When a refined state is not external, it should not have external
29000 -- constituents (SPARK RM 7.2.8(1)).
29002 elsif External_Constit_Seen then
29004 ("non-external state & cannot contain external constituents in "
29005 & "refinement", State, State_Id);
29008 -- Ensure that all Part_Of candidate constituents have been mentioned
29009 -- in the refinement clause.
29011 Report_Unused_Constituents (Part_Of_Constits);
29012 end Analyze_Refinement_Clause;
29014 -----------------------------
29015 -- Report_Unrefined_States --
29016 -----------------------------
29018 procedure Report_Unrefined_States (States : Elist_Id) is
29019 State_Elmt : Elmt_Id;
29022 if Present (States) then
29023 State_Elmt := First_Elmt (States);
29024 while Present (State_Elmt) loop
29026 ("abstract state & must be refined", Node (State_Elmt));
29028 Next_Elmt (State_Elmt);
29031 end Report_Unrefined_States;
29033 -- Local declarations
29035 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
29038 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29041 -- Do not analyze the pragma multiple times
29043 if Is_Analyzed_Pragma (N) then
29047 -- Save the scenario for examination by the ABE Processing phase
29049 Record_Elaboration_Scenario (N);
29051 -- Replicate the abstract states declared by the package because the
29052 -- matching algorithm will consume states.
29054 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
29056 -- Gather all abstract states and objects declared in the visible
29057 -- state space of the package body. These items must be utilized as
29058 -- constituents in a state refinement.
29060 Body_States := Collect_Body_States (Body_Id);
29062 -- Multiple non-null state refinements appear as an aggregate
29064 if Nkind (Clauses) = N_Aggregate then
29065 if Present (Expressions (Clauses)) then
29067 ("state refinements must appear as component associations",
29070 else pragma Assert (Present (Component_Associations (Clauses)));
29071 Clause := First (Component_Associations (Clauses));
29072 while Present (Clause) loop
29073 Analyze_Refinement_Clause (Clause);
29078 -- Various forms of a single state refinement. Note that these may
29079 -- include malformed refinements.
29082 Analyze_Refinement_Clause (Clauses);
29085 -- List all abstract states that were left unrefined
29087 Report_Unrefined_States (Available_States);
29089 Set_Is_Analyzed_Pragma (N);
29090 end Analyze_Refined_State_In_Decl_Part;
29092 ------------------------------------
29093 -- Analyze_Test_Case_In_Decl_Part --
29094 ------------------------------------
29096 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
29097 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
29098 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
29100 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
29101 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29102 -- denoted by Arg_Nam.
29104 ------------------------------
29105 -- Preanalyze_Test_Case_Arg --
29106 ------------------------------
29108 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
29112 -- Preanalyze the original aspect argument for ASIS or for a generic
29113 -- subprogram to properly capture global references.
29115 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
29119 Arg_Nam => Arg_Nam,
29120 From_Aspect => True);
29122 if Present (Arg) then
29123 Preanalyze_Assert_Expression
29124 (Expression (Arg), Standard_Boolean);
29128 Arg := Test_Case_Arg (N, Arg_Nam);
29130 if Present (Arg) then
29131 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
29133 end Preanalyze_Test_Case_Arg;
29137 Restore_Scope : Boolean := False;
29139 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29142 -- Do not analyze the pragma multiple times
29144 if Is_Analyzed_Pragma (N) then
29148 -- Ensure that the formal parameters are visible when analyzing all
29149 -- clauses. This falls out of the general rule of aspects pertaining
29150 -- to subprogram declarations.
29152 if not In_Open_Scopes (Spec_Id) then
29153 Restore_Scope := True;
29154 Push_Scope (Spec_Id);
29156 if Is_Generic_Subprogram (Spec_Id) then
29157 Install_Generic_Formals (Spec_Id);
29159 Install_Formals (Spec_Id);
29163 Preanalyze_Test_Case_Arg (Name_Requires);
29164 Preanalyze_Test_Case_Arg (Name_Ensures);
29166 if Restore_Scope then
29170 -- Currently it is not possible to inline pre/postconditions on a
29171 -- subprogram subject to pragma Inline_Always.
29173 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
29175 Set_Is_Analyzed_Pragma (N);
29176 end Analyze_Test_Case_In_Decl_Part;
29182 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
29187 if Present (List) then
29188 Elmt := First_Elmt (List);
29189 while Present (Elmt) loop
29190 if Nkind (Node (Elmt)) = N_Defining_Identifier then
29193 Id := Entity_Of (Node (Elmt));
29196 if Id = Item_Id then
29207 -----------------------------------
29208 -- Build_Pragma_Check_Equivalent --
29209 -----------------------------------
29211 function Build_Pragma_Check_Equivalent
29213 Subp_Id : Entity_Id := Empty;
29214 Inher_Id : Entity_Id := Empty;
29215 Keep_Pragma_Id : Boolean := False) return Node_Id
29217 function Suppress_Reference (N : Node_Id) return Traverse_Result;
29218 -- Detect whether node N references a formal parameter subject to
29219 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29220 -- to False to suppress the generation of a reference when analyzing
29223 ------------------------
29224 -- Suppress_Reference --
29225 ------------------------
29227 function Suppress_Reference (N : Node_Id) return Traverse_Result is
29228 Formal : Entity_Id;
29231 if Is_Entity_Name (N) and then Present (Entity (N)) then
29232 Formal := Entity (N);
29234 -- The formal parameter is subject to pragma Unreferenced. Prevent
29235 -- the generation of references by resetting the Comes_From_Source
29238 if Is_Formal (Formal)
29239 and then Has_Pragma_Unreferenced (Formal)
29241 Set_Comes_From_Source (N, False);
29246 end Suppress_Reference;
29248 procedure Suppress_References is
29249 new Traverse_Proc (Suppress_Reference);
29253 Loc : constant Source_Ptr := Sloc (Prag);
29254 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
29255 Check_Prag : Node_Id;
29259 Needs_Wrapper : Boolean;
29260 pragma Unreferenced (Needs_Wrapper);
29262 -- Start of processing for Build_Pragma_Check_Equivalent
29265 -- When the pre- or postcondition is inherited, map the formals of the
29266 -- inherited subprogram to those of the current subprogram. In addition,
29267 -- map primitive operations of the parent type into the corresponding
29268 -- primitive operations of the descendant.
29270 if Present (Inher_Id) then
29271 pragma Assert (Present (Subp_Id));
29273 Update_Primitives_Mapping (Inher_Id, Subp_Id);
29275 -- Use generic machinery to copy inherited pragma, as if it were an
29276 -- instantiation, resetting source locations appropriately, so that
29277 -- expressions inside the inherited pragma use chained locations.
29278 -- This is used in particular in GNATprove to locate precisely
29279 -- messages on a given inherited pragma.
29281 Set_Copied_Sloc_For_Inherited_Pragma
29282 (Unit_Declaration_Node (Subp_Id), Inher_Id);
29283 Check_Prag := New_Copy_Tree (Source => Prag);
29285 -- Build the inherited class-wide condition
29287 Build_Class_Wide_Expression
29288 (Prag => Check_Prag,
29290 Par_Subp => Inher_Id,
29291 Adjust_Sloc => True,
29292 Needs_Wrapper => Needs_Wrapper);
29294 -- If not an inherited condition simply copy the original pragma
29297 Check_Prag := New_Copy_Tree (Source => Prag);
29300 -- Mark the pragma as being internally generated and reset the Analyzed
29303 Set_Analyzed (Check_Prag, False);
29304 Set_Comes_From_Source (Check_Prag, False);
29306 -- The tree of the original pragma may contain references to the
29307 -- formal parameters of the related subprogram. At the same time
29308 -- the corresponding body may mark the formals as unreferenced:
29310 -- procedure Proc (Formal : ...)
29311 -- with Pre => Formal ...;
29313 -- procedure Proc (Formal : ...) is
29314 -- pragma Unreferenced (Formal);
29317 -- This creates problems because all pragma Check equivalents are
29318 -- analyzed at the end of the body declarations. Since all source
29319 -- references have already been accounted for, reset any references
29320 -- to such formals in the generated pragma Check equivalent.
29322 Suppress_References (Check_Prag);
29324 if Present (Corresponding_Aspect (Prag)) then
29325 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
29330 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29331 -- the copied pragma in the newly created pragma, convert the copy into
29332 -- pragma Check by correcting the name and adding a check_kind argument.
29334 if not Keep_Pragma_Id then
29335 Set_Class_Present (Check_Prag, False);
29337 Set_Pragma_Identifier
29338 (Check_Prag, Make_Identifier (Loc, Name_Check));
29340 Prepend_To (Pragma_Argument_Associations (Check_Prag),
29341 Make_Pragma_Argument_Association (Loc,
29342 Expression => Make_Identifier (Loc, Nam)));
29345 -- Update the error message when the pragma is inherited
29347 if Present (Inher_Id) then
29348 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
29350 if Chars (Msg_Arg) = Name_Message then
29351 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
29353 -- Insert "inherited" to improve the error message
29355 if Name_Buffer (1 .. 8) = "failed p" then
29356 Insert_Str_In_Name_Buffer ("inherited ", 8);
29357 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
29363 end Build_Pragma_Check_Equivalent;
29365 -----------------------------
29366 -- Check_Applicable_Policy --
29367 -----------------------------
29369 procedure Check_Applicable_Policy (N : Node_Id) is
29373 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
29376 -- No effect if not valid assertion kind name
29378 if not Is_Valid_Assertion_Kind (Ename) then
29382 -- Loop through entries in check policy list
29384 PP := Opt.Check_Policy_List;
29385 while Present (PP) loop
29387 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29388 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29392 or else Pnm = Name_Assertion
29393 or else (Pnm = Name_Statement_Assertions
29394 and then Nam_In (Ename, Name_Assert,
29395 Name_Assert_And_Cut,
29397 Name_Loop_Invariant,
29398 Name_Loop_Variant))
29400 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
29406 -- In CodePeer mode and GNATprove mode, we need to
29407 -- consider all assertions, unless they are disabled.
29408 -- Force Is_Checked on ignored assertions, in particular
29409 -- because transformations of the AST may depend on
29410 -- assertions being checked (e.g. the translation of
29411 -- attribute 'Loop_Entry).
29413 if CodePeer_Mode or GNATprove_Mode then
29414 Set_Is_Checked (N, True);
29415 Set_Is_Ignored (N, False);
29417 Set_Is_Checked (N, False);
29418 Set_Is_Ignored (N, True);
29424 Set_Is_Checked (N, True);
29425 Set_Is_Ignored (N, False);
29427 when Name_Disable =>
29428 Set_Is_Ignored (N, True);
29429 Set_Is_Checked (N, False);
29430 Set_Is_Disabled (N, True);
29432 -- That should be exhaustive, the null here is a defence
29433 -- against a malformed tree from previous errors.
29442 PP := Next_Pragma (PP);
29446 -- If there are no specific entries that matched, then we let the
29447 -- setting of assertions govern. Note that this provides the needed
29448 -- compatibility with the RM for the cases of assertion, invariant,
29449 -- precondition, predicate, and postcondition. Note also that
29450 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29452 if Assertions_Enabled then
29453 Set_Is_Checked (N, True);
29454 Set_Is_Ignored (N, False);
29456 Set_Is_Checked (N, False);
29457 Set_Is_Ignored (N, True);
29459 end Check_Applicable_Policy;
29461 -------------------------------
29462 -- Check_External_Properties --
29463 -------------------------------
29465 procedure Check_External_Properties
29473 -- All properties enabled
29475 if AR and AW and ER and EW then
29478 -- Async_Readers + Effective_Writes
29479 -- Async_Readers + Async_Writers + Effective_Writes
29481 elsif AR and EW and not ER then
29484 -- Async_Writers + Effective_Reads
29485 -- Async_Readers + Async_Writers + Effective_Reads
29487 elsif AW and ER and not EW then
29490 -- Async_Readers + Async_Writers
29492 elsif AR and AW and not ER and not EW then
29497 elsif AR and not AW and not ER and not EW then
29502 elsif AW and not AR and not ER and not EW then
29507 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29510 end Check_External_Properties;
29516 function Check_Kind (Nam : Name_Id) return Name_Id is
29520 -- Loop through entries in check policy list
29522 PP := Opt.Check_Policy_List;
29523 while Present (PP) loop
29525 PPA : constant List_Id := Pragma_Argument_Associations (PP);
29526 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
29530 or else (Pnm = Name_Assertion
29531 and then Is_Valid_Assertion_Kind (Nam))
29532 or else (Pnm = Name_Statement_Assertions
29533 and then Nam_In (Nam, Name_Assert,
29534 Name_Assert_And_Cut,
29536 Name_Loop_Invariant,
29537 Name_Loop_Variant))
29539 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
29548 return Name_Ignore;
29550 when Name_Disable =>
29551 return Name_Disable;
29554 raise Program_Error;
29558 PP := Next_Pragma (PP);
29563 -- If there are no specific entries that matched, then we let the
29564 -- setting of assertions govern. Note that this provides the needed
29565 -- compatibility with the RM for the cases of assertion, invariant,
29566 -- precondition, predicate, and postcondition.
29568 if Assertions_Enabled then
29571 return Name_Ignore;
29575 ---------------------------
29576 -- Check_Missing_Part_Of --
29577 ---------------------------
29579 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
29580 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
29581 -- Determine whether a package denoted by Pack_Id declares at least one
29584 -----------------------
29585 -- Has_Visible_State --
29586 -----------------------
29588 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
29589 Item_Id : Entity_Id;
29592 -- Traverse the entity chain of the package trying to find at least
29593 -- one visible abstract state, variable or a package [instantiation]
29594 -- that declares a visible state.
29596 Item_Id := First_Entity (Pack_Id);
29597 while Present (Item_Id)
29598 and then not In_Private_Part (Item_Id)
29600 -- Do not consider internally generated items
29602 if not Comes_From_Source (Item_Id) then
29605 -- Do not consider generic formals or their corresponding actuals
29606 -- because they are not part of a visible state. Note that both
29607 -- entities are marked as hidden.
29609 elsif Is_Hidden (Item_Id) then
29612 -- A visible state has been found. Note that constants are not
29613 -- considered here because it is not possible to determine whether
29614 -- they depend on variable input. This check is left to the SPARK
29617 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
29620 -- Recursively peek into nested packages and instantiations
29622 elsif Ekind (Item_Id) = E_Package
29623 and then Has_Visible_State (Item_Id)
29628 Next_Entity (Item_Id);
29632 end Has_Visible_State;
29636 Pack_Id : Entity_Id;
29637 Placement : State_Space_Kind;
29639 -- Start of processing for Check_Missing_Part_Of
29642 -- Do not consider abstract states, variables or package instantiations
29643 -- coming from an instance as those always inherit the Part_Of indicator
29644 -- of the instance itself.
29646 if In_Instance then
29649 -- Do not consider internally generated entities as these can never
29650 -- have a Part_Of indicator.
29652 elsif not Comes_From_Source (Item_Id) then
29655 -- Perform these checks only when SPARK_Mode is enabled as they will
29656 -- interfere with standard Ada rules and produce false positives.
29658 elsif SPARK_Mode /= On then
29661 -- Do not consider constants, because the compiler cannot accurately
29662 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29663 -- act as a hidden state of a package.
29665 elsif Ekind (Item_Id) = E_Constant then
29669 -- Find where the abstract state, variable or package instantiation
29670 -- lives with respect to the state space.
29672 Find_Placement_In_State_Space
29673 (Item_Id => Item_Id,
29674 Placement => Placement,
29675 Pack_Id => Pack_Id);
29677 -- Items that appear in a non-package construct (subprogram, block, etc)
29678 -- do not require a Part_Of indicator because they can never act as a
29681 if Placement = Not_In_Package then
29684 -- An item declared in the body state space of a package always act as a
29685 -- constituent and does not need explicit Part_Of indicator.
29687 elsif Placement = Body_State_Space then
29690 -- In general an item declared in the visible state space of a package
29691 -- does not require a Part_Of indicator. The only exception is when the
29692 -- related package is a nongeneric private child unit, in which case
29693 -- Part_Of must denote a state in the parent unit or in one of its
29696 elsif Placement = Visible_State_Space then
29697 if Is_Child_Unit (Pack_Id)
29698 and then not Is_Generic_Unit (Pack_Id)
29699 and then Is_Private_Descendant (Pack_Id)
29701 -- A package instantiation does not need a Part_Of indicator when
29702 -- the related generic template has no visible state.
29704 if Ekind (Item_Id) = E_Package
29705 and then Is_Generic_Instance (Item_Id)
29706 and then not Has_Visible_State (Item_Id)
29710 -- All other cases require Part_Of
29714 ("indicator Part_Of is required in this context "
29715 & "(SPARK RM 7.2.6(3))", Item_Id);
29716 Error_Msg_Name_1 := Chars (Pack_Id);
29718 ("\& is declared in the visible part of private child "
29719 & "unit %", Item_Id);
29723 -- When the item appears in the private state space of a package, it
29724 -- must be a part of some state declared by the said package.
29726 else pragma Assert (Placement = Private_State_Space);
29728 -- The related package does not declare a state, the item cannot act
29729 -- as a Part_Of constituent.
29731 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
29734 -- A package instantiation does not need a Part_Of indicator when the
29735 -- related generic template has no visible state.
29737 elsif Ekind (Item_Id) = E_Package
29738 and then Is_Generic_Instance (Item_Id)
29739 and then not Has_Visible_State (Item_Id)
29743 -- All other cases require Part_Of
29747 ("indicator Part_Of is required in this context "
29748 & "(SPARK RM 7.2.6(2))", Item_Id);
29749 Error_Msg_Name_1 := Chars (Pack_Id);
29751 ("\& is declared in the private part of package %", Item_Id);
29754 end Check_Missing_Part_Of;
29756 ---------------------------------------------------
29757 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29758 ---------------------------------------------------
29760 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29762 Spec_Id : Entity_Id)
29765 if Warn_On_Redundant_Constructs
29766 and then Has_Pragma_Inline_Always (Spec_Id)
29767 and then Assertions_Enabled
29769 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
29771 if From_Aspect_Specification (Prag) then
29773 ("aspect % not enforced on inlined subprogram &?r?",
29774 Corresponding_Aspect (Prag), Spec_Id);
29777 ("pragma % not enforced on inlined subprogram &?r?",
29781 end Check_Postcondition_Use_In_Inlined_Subprogram;
29783 -------------------------------------
29784 -- Check_State_And_Constituent_Use --
29785 -------------------------------------
29787 procedure Check_State_And_Constituent_Use
29788 (States : Elist_Id;
29789 Constits : Elist_Id;
29792 Constit_Elmt : Elmt_Id;
29793 Constit_Id : Entity_Id;
29794 State_Id : Entity_Id;
29797 -- Nothing to do if there are no states or constituents
29799 if No (States) or else No (Constits) then
29803 -- Inspect the list of constituents and try to determine whether its
29804 -- encapsulating state is in list States.
29806 Constit_Elmt := First_Elmt (Constits);
29807 while Present (Constit_Elmt) loop
29808 Constit_Id := Node (Constit_Elmt);
29810 -- Determine whether the constituent is part of an encapsulating
29811 -- state that appears in the same context and if this is the case,
29812 -- emit an error (SPARK RM 7.2.6(7)).
29814 State_Id := Find_Encapsulating_State (States, Constit_Id);
29816 if Present (State_Id) then
29817 Error_Msg_Name_1 := Chars (Constit_Id);
29819 ("cannot mention state & and its constituent % in the same "
29820 & "context", Context, State_Id);
29824 Next_Elmt (Constit_Elmt);
29826 end Check_State_And_Constituent_Use;
29828 ---------------------------------------------
29829 -- Collect_Inherited_Class_Wide_Conditions --
29830 ---------------------------------------------
29832 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
29833 Parent_Subp : constant Entity_Id :=
29834 Ultimate_Alias (Overridden_Operation (Subp));
29835 -- The Overridden_Operation may itself be inherited and as such have no
29836 -- explicit contract.
29838 Prags : constant Node_Id := Contract (Parent_Subp);
29839 In_Spec_Expr : Boolean;
29840 Installed : Boolean;
29842 New_Prag : Node_Id;
29845 Installed := False;
29847 -- Iterate over the contract of the overridden subprogram to find all
29848 -- inherited class-wide pre- and postconditions.
29850 if Present (Prags) then
29851 Prag := Pre_Post_Conditions (Prags);
29853 while Present (Prag) loop
29854 if Nam_In (Pragma_Name_Unmapped (Prag),
29855 Name_Precondition, Name_Postcondition)
29856 and then Class_Present (Prag)
29858 -- The generated pragma must be analyzed in the context of
29859 -- the subprogram, to make its formals visible. In addition,
29860 -- we must inhibit freezing and full analysis because the
29861 -- controlling type of the subprogram is not frozen yet, and
29862 -- may have further primitives.
29864 if not Installed then
29867 Install_Formals (Subp);
29868 In_Spec_Expr := In_Spec_Expression;
29869 In_Spec_Expression := True;
29873 Build_Pragma_Check_Equivalent
29874 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
29876 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
29877 Preanalyze (New_Prag);
29879 -- Prevent further analysis in subsequent processing of the
29880 -- current list of declarations
29882 Set_Analyzed (New_Prag);
29885 Prag := Next_Pragma (Prag);
29889 In_Spec_Expression := In_Spec_Expr;
29893 end Collect_Inherited_Class_Wide_Conditions;
29895 ---------------------------------------
29896 -- Collect_Subprogram_Inputs_Outputs --
29897 ---------------------------------------
29899 procedure Collect_Subprogram_Inputs_Outputs
29900 (Subp_Id : Entity_Id;
29901 Synthesize : Boolean := False;
29902 Subp_Inputs : in out Elist_Id;
29903 Subp_Outputs : in out Elist_Id;
29904 Global_Seen : out Boolean)
29906 procedure Collect_Dependency_Clause (Clause : Node_Id);
29907 -- Collect all relevant items from a dependency clause
29909 procedure Collect_Global_List
29911 Mode : Name_Id := Name_Input);
29912 -- Collect all relevant items from a global list
29914 -------------------------------
29915 -- Collect_Dependency_Clause --
29916 -------------------------------
29918 procedure Collect_Dependency_Clause (Clause : Node_Id) is
29919 procedure Collect_Dependency_Item
29921 Is_Input : Boolean);
29922 -- Add an item to the proper subprogram input or output collection
29924 -----------------------------
29925 -- Collect_Dependency_Item --
29926 -----------------------------
29928 procedure Collect_Dependency_Item
29930 Is_Input : Boolean)
29935 -- Nothing to collect when the item is null
29937 if Nkind (Item) = N_Null then
29940 -- Ditto for attribute 'Result
29942 elsif Is_Attribute_Result (Item) then
29945 -- Multiple items appear as an aggregate
29947 elsif Nkind (Item) = N_Aggregate then
29948 Extra := First (Expressions (Item));
29949 while Present (Extra) loop
29950 Collect_Dependency_Item (Extra, Is_Input);
29954 -- Otherwise this is a solitary item
29958 Append_New_Elmt (Item, Subp_Inputs);
29960 Append_New_Elmt (Item, Subp_Outputs);
29963 end Collect_Dependency_Item;
29965 -- Start of processing for Collect_Dependency_Clause
29968 if Nkind (Clause) = N_Null then
29971 -- A dependency clause appears as component association
29973 elsif Nkind (Clause) = N_Component_Association then
29974 Collect_Dependency_Item
29975 (Item => Expression (Clause),
29978 Collect_Dependency_Item
29979 (Item => First (Choices (Clause)),
29980 Is_Input => False);
29982 -- To accommodate partial decoration of disabled SPARK features, this
29983 -- routine may be called with illegal input. If this is the case, do
29984 -- not raise Program_Error.
29989 end Collect_Dependency_Clause;
29991 -------------------------
29992 -- Collect_Global_List --
29993 -------------------------
29995 procedure Collect_Global_List
29997 Mode : Name_Id := Name_Input)
29999 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
30000 -- Add an item to the proper subprogram input or output collection
30002 -------------------------
30003 -- Collect_Global_Item --
30004 -------------------------
30006 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
30008 if Nam_In (Mode, Name_In_Out, Name_Input) then
30009 Append_New_Elmt (Item, Subp_Inputs);
30012 if Nam_In (Mode, Name_In_Out, Name_Output) then
30013 Append_New_Elmt (Item, Subp_Outputs);
30015 end Collect_Global_Item;
30022 -- Start of processing for Collect_Global_List
30025 if Nkind (List) = N_Null then
30028 -- Single global item declaration
30030 elsif Nkind_In (List, N_Expanded_Name,
30032 N_Selected_Component)
30034 Collect_Global_Item (List, Mode);
30036 -- Simple global list or moded global list declaration
30038 elsif Nkind (List) = N_Aggregate then
30039 if Present (Expressions (List)) then
30040 Item := First (Expressions (List));
30041 while Present (Item) loop
30042 Collect_Global_Item (Item, Mode);
30047 Assoc := First (Component_Associations (List));
30048 while Present (Assoc) loop
30049 Collect_Global_List
30050 (List => Expression (Assoc),
30051 Mode => Chars (First (Choices (Assoc))));
30056 -- To accommodate partial decoration of disabled SPARK features, this
30057 -- routine may be called with illegal input. If this is the case, do
30058 -- not raise Program_Error.
30063 end Collect_Global_List;
30070 Formal : Entity_Id;
30072 Spec_Id : Entity_Id := Empty;
30073 Subp_Decl : Node_Id;
30076 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30079 Global_Seen := False;
30081 -- Process all formal parameters of entries, [generic] subprograms, and
30084 if Ekind_In (Subp_Id, E_Entry,
30087 E_Generic_Function,
30088 E_Generic_Procedure,
30092 Subp_Decl := Unit_Declaration_Node (Subp_Id);
30093 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30095 -- Process all formal parameters
30097 Formal := First_Entity (Spec_Id);
30098 while Present (Formal) loop
30099 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
30100 Append_New_Elmt (Formal, Subp_Inputs);
30103 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
30104 Append_New_Elmt (Formal, Subp_Outputs);
30106 -- Out parameters can act as inputs when the related type is
30107 -- tagged, unconstrained array, unconstrained record, or record
30108 -- with unconstrained components.
30110 if Ekind (Formal) = E_Out_Parameter
30111 and then Is_Unconstrained_Or_Tagged_Item (Formal)
30113 Append_New_Elmt (Formal, Subp_Inputs);
30117 Next_Entity (Formal);
30120 -- Otherwise the input denotes a task type, a task body, or the
30121 -- anonymous object created for a single task type.
30123 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
30124 or else Is_Single_Task_Object (Subp_Id)
30126 Subp_Decl := Declaration_Node (Subp_Id);
30127 Spec_Id := Unique_Defining_Entity (Subp_Decl);
30130 -- When processing an entry, subprogram or task body, look for pragmas
30131 -- Refined_Depends and Refined_Global as they specify the inputs and
30134 if Is_Entry_Body (Subp_Id)
30135 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
30137 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
30138 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
30140 -- Subprogram declaration or stand-alone body case, look for pragmas
30141 -- Depends and Global
30144 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
30145 Global := Get_Pragma (Spec_Id, Pragma_Global);
30148 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30149 -- because it provides finer granularity of inputs and outputs.
30151 if Present (Global) then
30152 Global_Seen := True;
30153 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
30155 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30156 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30157 -- the inputs and outputs from [Refined_]Depends.
30159 elsif Synthesize and then Present (Depends) then
30160 Clauses := Expression (Get_Argument (Depends, Spec_Id));
30162 -- Multiple dependency clauses appear as an aggregate
30164 if Nkind (Clauses) = N_Aggregate then
30165 Clause := First (Component_Associations (Clauses));
30166 while Present (Clause) loop
30167 Collect_Dependency_Clause (Clause);
30171 -- Otherwise this is a single dependency clause
30174 Collect_Dependency_Clause (Clauses);
30178 -- The current instance of a protected type acts as a formal parameter
30179 -- of mode IN for functions and IN OUT for entries and procedures
30180 -- (SPARK RM 6.1.4).
30182 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
30183 Typ := Scope (Spec_Id);
30185 -- Use the anonymous object when the type is single protected
30187 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30188 Typ := Anonymous_Object (Typ);
30191 Append_New_Elmt (Typ, Subp_Inputs);
30193 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
30194 Append_New_Elmt (Typ, Subp_Outputs);
30197 -- The current instance of a task type acts as a formal parameter of
30198 -- mode IN OUT (SPARK RM 6.1.4).
30200 elsif Ekind (Spec_Id) = E_Task_Type then
30203 -- Use the anonymous object when the type is single task
30205 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
30206 Typ := Anonymous_Object (Typ);
30209 Append_New_Elmt (Typ, Subp_Inputs);
30210 Append_New_Elmt (Typ, Subp_Outputs);
30212 elsif Is_Single_Task_Object (Spec_Id) then
30213 Append_New_Elmt (Spec_Id, Subp_Inputs);
30214 Append_New_Elmt (Spec_Id, Subp_Outputs);
30216 end Collect_Subprogram_Inputs_Outputs;
30218 ---------------------------
30219 -- Contract_Freeze_Error --
30220 ---------------------------
30222 procedure Contract_Freeze_Error
30223 (Contract_Id : Entity_Id;
30224 Freeze_Id : Entity_Id)
30227 Error_Msg_Name_1 := Chars (Contract_Id);
30228 Error_Msg_Sloc := Sloc (Freeze_Id);
30231 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
30233 ("\all contractual items must be declared before body #", Contract_Id);
30234 end Contract_Freeze_Error;
30236 ---------------------------------
30237 -- Delay_Config_Pragma_Analyze --
30238 ---------------------------------
30240 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
30242 return Nam_In (Pragma_Name_Unmapped (N),
30243 Name_Interrupt_State, Name_Priority_Specific_Dispatching);
30244 end Delay_Config_Pragma_Analyze;
30246 -----------------------
30247 -- Duplication_Error --
30248 -----------------------
30250 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
30251 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
30252 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
30255 Error_Msg_Sloc := Sloc (Prev);
30256 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
30258 -- Emit a precise message to distinguish between source pragmas and
30259 -- pragmas generated from aspects. The ordering of the two pragmas is
30263 -- Prag -- duplicate
30265 -- No error is emitted when both pragmas come from aspects because this
30266 -- is already detected by the general aspect analysis mechanism.
30268 if Prag_From_Asp and Prev_From_Asp then
30270 elsif Prag_From_Asp then
30271 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
30272 elsif Prev_From_Asp then
30273 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
30275 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
30277 end Duplication_Error;
30279 ------------------------------
30280 -- Find_Encapsulating_State --
30281 ------------------------------
30283 function Find_Encapsulating_State
30284 (States : Elist_Id;
30285 Constit_Id : Entity_Id) return Entity_Id
30287 State_Id : Entity_Id;
30290 -- Since a constituent may be part of a larger constituent set, climb
30291 -- the encapsulating state chain looking for a state that appears in
30294 State_Id := Encapsulating_State (Constit_Id);
30295 while Present (State_Id) loop
30296 if Contains (States, State_Id) then
30300 State_Id := Encapsulating_State (State_Id);
30304 end Find_Encapsulating_State;
30306 --------------------------
30307 -- Find_Related_Context --
30308 --------------------------
30310 function Find_Related_Context
30312 Do_Checks : Boolean := False) return Node_Id
30317 Stmt := Prev (Prag);
30318 while Present (Stmt) loop
30320 -- Skip prior pragmas, but check for duplicates
30322 if Nkind (Stmt) = N_Pragma then
30324 and then Pragma_Name (Stmt) = Pragma_Name (Prag)
30331 -- Skip internally generated code
30333 elsif not Comes_From_Source (Stmt) then
30335 -- The anonymous object created for a single concurrent type is a
30336 -- suitable context.
30338 if Nkind (Stmt) = N_Object_Declaration
30339 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30344 -- Return the current source construct
30354 end Find_Related_Context;
30356 --------------------------------------
30357 -- Find_Related_Declaration_Or_Body --
30358 --------------------------------------
30360 function Find_Related_Declaration_Or_Body
30362 Do_Checks : Boolean := False) return Node_Id
30364 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
30366 procedure Expression_Function_Error;
30367 -- Emit an error concerning pragma Prag that illegaly applies to an
30368 -- expression function.
30370 -------------------------------
30371 -- Expression_Function_Error --
30372 -------------------------------
30374 procedure Expression_Function_Error is
30376 Error_Msg_Name_1 := Prag_Nam;
30378 -- Emit a precise message to distinguish between source pragmas and
30379 -- pragmas generated from aspects.
30381 if From_Aspect_Specification (Prag) then
30383 ("aspect % cannot apply to a stand alone expression function",
30387 ("pragma % cannot apply to a stand alone expression function",
30390 end Expression_Function_Error;
30394 Context : constant Node_Id := Parent (Prag);
30397 Look_For_Body : constant Boolean :=
30398 Nam_In (Prag_Nam, Name_Refined_Depends,
30399 Name_Refined_Global,
30401 Name_Refined_State);
30402 -- Refinement pragmas must be associated with a subprogram body [stub]
30404 -- Start of processing for Find_Related_Declaration_Or_Body
30407 Stmt := Prev (Prag);
30408 while Present (Stmt) loop
30410 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30411 -- by splitting a complex pre/postcondition are not considered to
30414 if Nkind (Stmt) = N_Pragma then
30416 and then not Split_PPC (Stmt)
30417 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
30424 -- Emit an error when a refinement pragma appears on an expression
30425 -- function without a completion.
30428 and then Look_For_Body
30429 and then Nkind (Stmt) = N_Subprogram_Declaration
30430 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
30431 and then not Has_Completion (Defining_Entity (Stmt))
30433 Expression_Function_Error;
30436 -- The refinement pragma applies to a subprogram body stub
30438 elsif Look_For_Body
30439 and then Nkind (Stmt) = N_Subprogram_Body_Stub
30443 -- Skip internally generated code
30445 elsif not Comes_From_Source (Stmt) then
30447 -- The anonymous object created for a single concurrent type is a
30448 -- suitable context.
30450 if Nkind (Stmt) = N_Object_Declaration
30451 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
30455 elsif Nkind (Stmt) = N_Subprogram_Declaration then
30457 -- The subprogram declaration is an internally generated spec
30458 -- for an expression function.
30460 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30463 -- The subprogram declaration is an internally generated spec
30464 -- for a stand-alone subrogram body declared inside a protected
30467 elsif Present (Corresponding_Body (Stmt))
30468 and then Comes_From_Source (Corresponding_Body (Stmt))
30469 and then Is_Protected_Type (Current_Scope)
30473 -- The subprogram is actually an instance housed within an
30474 -- anonymous wrapper package.
30476 elsif Present (Generic_Parent (Specification (Stmt))) then
30481 -- Return the current construct which is either a subprogram body,
30482 -- a subprogram declaration or is illegal.
30491 -- If we fall through, then the pragma was either the first declaration
30492 -- or it was preceded by other pragmas and no source constructs.
30494 -- The pragma is associated with a library-level subprogram
30496 if Nkind (Context) = N_Compilation_Unit_Aux then
30497 return Unit (Parent (Context));
30499 -- The pragma appears inside the declarations of an entry body
30501 elsif Nkind (Context) = N_Entry_Body then
30504 -- The pragma appears inside the statements of a subprogram body. This
30505 -- placement is the result of subprogram contract expansion.
30507 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
30508 return Parent (Context);
30510 -- The pragma appears inside the declarative part of a package body
30512 elsif Nkind (Context) = N_Package_Body then
30515 -- The pragma appears inside the declarative part of a subprogram body
30517 elsif Nkind (Context) = N_Subprogram_Body then
30520 -- The pragma appears inside the declarative part of a task body
30522 elsif Nkind (Context) = N_Task_Body then
30525 -- The pragma appears inside the visible part of a package specification
30527 elsif Nkind (Context) = N_Package_Specification then
30528 return Parent (Context);
30530 -- The pragma is a byproduct of aspect expansion, return the related
30531 -- context of the original aspect. This case has a lower priority as
30532 -- the above circuitry pinpoints precisely the related context.
30534 elsif Present (Corresponding_Aspect (Prag)) then
30535 return Parent (Corresponding_Aspect (Prag));
30537 -- No candidate subprogram [body] found
30542 end Find_Related_Declaration_Or_Body;
30544 ----------------------------------
30545 -- Find_Related_Package_Or_Body --
30546 ----------------------------------
30548 function Find_Related_Package_Or_Body
30550 Do_Checks : Boolean := False) return Node_Id
30552 Context : constant Node_Id := Parent (Prag);
30553 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
30557 Stmt := Prev (Prag);
30558 while Present (Stmt) loop
30560 -- Skip prior pragmas, but check for duplicates
30562 if Nkind (Stmt) = N_Pragma then
30563 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
30569 -- Skip internally generated code
30571 elsif not Comes_From_Source (Stmt) then
30572 if Nkind (Stmt) = N_Subprogram_Declaration then
30574 -- The subprogram declaration is an internally generated spec
30575 -- for an expression function.
30577 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
30580 -- The subprogram is actually an instance housed within an
30581 -- anonymous wrapper package.
30583 elsif Present (Generic_Parent (Specification (Stmt))) then
30588 -- Return the current source construct which is illegal
30597 -- If we fall through, then the pragma was either the first declaration
30598 -- or it was preceded by other pragmas and no source constructs.
30600 -- The pragma is associated with a package. The immediate context in
30601 -- this case is the specification of the package.
30603 if Nkind (Context) = N_Package_Specification then
30604 return Parent (Context);
30606 -- The pragma appears in the declarations of a package body
30608 elsif Nkind (Context) = N_Package_Body then
30611 -- The pragma appears in the statements of a package body
30613 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
30614 and then Nkind (Parent (Context)) = N_Package_Body
30616 return Parent (Context);
30618 -- The pragma is a byproduct of aspect expansion, return the related
30619 -- context of the original aspect. This case has a lower priority as
30620 -- the above circuitry pinpoints precisely the related context.
30622 elsif Present (Corresponding_Aspect (Prag)) then
30623 return Parent (Corresponding_Aspect (Prag));
30625 -- No candidate package [body] found
30630 end Find_Related_Package_Or_Body;
30636 function Get_Argument
30638 Context_Id : Entity_Id := Empty) return Node_Id
30640 Args : constant List_Id := Pragma_Argument_Associations (Prag);
30643 -- Use the expression of the original aspect when compiling for ASIS or
30644 -- when analyzing the template of a generic unit. In both cases the
30645 -- aspect's tree must be decorated to allow for ASIS queries or to save
30646 -- the global references in the generic context.
30648 if From_Aspect_Specification (Prag)
30649 and then (ASIS_Mode or else (Present (Context_Id)
30650 and then Is_Generic_Unit (Context_Id)))
30652 return Corresponding_Aspect (Prag);
30654 -- Otherwise use the expression of the pragma
30656 elsif Present (Args) then
30657 return First (Args);
30664 -------------------------
30665 -- Get_Base_Subprogram --
30666 -------------------------
30668 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
30670 -- Follow subprogram renaming chain
30672 if Is_Subprogram (Def_Id)
30673 and then Nkind (Parent (Declaration_Node (Def_Id))) =
30674 N_Subprogram_Renaming_Declaration
30675 and then Present (Alias (Def_Id))
30677 return Alias (Def_Id);
30681 end Get_Base_Subprogram;
30683 -----------------------
30684 -- Get_SPARK_Mode_Type --
30685 -----------------------
30687 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
30689 if N = Name_On then
30691 elsif N = Name_Off then
30694 -- Any other argument is illegal. Assume that no SPARK mode applies to
30695 -- avoid potential cascaded errors.
30700 end Get_SPARK_Mode_Type;
30702 ------------------------------------
30703 -- Get_SPARK_Mode_From_Annotation --
30704 ------------------------------------
30706 function Get_SPARK_Mode_From_Annotation
30707 (N : Node_Id) return SPARK_Mode_Type
30712 if Nkind (N) = N_Aspect_Specification then
30713 Mode := Expression (N);
30715 else pragma Assert (Nkind (N) = N_Pragma);
30716 Mode := First (Pragma_Argument_Associations (N));
30718 if Present (Mode) then
30719 Mode := Get_Pragma_Arg (Mode);
30723 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30725 if Present (Mode) then
30726 if Nkind (Mode) = N_Identifier then
30727 return Get_SPARK_Mode_Type (Chars (Mode));
30729 -- In case of a malformed aspect or pragma, return the default None
30735 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30740 end Get_SPARK_Mode_From_Annotation;
30742 ---------------------------
30743 -- Has_Extra_Parentheses --
30744 ---------------------------
30746 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
30750 -- The aggregate should not have an expression list because a clause
30751 -- is always interpreted as a component association. The only way an
30752 -- expression list can sneak in is by adding extra parentheses around
30753 -- the individual clauses:
30755 -- Depends (Output => Input) -- proper form
30756 -- Depends ((Output => Input)) -- extra parentheses
30758 -- Since the extra parentheses are not allowed by the syntax of the
30759 -- pragma, flag them now to avoid emitting misleading errors down the
30762 if Nkind (Clause) = N_Aggregate
30763 and then Present (Expressions (Clause))
30765 Expr := First (Expressions (Clause));
30766 while Present (Expr) loop
30768 -- A dependency clause surrounded by extra parentheses appears
30769 -- as an aggregate of component associations with an optional
30770 -- Paren_Count set.
30772 if Nkind (Expr) = N_Aggregate
30773 and then Present (Component_Associations (Expr))
30776 ("dependency clause contains extra parentheses", Expr);
30778 -- Otherwise the expression is a malformed construct
30781 SPARK_Msg_N ("malformed dependency clause", Expr);
30791 end Has_Extra_Parentheses;
30797 procedure Initialize is
30800 Compile_Time_Warnings_Errors.Init;
30809 Dummy := Dummy + 1;
30812 -----------------------------
30813 -- Is_Config_Static_String --
30814 -----------------------------
30816 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
30818 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
30819 -- This is an internal recursive function that is just like the outer
30820 -- function except that it adds the string to the name buffer rather
30821 -- than placing the string in the name buffer.
30823 ------------------------------
30824 -- Add_Config_Static_String --
30825 ------------------------------
30827 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
30834 if Nkind (N) = N_Op_Concat then
30835 if Add_Config_Static_String (Left_Opnd (N)) then
30836 N := Right_Opnd (N);
30842 if Nkind (N) /= N_String_Literal then
30843 Error_Msg_N ("string literal expected for pragma argument", N);
30847 for J in 1 .. String_Length (Strval (N)) loop
30848 C := Get_String_Char (Strval (N), J);
30850 if not In_Character_Range (C) then
30852 ("string literal contains invalid wide character",
30853 Sloc (N) + 1 + Source_Ptr (J));
30857 Add_Char_To_Name_Buffer (Get_Character (C));
30862 end Add_Config_Static_String;
30864 -- Start of processing for Is_Config_Static_String
30869 return Add_Config_Static_String (Arg);
30870 end Is_Config_Static_String;
30872 -------------------------------
30873 -- Is_Elaboration_SPARK_Mode --
30874 -------------------------------
30876 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
30879 (Nkind (N) = N_Pragma
30880 and then Pragma_Name (N) = Name_SPARK_Mode
30881 and then Is_List_Member (N));
30883 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30884 -- appears in the statement part of the body.
30887 Present (Parent (N))
30888 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
30889 and then List_Containing (N) = Statements (Parent (N))
30890 and then Present (Parent (Parent (N)))
30891 and then Nkind (Parent (Parent (N))) = N_Package_Body;
30892 end Is_Elaboration_SPARK_Mode;
30894 -----------------------
30895 -- Is_Enabled_Pragma --
30896 -----------------------
30898 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
30902 if Present (Prag) then
30903 Arg := First (Pragma_Argument_Associations (Prag));
30905 if Present (Arg) then
30906 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
30908 -- The lack of a Boolean argument automatically enables the pragma
30914 -- The pragma is missing, therefore it is not enabled
30919 end Is_Enabled_Pragma;
30921 -----------------------------------------
30922 -- Is_Non_Significant_Pragma_Reference --
30923 -----------------------------------------
30925 -- This function makes use of the following static table which indicates
30926 -- whether appearance of some name in a given pragma is to be considered
30927 -- as a reference for the purposes of warnings about unreferenced objects.
30929 -- -1 indicates that appearence in any argument is significant
30930 -- 0 indicates that appearance in any argument is not significant
30931 -- +n indicates that appearance as argument n is significant, but all
30932 -- other arguments are not significant
30933 -- 9n arguments from n on are significant, before n insignificant
30935 Sig_Flags : constant array (Pragma_Id) of Int :=
30936 (Pragma_Abort_Defer => -1,
30937 Pragma_Abstract_State => -1,
30938 Pragma_Acc_Data => 0,
30939 Pragma_Acc_Kernels => 0,
30940 Pragma_Acc_Loop => 0,
30941 Pragma_Acc_Parallel => 0,
30942 Pragma_Ada_83 => -1,
30943 Pragma_Ada_95 => -1,
30944 Pragma_Ada_05 => -1,
30945 Pragma_Ada_2005 => -1,
30946 Pragma_Ada_12 => -1,
30947 Pragma_Ada_2012 => -1,
30948 Pragma_Ada_2020 => -1,
30949 Pragma_All_Calls_Remote => -1,
30950 Pragma_Allow_Integer_Address => -1,
30951 Pragma_Annotate => 93,
30952 Pragma_Assert => -1,
30953 Pragma_Assert_And_Cut => -1,
30954 Pragma_Assertion_Policy => 0,
30955 Pragma_Assume => -1,
30956 Pragma_Assume_No_Invalid_Values => 0,
30957 Pragma_Async_Readers => 0,
30958 Pragma_Async_Writers => 0,
30959 Pragma_Asynchronous => 0,
30960 Pragma_Atomic => 0,
30961 Pragma_Atomic_Components => 0,
30962 Pragma_Attach_Handler => -1,
30963 Pragma_Attribute_Definition => 92,
30964 Pragma_Check => -1,
30965 Pragma_Check_Float_Overflow => 0,
30966 Pragma_Check_Name => 0,
30967 Pragma_Check_Policy => 0,
30968 Pragma_CPP_Class => 0,
30969 Pragma_CPP_Constructor => 0,
30970 Pragma_CPP_Virtual => 0,
30971 Pragma_CPP_Vtable => 0,
30973 Pragma_C_Pass_By_Copy => 0,
30974 Pragma_Comment => -1,
30975 Pragma_Common_Object => 0,
30976 Pragma_Compile_Time_Error => -1,
30977 Pragma_Compile_Time_Warning => -1,
30978 Pragma_Compiler_Unit => -1,
30979 Pragma_Compiler_Unit_Warning => -1,
30980 Pragma_Complete_Representation => 0,
30981 Pragma_Complex_Representation => 0,
30982 Pragma_Component_Alignment => 0,
30983 Pragma_Constant_After_Elaboration => 0,
30984 Pragma_Contract_Cases => -1,
30985 Pragma_Controlled => 0,
30986 Pragma_Convention => 0,
30987 Pragma_Convention_Identifier => 0,
30988 Pragma_Deadline_Floor => -1,
30989 Pragma_Debug => -1,
30990 Pragma_Debug_Policy => 0,
30991 Pragma_Detect_Blocking => 0,
30992 Pragma_Default_Initial_Condition => -1,
30993 Pragma_Default_Scalar_Storage_Order => 0,
30994 Pragma_Default_Storage_Pool => 0,
30995 Pragma_Depends => -1,
30996 Pragma_Disable_Atomic_Synchronization => 0,
30997 Pragma_Discard_Names => 0,
30998 Pragma_Dispatching_Domain => -1,
30999 Pragma_Effective_Reads => 0,
31000 Pragma_Effective_Writes => 0,
31001 Pragma_Elaborate => 0,
31002 Pragma_Elaborate_All => 0,
31003 Pragma_Elaborate_Body => 0,
31004 Pragma_Elaboration_Checks => 0,
31005 Pragma_Eliminate => 0,
31006 Pragma_Enable_Atomic_Synchronization => 0,
31007 Pragma_Export => -1,
31008 Pragma_Export_Function => -1,
31009 Pragma_Export_Object => -1,
31010 Pragma_Export_Procedure => -1,
31011 Pragma_Export_Value => -1,
31012 Pragma_Export_Valued_Procedure => -1,
31013 Pragma_Extend_System => -1,
31014 Pragma_Extensions_Allowed => 0,
31015 Pragma_Extensions_Visible => 0,
31016 Pragma_External => -1,
31017 Pragma_Favor_Top_Level => 0,
31018 Pragma_External_Name_Casing => 0,
31019 Pragma_Fast_Math => 0,
31020 Pragma_Finalize_Storage_Only => 0,
31022 Pragma_Global => -1,
31023 Pragma_Ident => -1,
31024 Pragma_Ignore_Pragma => 0,
31025 Pragma_Implementation_Defined => -1,
31026 Pragma_Implemented => -1,
31027 Pragma_Implicit_Packing => 0,
31028 Pragma_Import => 93,
31029 Pragma_Import_Function => 0,
31030 Pragma_Import_Object => 0,
31031 Pragma_Import_Procedure => 0,
31032 Pragma_Import_Valued_Procedure => 0,
31033 Pragma_Independent => 0,
31034 Pragma_Independent_Components => 0,
31035 Pragma_Initial_Condition => -1,
31036 Pragma_Initialize_Scalars => 0,
31037 Pragma_Initializes => -1,
31038 Pragma_Inline => 0,
31039 Pragma_Inline_Always => 0,
31040 Pragma_Inline_Generic => 0,
31041 Pragma_Inspection_Point => -1,
31042 Pragma_Interface => 92,
31043 Pragma_Interface_Name => 0,
31044 Pragma_Interrupt_Handler => -1,
31045 Pragma_Interrupt_Priority => -1,
31046 Pragma_Interrupt_State => -1,
31047 Pragma_Invariant => -1,
31048 Pragma_Keep_Names => 0,
31049 Pragma_License => 0,
31050 Pragma_Link_With => -1,
31051 Pragma_Linker_Alias => -1,
31052 Pragma_Linker_Constructor => -1,
31053 Pragma_Linker_Destructor => -1,
31054 Pragma_Linker_Options => -1,
31055 Pragma_Linker_Section => -1,
31057 Pragma_Lock_Free => 0,
31058 Pragma_Locking_Policy => 0,
31059 Pragma_Loop_Invariant => -1,
31060 Pragma_Loop_Optimize => 0,
31061 Pragma_Loop_Variant => -1,
31062 Pragma_Machine_Attribute => -1,
31064 Pragma_Main_Storage => -1,
31065 Pragma_Max_Entry_Queue_Depth => 0,
31066 Pragma_Max_Entry_Queue_Length => 0,
31067 Pragma_Max_Queue_Length => 0,
31068 Pragma_Memory_Size => 0,
31069 Pragma_No_Body => 0,
31070 Pragma_No_Caching => 0,
31071 Pragma_No_Component_Reordering => -1,
31072 Pragma_No_Elaboration_Code_All => 0,
31073 Pragma_No_Heap_Finalization => 0,
31074 Pragma_No_Inline => 0,
31075 Pragma_No_Return => 0,
31076 Pragma_No_Run_Time => -1,
31077 Pragma_No_Strict_Aliasing => -1,
31078 Pragma_No_Tagged_Streams => 0,
31079 Pragma_Normalize_Scalars => 0,
31080 Pragma_Obsolescent => 0,
31081 Pragma_Optimize => 0,
31082 Pragma_Optimize_Alignment => 0,
31083 Pragma_Overflow_Mode => 0,
31084 Pragma_Overriding_Renamings => 0,
31085 Pragma_Ordered => 0,
31088 Pragma_Part_Of => 0,
31089 Pragma_Partition_Elaboration_Policy => 0,
31090 Pragma_Passive => 0,
31091 Pragma_Persistent_BSS => 0,
31092 Pragma_Polling => 0,
31093 Pragma_Prefix_Exception_Messages => 0,
31095 Pragma_Postcondition => -1,
31096 Pragma_Post_Class => -1,
31098 Pragma_Precondition => -1,
31099 Pragma_Predicate => -1,
31100 Pragma_Predicate_Failure => -1,
31101 Pragma_Preelaborable_Initialization => -1,
31102 Pragma_Preelaborate => 0,
31103 Pragma_Pre_Class => -1,
31104 Pragma_Priority => -1,
31105 Pragma_Priority_Specific_Dispatching => 0,
31106 Pragma_Profile => 0,
31107 Pragma_Profile_Warnings => 0,
31108 Pragma_Propagate_Exceptions => 0,
31109 Pragma_Provide_Shift_Operators => 0,
31110 Pragma_Psect_Object => 0,
31112 Pragma_Pure_Function => 0,
31113 Pragma_Queuing_Policy => 0,
31114 Pragma_Rational => 0,
31115 Pragma_Ravenscar => 0,
31116 Pragma_Refined_Depends => -1,
31117 Pragma_Refined_Global => -1,
31118 Pragma_Refined_Post => -1,
31119 Pragma_Refined_State => -1,
31120 Pragma_Relative_Deadline => 0,
31121 Pragma_Rename_Pragma => 0,
31122 Pragma_Remote_Access_Type => -1,
31123 Pragma_Remote_Call_Interface => -1,
31124 Pragma_Remote_Types => -1,
31125 Pragma_Restricted_Run_Time => 0,
31126 Pragma_Restriction_Warnings => 0,
31127 Pragma_Restrictions => 0,
31128 Pragma_Reviewable => -1,
31129 Pragma_Secondary_Stack_Size => -1,
31130 Pragma_Short_Circuit_And_Or => 0,
31131 Pragma_Share_Generic => 0,
31132 Pragma_Shared => 0,
31133 Pragma_Shared_Passive => 0,
31134 Pragma_Short_Descriptors => 0,
31135 Pragma_Simple_Storage_Pool_Type => 0,
31136 Pragma_Source_File_Name => 0,
31137 Pragma_Source_File_Name_Project => 0,
31138 Pragma_Source_Reference => 0,
31139 Pragma_SPARK_Mode => 0,
31140 Pragma_Storage_Size => -1,
31141 Pragma_Storage_Unit => 0,
31142 Pragma_Static_Elaboration_Desired => 0,
31143 Pragma_Stream_Convert => 0,
31144 Pragma_Style_Checks => 0,
31145 Pragma_Subtitle => 0,
31146 Pragma_Suppress => 0,
31147 Pragma_Suppress_Exception_Locations => 0,
31148 Pragma_Suppress_All => 0,
31149 Pragma_Suppress_Debug_Info => 0,
31150 Pragma_Suppress_Initialization => 0,
31151 Pragma_System_Name => 0,
31152 Pragma_Task_Dispatching_Policy => 0,
31153 Pragma_Task_Info => -1,
31154 Pragma_Task_Name => -1,
31155 Pragma_Task_Storage => -1,
31156 Pragma_Test_Case => -1,
31157 Pragma_Thread_Local_Storage => -1,
31158 Pragma_Time_Slice => -1,
31160 Pragma_Type_Invariant => -1,
31161 Pragma_Type_Invariant_Class => -1,
31162 Pragma_Unchecked_Union => 0,
31163 Pragma_Unevaluated_Use_Of_Old => 0,
31164 Pragma_Unimplemented_Unit => 0,
31165 Pragma_Universal_Aliasing => 0,
31166 Pragma_Universal_Data => 0,
31167 Pragma_Unmodified => 0,
31168 Pragma_Unreferenced => 0,
31169 Pragma_Unreferenced_Objects => 0,
31170 Pragma_Unreserve_All_Interrupts => 0,
31171 Pragma_Unsuppress => 0,
31172 Pragma_Unused => 0,
31173 Pragma_Use_VADS_Size => 0,
31174 Pragma_Validity_Checks => 0,
31175 Pragma_Volatile => 0,
31176 Pragma_Volatile_Components => 0,
31177 Pragma_Volatile_Full_Access => 0,
31178 Pragma_Volatile_Function => 0,
31179 Pragma_Warning_As_Error => 0,
31180 Pragma_Warnings => 0,
31181 Pragma_Weak_External => 0,
31182 Pragma_Wide_Character_Encoding => 0,
31183 Unknown_Pragma => 0);
31185 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
31191 function Arg_No return Nat;
31192 -- Returns an integer showing what argument we are in. A value of
31193 -- zero means we are not in any of the arguments.
31199 function Arg_No return Nat is
31204 A := First (Pragma_Argument_Associations (Parent (P)));
31218 -- Start of processing for Non_Significant_Pragma_Reference
31223 if Nkind (P) /= N_Pragma_Argument_Association then
31227 Id := Get_Pragma_Id (Parent (P));
31228 C := Sig_Flags (Id);
31243 return AN < (C - 90);
31249 end Is_Non_Significant_Pragma_Reference;
31251 ------------------------------
31252 -- Is_Pragma_String_Literal --
31253 ------------------------------
31255 -- This function returns true if the corresponding pragma argument is a
31256 -- static string expression. These are the only cases in which string
31257 -- literals can appear as pragma arguments. We also allow a string literal
31258 -- as the first argument to pragma Assert (although it will of course
31259 -- always generate a type error).
31261 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
31262 Pragn : constant Node_Id := Parent (Par);
31263 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
31264 Pname : constant Name_Id := Pragma_Name (Pragn);
31270 N := First (Assoc);
31277 if Pname = Name_Assert then
31280 elsif Pname = Name_Export then
31283 elsif Pname = Name_Ident then
31286 elsif Pname = Name_Import then
31289 elsif Pname = Name_Interface_Name then
31292 elsif Pname = Name_Linker_Alias then
31295 elsif Pname = Name_Linker_Section then
31298 elsif Pname = Name_Machine_Attribute then
31301 elsif Pname = Name_Source_File_Name then
31304 elsif Pname = Name_Source_Reference then
31307 elsif Pname = Name_Title then
31310 elsif Pname = Name_Subtitle then
31316 end Is_Pragma_String_Literal;
31318 ---------------------------
31319 -- Is_Private_SPARK_Mode --
31320 ---------------------------
31322 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
31325 (Nkind (N) = N_Pragma
31326 and then Pragma_Name (N) = Name_SPARK_Mode
31327 and then Is_List_Member (N));
31329 -- For pragma SPARK_Mode to be private, it has to appear in the private
31330 -- declarations of a package.
31333 Present (Parent (N))
31334 and then Nkind (Parent (N)) = N_Package_Specification
31335 and then List_Containing (N) = Private_Declarations (Parent (N));
31336 end Is_Private_SPARK_Mode;
31338 -------------------------------------
31339 -- Is_Unconstrained_Or_Tagged_Item --
31340 -------------------------------------
31342 function Is_Unconstrained_Or_Tagged_Item
31343 (Item : Entity_Id) return Boolean
31345 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
31346 -- Determine whether record type Typ has at least one unconstrained
31349 ---------------------------------
31350 -- Has_Unconstrained_Component --
31351 ---------------------------------
31353 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
31357 Comp := First_Component (Typ);
31358 while Present (Comp) loop
31359 if Is_Unconstrained_Or_Tagged_Item (Comp) then
31363 Next_Component (Comp);
31367 end Has_Unconstrained_Component;
31371 Typ : constant Entity_Id := Etype (Item);
31373 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31376 if Is_Tagged_Type (Typ) then
31379 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
31382 elsif Is_Record_Type (Typ) then
31383 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
31386 return Has_Unconstrained_Component (Typ);
31389 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
31395 end Is_Unconstrained_Or_Tagged_Item;
31397 -----------------------------
31398 -- Is_Valid_Assertion_Kind --
31399 -----------------------------
31401 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
31408 | Name_Assertion_Policy
31409 | Name_Static_Predicate
31410 | Name_Dynamic_Predicate
31415 | Name_Type_Invariant
31416 | Name_uType_Invariant
31420 | Name_Assert_And_Cut
31422 | Name_Contract_Cases
31424 | Name_Default_Initial_Condition
31426 | Name_Initial_Condition
31429 | Name_Loop_Invariant
31430 | Name_Loop_Variant
31431 | Name_Postcondition
31432 | Name_Precondition
31434 | Name_Refined_Post
31435 | Name_Statement_Assertions
31442 end Is_Valid_Assertion_Kind;
31444 --------------------------------------
31445 -- Process_Compilation_Unit_Pragmas --
31446 --------------------------------------
31448 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
31450 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31451 -- strange because it comes at the end of the unit. Rational has the
31452 -- same name for a pragma, but treats it as a program unit pragma, In
31453 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31454 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31455 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31456 -- the context clause to ensure the correct processing.
31458 if Has_Pragma_Suppress_All (N) then
31459 Prepend_To (Context_Items (N),
31460 Make_Pragma (Sloc (N),
31461 Chars => Name_Suppress,
31462 Pragma_Argument_Associations => New_List (
31463 Make_Pragma_Argument_Association (Sloc (N),
31464 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
31467 -- Nothing else to do at the current time
31469 end Process_Compilation_Unit_Pragmas;
31471 -------------------------------------------
31472 -- Process_Compile_Time_Warning_Or_Error --
31473 -------------------------------------------
31475 procedure Process_Compile_Time_Warning_Or_Error
31479 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
31480 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
31481 Arg2 : constant Node_Id := Next (Arg1);
31484 Analyze_And_Resolve (Arg1x, Standard_Boolean);
31486 if Compile_Time_Known_Value (Arg1x) then
31487 if Is_True (Expr_Value (Arg1x)) then
31489 -- We have already verified that the second argument is a static
31490 -- string expression. Its string value must be retrieved
31491 -- explicitly if it is a declared constant, otherwise it has
31492 -- been constant-folded previously.
31495 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
31496 Pname : constant Name_Id := Pragma_Name_Unmapped (N);
31497 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
31498 Str : constant String_Id :=
31499 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)));
31500 Str_Len : constant Nat := String_Length (Str);
31502 Force : constant Boolean :=
31503 Prag_Id = Pragma_Compile_Time_Warning
31504 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
31505 and then (Ekind (Cent) /= E_Package
31506 or else not In_Private_Part (Cent));
31507 -- Set True if this is the warning case, and we are in the
31508 -- visible part of a package spec, or in a subprogram spec,
31509 -- in which case we want to force the client to see the
31510 -- warning, even though it is not in the main unit.
31518 -- Loop through segments of message separated by line feeds.
31519 -- We output these segments as separate messages with
31520 -- continuation marks for all but the first.
31525 Error_Msg_Strlen := 0;
31527 -- Loop to copy characters from argument to error message
31531 exit when Ptr > Str_Len;
31532 CC := Get_String_Char (Str, Ptr);
31535 -- Ignore wide chars ??? else store character
31537 if In_Character_Range (CC) then
31538 C := Get_Character (CC);
31539 exit when C = ASCII.LF;
31540 Error_Msg_Strlen := Error_Msg_Strlen + 1;
31541 Error_Msg_String (Error_Msg_Strlen) := C;
31545 -- Here with one line ready to go
31547 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
31549 -- If this is a warning in a spec, then we want clients
31550 -- to see the warning, so mark the message with the
31551 -- special sequence !! to force the warning. In the case
31552 -- of a package spec, we do not force this if we are in
31553 -- the private part of the spec.
31556 if Cont = False then
31557 Error_Msg ("<<~!!", Eloc);
31560 Error_Msg ("\<<~!!", Eloc);
31563 -- Error, rather than warning, or in a body, so we do not
31564 -- need to force visibility for client (error will be
31565 -- output in any case, and this is the situation in which
31566 -- we do not want a client to get a warning, since the
31567 -- warning is in the body or the spec private part).
31570 if Cont = False then
31571 Error_Msg ("<<~", Eloc);
31574 Error_Msg ("\<<~", Eloc);
31578 exit when Ptr > Str_Len;
31583 end Process_Compile_Time_Warning_Or_Error;
31585 ------------------------------------
31586 -- Record_Possible_Body_Reference --
31587 ------------------------------------
31589 procedure Record_Possible_Body_Reference
31590 (State_Id : Entity_Id;
31594 Spec_Id : Entity_Id;
31597 -- Ensure that we are dealing with a reference to a state
31599 pragma Assert (Ekind (State_Id) = E_Abstract_State);
31601 -- Climb the tree starting from the reference looking for a package body
31602 -- whose spec declares the referenced state. This criteria automatically
31603 -- excludes references in package specs which are legal. Note that it is
31604 -- not wise to emit an error now as the package body may lack pragma
31605 -- Refined_State or the referenced state may not be mentioned in the
31606 -- refinement. This approach avoids the generation of misleading errors.
31609 while Present (Context) loop
31610 if Nkind (Context) = N_Package_Body then
31611 Spec_Id := Corresponding_Spec (Context);
31613 if Present (Abstract_States (Spec_Id))
31614 and then Contains (Abstract_States (Spec_Id), State_Id)
31616 if No (Body_References (State_Id)) then
31617 Set_Body_References (State_Id, New_Elmt_List);
31620 Append_Elmt (Ref, To => Body_References (State_Id));
31625 Context := Parent (Context);
31627 end Record_Possible_Body_Reference;
31629 ------------------------------------------
31630 -- Relocate_Pragmas_To_Anonymous_Object --
31631 ------------------------------------------
31633 procedure Relocate_Pragmas_To_Anonymous_Object
31634 (Typ_Decl : Node_Id;
31635 Obj_Decl : Node_Id)
31639 Next_Decl : Node_Id;
31642 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
31643 Def := Protected_Definition (Typ_Decl);
31645 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
31646 Def := Task_Definition (Typ_Decl);
31649 -- The concurrent definition has a visible declaration list. Inspect it
31650 -- and relocate all canidate pragmas.
31652 if Present (Def) and then Present (Visible_Declarations (Def)) then
31653 Decl := First (Visible_Declarations (Def));
31654 while Present (Decl) loop
31656 -- Preserve the following declaration for iteration purposes due
31657 -- to possible relocation of a pragma.
31659 Next_Decl := Next (Decl);
31661 if Nkind (Decl) = N_Pragma
31662 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
31665 Insert_After (Obj_Decl, Decl);
31667 -- Skip internally generated code
31669 elsif not Comes_From_Source (Decl) then
31672 -- No candidate pragmas are available for relocation
31681 end Relocate_Pragmas_To_Anonymous_Object;
31683 ------------------------------
31684 -- Relocate_Pragmas_To_Body --
31685 ------------------------------
31687 procedure Relocate_Pragmas_To_Body
31688 (Subp_Body : Node_Id;
31689 Target_Body : Node_Id := Empty)
31691 procedure Relocate_Pragma (Prag : Node_Id);
31692 -- Remove a single pragma from its current list and add it to the
31693 -- declarations of the proper body (either Subp_Body or Target_Body).
31695 ---------------------
31696 -- Relocate_Pragma --
31697 ---------------------
31699 procedure Relocate_Pragma (Prag : Node_Id) is
31704 -- When subprogram stubs or expression functions are involves, the
31705 -- destination declaration list belongs to the proper body.
31707 if Present (Target_Body) then
31708 Target := Target_Body;
31710 Target := Subp_Body;
31713 Decls := Declarations (Target);
31717 Set_Declarations (Target, Decls);
31720 -- Unhook the pragma from its current list
31723 Prepend (Prag, Decls);
31724 end Relocate_Pragma;
31728 Body_Id : constant Entity_Id :=
31729 Defining_Unit_Name (Specification (Subp_Body));
31730 Next_Stmt : Node_Id;
31733 -- Start of processing for Relocate_Pragmas_To_Body
31736 -- Do not process a body that comes from a separate unit as no construct
31737 -- can possibly follow it.
31739 if not Is_List_Member (Subp_Body) then
31742 -- Do not relocate pragmas that follow a stub if the stub does not have
31745 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
31746 and then No (Target_Body)
31750 -- Do not process internally generated routine _Postconditions
31752 elsif Ekind (Body_Id) = E_Procedure
31753 and then Chars (Body_Id) = Name_uPostconditions
31758 -- Look at what is following the body. We are interested in certain kind
31759 -- of pragmas (either from source or byproducts of expansion) that can
31760 -- apply to a body [stub].
31762 Stmt := Next (Subp_Body);
31763 while Present (Stmt) loop
31765 -- Preserve the following statement for iteration purposes due to a
31766 -- possible relocation of a pragma.
31768 Next_Stmt := Next (Stmt);
31770 -- Move a candidate pragma following the body to the declarations of
31773 if Nkind (Stmt) = N_Pragma
31774 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
31777 -- If a source pragma Warnings follows the body, it applies to
31778 -- following statements and does not belong in the body.
31780 if Get_Pragma_Id (Stmt) = Pragma_Warnings
31781 and then Comes_From_Source (Stmt)
31785 Relocate_Pragma (Stmt);
31788 -- Skip internally generated code
31790 elsif not Comes_From_Source (Stmt) then
31793 -- No candidate pragmas are available for relocation
31801 end Relocate_Pragmas_To_Body;
31803 -------------------
31804 -- Resolve_State --
31805 -------------------
31807 procedure Resolve_State (N : Node_Id) is
31812 if Is_Entity_Name (N) and then Present (Entity (N)) then
31813 Func := Entity (N);
31815 -- Handle overloading of state names by functions. Traverse the
31816 -- homonym chain looking for an abstract state.
31818 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
31819 pragma Assert (Is_Overloaded (N));
31821 State := Homonym (Func);
31822 while Present (State) loop
31823 if Ekind (State) = E_Abstract_State then
31825 -- Resolve the overloading by setting the proper entity of
31826 -- the reference to that of the state.
31828 Set_Etype (N, Standard_Void_Type);
31829 Set_Entity (N, State);
31830 Set_Is_Overloaded (N, False);
31832 Generate_Reference (State, N);
31836 State := Homonym (State);
31839 -- A function can never act as a state. If the homonym chain does
31840 -- not contain a corresponding state, then something went wrong in
31841 -- the overloading mechanism.
31843 raise Program_Error;
31848 ----------------------------
31849 -- Rewrite_Assertion_Kind --
31850 ----------------------------
31852 procedure Rewrite_Assertion_Kind
31854 From_Policy : Boolean := False)
31860 if Nkind (N) = N_Attribute_Reference
31861 and then Attribute_Name (N) = Name_Class
31862 and then Nkind (Prefix (N)) = N_Identifier
31864 case Chars (Prefix (N)) is
31871 when Name_Type_Invariant =>
31872 Nam := Name_uType_Invariant;
31874 when Name_Invariant =>
31875 Nam := Name_uInvariant;
31881 -- Recommend standard use of aspect names Pre/Post
31883 elsif Nkind (N) = N_Identifier
31884 and then From_Policy
31885 and then Serious_Errors_Detected = 0
31886 and then not ASIS_Mode
31888 if Chars (N) = Name_Precondition
31889 or else Chars (N) = Name_Postcondition
31891 Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
31893 ("\use Assertion_Policy and aspect names Pre/Post for "
31894 & "Ada2012 conformance?", N);
31900 if Nam /= No_Name then
31901 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
31903 end Rewrite_Assertion_Kind;
31911 Dummy := Dummy + 1;
31914 --------------------------------
31915 -- Set_Encoded_Interface_Name --
31916 --------------------------------
31918 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
31919 Str : constant String_Id := Strval (S);
31920 Len : constant Nat := String_Length (Str);
31925 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
31928 -- Stores encoded value of character code CC. The encoding we use an
31929 -- underscore followed by four lower case hex digits.
31935 procedure Encode is
31937 Store_String_Char (Get_Char_Code ('_'));
31939 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
31941 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
31943 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
31945 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
31948 -- Start of processing for Set_Encoded_Interface_Name
31951 -- If first character is asterisk, this is a link name, and we leave it
31952 -- completely unmodified. We also ignore null strings (the latter case
31953 -- happens only in error cases).
31956 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
31958 Set_Interface_Name (E, S);
31963 CC := Get_String_Char (Str, J);
31965 exit when not In_Character_Range (CC);
31967 C := Get_Character (CC);
31969 exit when C /= '_' and then C /= '$'
31970 and then C not in '0' .. '9'
31971 and then C not in 'a' .. 'z'
31972 and then C not in 'A' .. 'Z';
31975 Set_Interface_Name (E, S);
31983 -- Here we need to encode. The encoding we use as follows:
31984 -- three underscores + four hex digits (lower case)
31988 for J in 1 .. String_Length (Str) loop
31989 CC := Get_String_Char (Str, J);
31991 if not In_Character_Range (CC) then
31994 C := Get_Character (CC);
31996 if C = '_' or else C = '$'
31997 or else C in '0' .. '9'
31998 or else C in 'a' .. 'z'
31999 or else C in 'A' .. 'Z'
32001 Store_String_Char (CC);
32008 Set_Interface_Name (E,
32009 Make_String_Literal (Sloc (S),
32010 Strval => End_String));
32012 end Set_Encoded_Interface_Name;
32014 ------------------------
32015 -- Set_Elab_Unit_Name --
32016 ------------------------
32018 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
32023 if Nkind (N) = N_Identifier
32024 and then Nkind (With_Item) = N_Identifier
32026 Set_Entity (N, Entity (With_Item));
32028 elsif Nkind (N) = N_Selected_Component then
32029 Change_Selected_Component_To_Expanded_Name (N);
32030 Set_Entity (N, Entity (With_Item));
32031 Set_Entity (Selector_Name (N), Entity (N));
32033 Pref := Prefix (N);
32034 Scop := Scope (Entity (N));
32035 while Nkind (Pref) = N_Selected_Component loop
32036 Change_Selected_Component_To_Expanded_Name (Pref);
32037 Set_Entity (Selector_Name (Pref), Scop);
32038 Set_Entity (Pref, Scop);
32039 Pref := Prefix (Pref);
32040 Scop := Scope (Scop);
32043 Set_Entity (Pref, Scop);
32046 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
32047 end Set_Elab_Unit_Name;
32049 -------------------
32050 -- Test_Case_Arg --
32051 -------------------
32053 function Test_Case_Arg
32056 From_Aspect : Boolean := False) return Node_Id
32058 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
32063 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
32068 -- The caller requests the aspect argument
32070 if From_Aspect then
32071 if Present (Aspect)
32072 and then Nkind (Expression (Aspect)) = N_Aggregate
32074 Args := Expression (Aspect);
32076 -- "Name" and "Mode" may appear without an identifier as a
32077 -- positional association.
32079 if Present (Expressions (Args)) then
32080 Arg := First (Expressions (Args));
32082 if Present (Arg) and then Arg_Nam = Name_Name then
32090 if Present (Arg) and then Arg_Nam = Name_Mode then
32095 -- Some or all arguments may appear as component associatons
32097 if Present (Component_Associations (Args)) then
32098 Arg := First (Component_Associations (Args));
32099 while Present (Arg) loop
32100 if Chars (First (Choices (Arg))) = Arg_Nam then
32109 -- Otherwise retrieve the argument directly from the pragma
32112 Arg := First (Pragma_Argument_Associations (Prag));
32114 if Present (Arg) and then Arg_Nam = Name_Name then
32118 -- Skip argument "Name"
32122 if Present (Arg) and then Arg_Nam = Name_Mode then
32126 -- Skip argument "Mode"
32130 -- Arguments "Requires" and "Ensures" are optional and may not be
32133 while Present (Arg) loop
32134 if Chars (Arg) = Arg_Nam then
32145 -----------------------------------------
32146 -- Validate_Compile_Time_Warning_Error --
32147 -----------------------------------------
32149 procedure Validate_Compile_Time_Warning_Error (N : Node_Id) is
32151 Compile_Time_Warnings_Errors.Append
32152 (New_Val => CTWE_Entry'(Eloc => Sloc (N),
32153 Scope => Current_Scope,
32155 end Validate_Compile_Time_Warning_Error;
32157 ------------------------------------------
32158 -- Validate_Compile_Time_Warning_Errors --
32159 ------------------------------------------
32161 procedure Validate_Compile_Time_Warning_Errors is
32162 procedure Set_Scope (S : Entity_Id);
32163 -- Install all enclosing scopes of S along with S itself
32165 procedure Unset_Scope (S : Entity_Id);
32166 -- Uninstall all enclosing scopes of S along with S itself
32172 procedure Set_Scope (S : Entity_Id) is
32174 if S /= Standard_Standard then
32175 Set_Scope (Scope (S));
32185 procedure Unset_Scope (S : Entity_Id) is
32187 if S /= Standard_Standard then
32188 Unset_Scope (Scope (S));
32194 -- Start of processing for Validate_Compile_Time_Warning_Errors
32197 Expander_Mode_Save_And_Set (False);
32198 In_Compile_Time_Warning_Or_Error := True;
32200 for N in Compile_Time_Warnings_Errors.First ..
32201 Compile_Time_Warnings_Errors.Last
32204 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32207 Set_Scope (T.Scope);
32208 Reset_Analyzed_Flags (T.Prag);
32209 Process_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32210 Unset_Scope (T.Scope);
32214 In_Compile_Time_Warning_Or_Error := False;
32215 Expander_Mode_Restore;
32216 end Validate_Compile_Time_Warning_Errors;