1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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_Ch7; use Exp_Ch7;
43 with Exp_Dist; use Exp_Dist;
44 with Exp_Util; use Exp_Util;
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_Elim; use Sem_Elim;
69 with Sem_Eval; use Sem_Eval;
70 with Sem_Intr; use Sem_Intr;
71 with Sem_Mech; use Sem_Mech;
72 with Sem_Res; use Sem_Res;
73 with Sem_Type; use Sem_Type;
74 with Sem_Util; use Sem_Util;
75 with Sem_Warn; use Sem_Warn;
76 with Stand; use Stand;
77 with Sinfo; use Sinfo;
78 with Sinfo.CN; use Sinfo.CN;
79 with Sinput; use Sinput;
80 with Stringt; use Stringt;
81 with Stylesw; use Stylesw;
83 with Targparm; use Targparm;
84 with Tbuild; use Tbuild;
86 with Uintp; use Uintp;
87 with Uname; use Uname;
88 with Urealp; use Urealp;
89 with Validsw; use Validsw;
90 with Warnsw; use Warnsw;
92 with GNAT.HTable; use GNAT.HTable;
94 package body Sem_Prag is
96 ----------------------------------------------
97 -- Common Handling of Import-Export Pragmas --
98 ----------------------------------------------
100 -- In the following section, a number of Import_xxx and Export_xxx pragmas
101 -- are defined by GNAT. These are compatible with the DEC pragmas of the
102 -- same name, and all have the following common form and processing:
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
110 -- [Internal =>] LOCAL_NAME
111 -- [, [External =>] EXTERNAL_SYMBOL]
112 -- [, other optional parameters ]);
114 -- EXTERNAL_SYMBOL ::=
116 -- | static_string_EXPRESSION
118 -- The internal LOCAL_NAME designates the entity that is imported or
119 -- exported, and must refer to an entity in the current declarative
120 -- part (as required by the rules for LOCAL_NAME).
122 -- The external linker name is designated by the External parameter if
123 -- given, or the Internal parameter if not (if there is no External
124 -- parameter, the External parameter is a copy of the Internal name).
126 -- If the External parameter is given as a string, then this string is
127 -- treated as an external name (exactly as though it had been given as an
128 -- External_Name parameter for a normal Import pragma).
130 -- If the External parameter is given as an identifier (or there is no
131 -- External parameter, so that the Internal identifier is used), then
132 -- the external name is the characters of the identifier, translated
133 -- to all lower case letters.
135 -- Note: the external name specified or implied by any of these special
136 -- Import_xxx or Export_xxx pragmas override an external or link name
137 -- specified in a previous Import or Export pragma.
139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
140 -- named notation, following the standard rules for subprogram calls, i.e.
141 -- parameters can be given in any order if named notation is used, and
142 -- positional and named notation can be mixed, subject to the rule that all
143 -- positional parameters must appear first.
145 -- Note: All these pragmas are implemented exactly following the DEC design
146 -- and implementation and are intended to be fully compatible with the use
147 -- of these pragmas in the DEC Ada compiler.
149 --------------------------------------------
150 -- Checking for Duplicated External Names --
151 --------------------------------------------
153 -- It is suspicious if two separate Export pragmas use the same external
154 -- name. The following table is used to diagnose this situation so that
155 -- an appropriate warning can be issued.
157 -- The Node_Id stored is for the N_String_Literal node created to hold
158 -- the value of the external name. The Sloc of this node is used to
159 -- cross-reference the location of the duplication.
161 package Externals is new Table.Table (
162 Table_Component_Type => Node_Id,
163 Table_Index_Type => Int,
164 Table_Low_Bound => 0,
165 Table_Initial => 100,
166 Table_Increment => 100,
167 Table_Name => "Name_Externals");
169 ---------------------------------------------------------
170 -- Handling of inherited class-wide pre/postconditions --
171 ---------------------------------------------------------
173 -- Following AI12-0113, the expression for a class-wide condition is
174 -- transformed for a subprogram that inherits it, by replacing calls
175 -- to primitive operations of the original controlling type into the
176 -- corresponding overriding operations of the derived type. The following
177 -- hash table manages this mapping, and is expanded on demand whenever
178 -- such inherited expression needs to be constructed.
180 -- The mapping is also used to check whether an inherited operation has
181 -- a condition that depends on overridden operations. For such an
182 -- operation we must create a wrapper that is then treated as a normal
183 -- overriding. In SPARK mode such operations are illegal.
185 -- For a given root type there may be several type extensions with their
186 -- own overriding operations, so at various times a given operation of
187 -- the root will be mapped into different overridings. The root type is
188 -- also mapped into the current type extension to indicate that its
189 -- operations are mapped into the overriding operations of that current
192 subtype Num_Primitives is Integer range 0 .. 510;
193 function Entity_Hash (E : Entity_Id) return Num_Primitives;
195 package Primitives_Mapping is new Gnat.HTable.Simple_Htable
196 (Header_Num => Num_Primitives,
198 Element => Entity_Id,
203 -------------------------------------
204 -- Local Subprograms and Variables --
205 -------------------------------------
207 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
208 -- This routine is used for possible casing adjustment of an explicit
209 -- external name supplied as a string literal (the node N), according to
210 -- the casing requirement of Opt.External_Name_Casing. If this is set to
211 -- As_Is, then the string literal is returned unchanged, but if it is set
212 -- to Uppercase or Lowercase, then a new string literal with appropriate
213 -- casing is constructed.
215 procedure Analyze_Part_Of
219 Encap_Id : out Entity_Id;
220 Legal : out Boolean);
221 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
222 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
223 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
224 -- package instantiation. Encap denotes the encapsulating state or single
225 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
226 -- the indicator is legal.
228 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
229 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
230 -- Query whether a particular item appears in a mixed list of nodes and
231 -- entities. It is assumed that all nodes in the list have entities.
233 procedure Check_Postcondition_Use_In_Inlined_Subprogram
235 Spec_Id : Entity_Id);
236 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
237 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
238 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
240 procedure Check_State_And_Constituent_Use
244 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
245 -- Global and Initializes. Determine whether a state from list States and a
246 -- corresponding constituent from list Constits (if any) appear in the same
247 -- context denoted by Context. If this is the case, emit an error.
249 procedure Contract_Freeze_Error
250 (Contract_Id : Entity_Id;
251 Freeze_Id : Entity_Id);
252 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
253 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
254 -- of a body which caused contract "freezing" and Contract_Id denotes the
255 -- entity of the affected contstruct.
257 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
258 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
259 -- Prag that duplicates previous pragma Prev.
261 function Find_Related_Context
263 Do_Checks : Boolean := False) return Node_Id;
264 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
265 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
266 -- Part_Of. Find the first source declaration or statement found while
267 -- traversing the previous node chain starting from pragma Prag. If flag
268 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
269 -- returns Empty when reaching the start of the node chain.
271 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
272 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
273 -- original one, following the renaming chain) is returned. Otherwise the
274 -- entity is returned unchanged. Should be in Einfo???
276 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
277 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
278 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
279 -- value of type SPARK_Mode_Type.
281 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
282 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
283 -- Determine whether dependency clause Clause is surrounded by extra
284 -- parentheses. If this is the case, issue an error message.
286 function Is_CCT_Instance
288 Context_Id : Entity_Id) return Boolean;
289 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
290 -- Global. Determine whether entity Ref_Id denotes the current instance of
291 -- a concurrent type. Context_Id denotes the associated context where the
294 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
295 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
296 -- pragma Depends. Determine whether the type of dependency item Item is
297 -- tagged, unconstrained array, unconstrained record or a record with at
298 -- least one unconstrained component.
300 procedure Record_Possible_Body_Reference
301 (State_Id : Entity_Id;
303 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
304 -- Global. Given an abstract state denoted by State_Id and a reference Ref
305 -- to it, determine whether the reference appears in a package body that
306 -- will eventually refine the state. If this is the case, record the
307 -- reference for future checks (see Analyze_Refined_State_In_Decls).
309 procedure Resolve_State (N : Node_Id);
310 -- Handle the overloading of state names by functions. When N denotes a
311 -- function, this routine finds the corresponding state and sets the entity
312 -- of N to that of the state.
314 procedure Rewrite_Assertion_Kind (N : Node_Id);
315 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
316 -- then it is rewritten as an identifier with the corresponding special
317 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
320 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
321 -- Place semantic information on the argument of an Elaborate/Elaborate_All
322 -- pragma. Entity name for unit and its parents is taken from item in
323 -- previous with_clause that mentions the unit.
325 Dummy : Integer := 0;
326 pragma Volatile (Dummy);
327 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
330 pragma No_Inline (ip);
331 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
332 -- is just to help debugging the front end. If a pragma Inspection_Point
333 -- is added to a source program, then breaking on ip will get you to that
334 -- point in the program.
337 pragma No_Inline (rv);
338 -- This is a dummy function called by the processing for pragma Reviewable.
339 -- It is there for assisting front end debugging. By placing a Reviewable
340 -- pragma in the source program, a breakpoint on rv catches this place in
341 -- the source, allowing convenient stepping to the point of interest.
343 -------------------------------
344 -- Adjust_External_Name_Case --
345 -------------------------------
347 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
351 -- Adjust case of literal if required
353 if Opt.External_Name_Exp_Casing = As_Is then
357 -- Copy existing string
363 for J in 1 .. String_Length (Strval (N)) loop
364 CC := Get_String_Char (Strval (N), J);
366 if Opt.External_Name_Exp_Casing = Uppercase
367 and then CC >= Get_Char_Code ('a')
368 and then CC <= Get_Char_Code ('z')
370 Store_String_Char (CC - 32);
372 elsif Opt.External_Name_Exp_Casing = Lowercase
373 and then CC >= Get_Char_Code ('A')
374 and then CC <= Get_Char_Code ('Z')
376 Store_String_Char (CC + 32);
379 Store_String_Char (CC);
384 Make_String_Literal (Sloc (N),
385 Strval => End_String);
387 end Adjust_External_Name_Case;
389 -----------------------------------------
390 -- Analyze_Contract_Cases_In_Decl_Part --
391 -----------------------------------------
393 procedure Analyze_Contract_Cases_In_Decl_Part
395 Freeze_Id : Entity_Id := Empty)
397 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
398 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
400 Others_Seen : Boolean := False;
401 -- This flag is set when an "others" choice is encountered. It is used
402 -- to detect multiple illegal occurrences of "others".
404 procedure Analyze_Contract_Case (CCase : Node_Id);
405 -- Verify the legality of a single contract case
407 ---------------------------
408 -- Analyze_Contract_Case --
409 ---------------------------
411 procedure Analyze_Contract_Case (CCase : Node_Id) is
412 Case_Guard : Node_Id;
415 Extra_Guard : Node_Id;
418 if Nkind (CCase) = N_Component_Association then
419 Case_Guard := First (Choices (CCase));
420 Conseq := Expression (CCase);
422 -- Each contract case must have exactly one case guard
424 Extra_Guard := Next (Case_Guard);
426 if Present (Extra_Guard) then
428 ("contract case must have exactly one case guard",
432 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
434 if Nkind (Case_Guard) = N_Others_Choice then
437 ("only one others choice allowed in contract cases",
443 elsif Others_Seen then
445 ("others must be the last choice in contract cases", N);
448 -- Preanalyze the case guard and consequence
450 if Nkind (Case_Guard) /= N_Others_Choice then
451 Errors := Serious_Errors_Detected;
452 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
454 -- Emit a clarification message when the case guard contains
455 -- at least one undefined reference, possibly due to contract
458 if Errors /= Serious_Errors_Detected
459 and then Present (Freeze_Id)
460 and then Has_Undefined_Reference (Case_Guard)
462 Contract_Freeze_Error (Spec_Id, Freeze_Id);
466 Errors := Serious_Errors_Detected;
467 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
469 -- Emit a clarification message when the consequence contains
470 -- at least one undefined reference, possibly due to contract
473 if Errors /= Serious_Errors_Detected
474 and then Present (Freeze_Id)
475 and then Has_Undefined_Reference (Conseq)
477 Contract_Freeze_Error (Spec_Id, Freeze_Id);
480 -- The contract case is malformed
483 Error_Msg_N ("wrong syntax in contract case", CCase);
485 end Analyze_Contract_Case;
489 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
491 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
494 Restore_Scope : Boolean := False;
496 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
499 -- Do not analyze the pragma multiple times
501 if Is_Analyzed_Pragma (N) then
505 -- Set the Ghost mode in effect from the pragma. Due to the delayed
506 -- analysis of the pragma, the Ghost mode at point of declaration and
507 -- point of analysis may not necessarily be the same. Use the mode in
508 -- effect at the point of declaration.
512 -- Single and multiple contract cases must appear in aggregate form. If
513 -- this is not the case, then either the parser of the analysis of the
514 -- pragma failed to produce an aggregate.
516 pragma Assert (Nkind (CCases) = N_Aggregate);
518 if Present (Component_Associations (CCases)) then
520 -- Ensure that the formal parameters are visible when analyzing all
521 -- clauses. This falls out of the general rule of aspects pertaining
522 -- to subprogram declarations.
524 if not In_Open_Scopes (Spec_Id) then
525 Restore_Scope := True;
526 Push_Scope (Spec_Id);
528 if Is_Generic_Subprogram (Spec_Id) then
529 Install_Generic_Formals (Spec_Id);
531 Install_Formals (Spec_Id);
535 CCase := First (Component_Associations (CCases));
536 while Present (CCase) loop
537 Analyze_Contract_Case (CCase);
541 if Restore_Scope then
545 -- Currently it is not possible to inline pre/postconditions on a
546 -- subprogram subject to pragma Inline_Always.
548 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
550 -- Otherwise the pragma is illegal
553 Error_Msg_N ("wrong syntax for constract cases", N);
556 Ghost_Mode := Save_Ghost_Mode;
557 Set_Is_Analyzed_Pragma (N);
558 end Analyze_Contract_Cases_In_Decl_Part;
560 ----------------------------------
561 -- Analyze_Depends_In_Decl_Part --
562 ----------------------------------
564 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
565 Loc : constant Source_Ptr := Sloc (N);
566 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
567 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
569 All_Inputs_Seen : Elist_Id := No_Elist;
570 -- A list containing the entities of all the inputs processed so far.
571 -- The list is populated with unique entities because the same input
572 -- may appear in multiple input lists.
574 All_Outputs_Seen : Elist_Id := No_Elist;
575 -- A list containing the entities of all the outputs processed so far.
576 -- The list is populated with unique entities because output items are
577 -- unique in a dependence relation.
579 Constits_Seen : Elist_Id := No_Elist;
580 -- A list containing the entities of all constituents processed so far.
581 -- It aids in detecting illegal usage of a state and a corresponding
582 -- constituent in pragma [Refinde_]Depends.
584 Global_Seen : Boolean := False;
585 -- A flag set when pragma Global has been processed
587 Null_Output_Seen : Boolean := False;
588 -- A flag used to track the legality of a null output
590 Result_Seen : Boolean := False;
591 -- A flag set when Spec_Id'Result is processed
593 States_Seen : Elist_Id := No_Elist;
594 -- A list containing the entities of all states processed so far. It
595 -- helps in detecting illegal usage of a state and a corresponding
596 -- constituent in pragma [Refined_]Depends.
598 Subp_Inputs : Elist_Id := No_Elist;
599 Subp_Outputs : Elist_Id := No_Elist;
600 -- Two lists containing the full set of inputs and output of the related
601 -- subprograms. Note that these lists contain both nodes and entities.
603 Task_Input_Seen : Boolean := False;
604 Task_Output_Seen : Boolean := False;
605 -- Flags used to track the implicit dependence of a task unit on itself
607 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
608 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
609 -- to the name buffer. The individual kinds are as follows:
610 -- E_Abstract_State - "state"
611 -- E_Constant - "constant"
612 -- E_Discriminant - "discriminant"
613 -- E_Generic_In_Out_Parameter - "generic parameter"
614 -- E_Generic_In_Parameter - "generic parameter"
615 -- E_In_Parameter - "parameter"
616 -- E_In_Out_Parameter - "parameter"
617 -- E_Loop_Parameter - "loop parameter"
618 -- E_Out_Parameter - "parameter"
619 -- E_Protected_Type - "current instance of protected type"
620 -- E_Task_Type - "current instance of task type"
621 -- E_Variable - "global"
623 procedure Analyze_Dependency_Clause
626 -- Verify the legality of a single dependency clause. Flag Is_Last
627 -- denotes whether Clause is the last clause in the relation.
629 procedure Check_Function_Return;
630 -- Verify that Funtion'Result appears as one of the outputs
631 -- (SPARK RM 6.1.5(10)).
638 -- Ensure that an item fulfills its designated input and/or output role
639 -- as specified by pragma Global (if any) or the enclosing context. If
640 -- this is not the case, emit an error. Item and Item_Id denote the
641 -- attributes of an item. Flag Is_Input should be set when item comes
642 -- from an input list. Flag Self_Ref should be set when the item is an
643 -- output and the dependency clause has operator "+".
645 procedure Check_Usage
646 (Subp_Items : Elist_Id;
647 Used_Items : Elist_Id;
649 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
650 -- error if this is not the case.
652 procedure Normalize_Clause (Clause : Node_Id);
653 -- Remove a self-dependency "+" from the input list of a clause
655 -----------------------------
656 -- Add_Item_To_Name_Buffer --
657 -----------------------------
659 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
661 if Ekind (Item_Id) = E_Abstract_State then
662 Add_Str_To_Name_Buffer ("state");
664 elsif Ekind (Item_Id) = E_Constant then
665 Add_Str_To_Name_Buffer ("constant");
667 elsif Ekind (Item_Id) = E_Discriminant then
668 Add_Str_To_Name_Buffer ("discriminant");
670 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
671 E_Generic_In_Parameter)
673 Add_Str_To_Name_Buffer ("generic parameter");
675 elsif Is_Formal (Item_Id) then
676 Add_Str_To_Name_Buffer ("parameter");
678 elsif Ekind (Item_Id) = E_Loop_Parameter then
679 Add_Str_To_Name_Buffer ("loop parameter");
681 elsif Ekind (Item_Id) = E_Protected_Type
682 or else Is_Single_Protected_Object (Item_Id)
684 Add_Str_To_Name_Buffer ("current instance of protected type");
686 elsif Ekind (Item_Id) = E_Task_Type
687 or else Is_Single_Task_Object (Item_Id)
689 Add_Str_To_Name_Buffer ("current instance of task type");
691 elsif Ekind (Item_Id) = E_Variable then
692 Add_Str_To_Name_Buffer ("global");
694 -- The routine should not be called with non-SPARK items
699 end Add_Item_To_Name_Buffer;
701 -------------------------------
702 -- Analyze_Dependency_Clause --
703 -------------------------------
705 procedure Analyze_Dependency_Clause
709 procedure Analyze_Input_List (Inputs : Node_Id);
710 -- Verify the legality of a single input list
712 procedure Analyze_Input_Output
717 Seen : in out Elist_Id;
718 Null_Seen : in out Boolean;
719 Non_Null_Seen : in out Boolean);
720 -- Verify the legality of a single input or output item. Flag
721 -- Is_Input should be set whenever Item is an input, False when it
722 -- denotes an output. Flag Self_Ref should be set when the item is an
723 -- output and the dependency clause has a "+". Flag Top_Level should
724 -- be set whenever Item appears immediately within an input or output
725 -- list. Seen is a collection of all abstract states, objects and
726 -- formals processed so far. Flag Null_Seen denotes whether a null
727 -- input or output has been encountered. Flag Non_Null_Seen denotes
728 -- whether a non-null input or output has been encountered.
730 ------------------------
731 -- Analyze_Input_List --
732 ------------------------
734 procedure Analyze_Input_List (Inputs : Node_Id) is
735 Inputs_Seen : Elist_Id := No_Elist;
736 -- A list containing the entities of all inputs that appear in the
737 -- current input list.
739 Non_Null_Input_Seen : Boolean := False;
740 Null_Input_Seen : Boolean := False;
741 -- Flags used to check the legality of an input list
746 -- Multiple inputs appear as an aggregate
748 if Nkind (Inputs) = N_Aggregate then
749 if Present (Component_Associations (Inputs)) then
751 ("nested dependency relations not allowed", Inputs);
753 elsif Present (Expressions (Inputs)) then
754 Input := First (Expressions (Inputs));
755 while Present (Input) loop
762 Null_Seen => Null_Input_Seen,
763 Non_Null_Seen => Non_Null_Input_Seen);
768 -- Syntax error, always report
771 Error_Msg_N ("malformed input dependency list", Inputs);
774 -- Process a solitary input
783 Null_Seen => Null_Input_Seen,
784 Non_Null_Seen => Non_Null_Input_Seen);
787 -- Detect an illegal dependency clause of the form
791 if Null_Output_Seen and then Null_Input_Seen then
793 ("null dependency clause cannot have a null input list",
796 end Analyze_Input_List;
798 --------------------------
799 -- Analyze_Input_Output --
800 --------------------------
802 procedure Analyze_Input_Output
807 Seen : in out Elist_Id;
808 Null_Seen : in out Boolean;
809 Non_Null_Seen : in out Boolean)
811 procedure Current_Task_Instance_Seen;
812 -- Set the appropriate global flag when the current instance of a
813 -- task unit is encountered.
815 --------------------------------
816 -- Current_Task_Instance_Seen --
817 --------------------------------
819 procedure Current_Task_Instance_Seen is
822 Task_Input_Seen := True;
824 Task_Output_Seen := True;
826 end Current_Task_Instance_Seen;
830 Is_Output : constant Boolean := not Is_Input;
834 -- Start of processing for Analyze_Input_Output
837 -- Multiple input or output items appear as an aggregate
839 if Nkind (Item) = N_Aggregate then
840 if not Top_Level then
841 SPARK_Msg_N ("nested grouping of items not allowed", Item);
843 elsif Present (Component_Associations (Item)) then
845 ("nested dependency relations not allowed", Item);
847 -- Recursively analyze the grouped items
849 elsif Present (Expressions (Item)) then
850 Grouped := First (Expressions (Item));
851 while Present (Grouped) loop
854 Is_Input => Is_Input,
855 Self_Ref => Self_Ref,
858 Null_Seen => Null_Seen,
859 Non_Null_Seen => Non_Null_Seen);
864 -- Syntax error, always report
867 Error_Msg_N ("malformed dependency list", Item);
870 -- Process attribute 'Result in the context of a dependency clause
872 elsif Is_Attribute_Result (Item) then
873 Non_Null_Seen := True;
877 -- Attribute 'Result is allowed to appear on the output side of
878 -- a dependency clause (SPARK RM 6.1.5(6)).
881 SPARK_Msg_N ("function result cannot act as input", Item);
885 ("cannot mix null and non-null dependency items", Item);
891 -- Detect multiple uses of null in a single dependency list or
892 -- throughout the whole relation. Verify the placement of a null
893 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
895 elsif Nkind (Item) = N_Null then
898 ("multiple null dependency relations not allowed", Item);
900 elsif Non_Null_Seen then
902 ("cannot mix null and non-null dependency items", Item);
910 ("null output list must be the last clause in a "
911 & "dependency relation", Item);
913 -- Catch a useless dependence of the form:
918 ("useless dependence, null depends on itself", Item);
926 Non_Null_Seen := True;
929 SPARK_Msg_N ("cannot mix null and non-null items", Item);
933 Resolve_State (Item);
935 -- Find the entity of the item. If this is a renaming, climb
936 -- the renaming chain to reach the root object. Renamings of
937 -- non-entire objects do not yield an entity (Empty).
939 Item_Id := Entity_Of (Item);
941 if Present (Item_Id) then
945 if Ekind_In (Item_Id, E_Constant,
950 -- Current instances of concurrent types
952 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
957 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
958 E_Generic_In_Parameter,
966 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
968 -- The item denotes a concurrent type. Note that single
969 -- protected/task types are not considered here because
970 -- they behave as objects in the context of pragma
971 -- [Refined_]Depends.
973 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
975 -- This use is legal as long as the concurrent type is
976 -- the current instance of an enclosing type.
978 if Is_CCT_Instance (Item_Id, Spec_Id) then
980 -- The dependence of a task unit on itself is
981 -- implicit and may or may not be explicitly
982 -- specified (SPARK RM 6.1.4).
984 if Ekind (Item_Id) = E_Task_Type then
985 Current_Task_Instance_Seen;
988 -- Otherwise this is not the current instance
992 ("invalid use of subtype mark in dependency "
996 -- The dependency of a task unit on itself is implicit
997 -- and may or may not be explicitly specified
1000 elsif Is_Single_Task_Object (Item_Id)
1001 and then Is_CCT_Instance (Item_Id, Spec_Id)
1003 Current_Task_Instance_Seen;
1006 -- Ensure that the item fulfills its role as input and/or
1007 -- output as specified by pragma Global or the enclosing
1010 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1012 -- Detect multiple uses of the same state, variable or
1013 -- formal parameter. If this is not the case, add the
1014 -- item to the list of processed relations.
1016 if Contains (Seen, Item_Id) then
1018 ("duplicate use of item &", Item, Item_Id);
1020 Append_New_Elmt (Item_Id, Seen);
1023 -- Detect illegal use of an input related to a null
1024 -- output. Such input items cannot appear in other
1025 -- input lists (SPARK RM 6.1.5(13)).
1028 and then Null_Output_Seen
1029 and then Contains (All_Inputs_Seen, Item_Id)
1032 ("input of a null output list cannot appear in "
1033 & "multiple input lists", Item);
1036 -- Add an input or a self-referential output to the list
1037 -- of all processed inputs.
1039 if Is_Input or else Self_Ref then
1040 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1043 -- State related checks (SPARK RM 6.1.5(3))
1045 if Ekind (Item_Id) = E_Abstract_State then
1047 -- Package and subprogram bodies are instantiated
1048 -- individually in a separate compiler pass. Due to
1049 -- this mode of instantiation, the refinement of a
1050 -- state may no longer be visible when a subprogram
1051 -- body contract is instantiated. Since the generic
1052 -- template is legal, do not perform this check in
1053 -- the instance to circumvent this oddity.
1055 if Is_Generic_Instance (Spec_Id) then
1058 -- An abstract state with visible refinement cannot
1059 -- appear in pragma [Refined_]Depends as its place
1060 -- must be taken by some of its constituents
1061 -- (SPARK RM 6.1.4(7)).
1063 elsif Has_Visible_Refinement (Item_Id) then
1065 ("cannot mention state & in dependence relation",
1067 SPARK_Msg_N ("\use its constituents instead", Item);
1070 -- If the reference to the abstract state appears in
1071 -- an enclosing package body that will eventually
1072 -- refine the state, record the reference for future
1076 Record_Possible_Body_Reference
1077 (State_Id => Item_Id,
1082 -- When the item renames an entire object, replace the
1083 -- item with a reference to the object.
1085 if Entity (Item) /= Item_Id then
1087 New_Occurrence_Of (Item_Id, Sloc (Item)));
1091 -- Add the entity of the current item to the list of
1094 if Ekind (Item_Id) = E_Abstract_State then
1095 Append_New_Elmt (Item_Id, States_Seen);
1097 -- The variable may eventually become a constituent of a
1098 -- single protected/task type. Record the reference now
1099 -- and verify its legality when analyzing the contract of
1100 -- the variable (SPARK RM 9.3).
1102 elsif Ekind (Item_Id) = E_Variable then
1103 Record_Possible_Part_Of_Reference
1108 if Ekind_In (Item_Id, E_Abstract_State,
1111 and then Present (Encapsulating_State (Item_Id))
1113 Append_New_Elmt (Item_Id, Constits_Seen);
1116 -- All other input/output items are illegal
1117 -- (SPARK RM 6.1.5(1)).
1121 ("item must denote parameter, variable, state or "
1122 & "current instance of concurren type", Item);
1125 -- All other input/output items are illegal
1126 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1130 ("item must denote parameter, variable, state or current "
1131 & "instance of concurrent type", Item);
1134 end Analyze_Input_Output;
1142 Non_Null_Output_Seen : Boolean := False;
1143 -- Flag used to check the legality of an output list
1145 -- Start of processing for Analyze_Dependency_Clause
1148 Inputs := Expression (Clause);
1151 -- An input list with a self-dependency appears as operator "+" where
1152 -- the actuals inputs are the right operand.
1154 if Nkind (Inputs) = N_Op_Plus then
1155 Inputs := Right_Opnd (Inputs);
1159 -- Process the output_list of a dependency_clause
1161 Output := First (Choices (Clause));
1162 while Present (Output) loop
1163 Analyze_Input_Output
1166 Self_Ref => Self_Ref,
1168 Seen => All_Outputs_Seen,
1169 Null_Seen => Null_Output_Seen,
1170 Non_Null_Seen => Non_Null_Output_Seen);
1175 -- Process the input_list of a dependency_clause
1177 Analyze_Input_List (Inputs);
1178 end Analyze_Dependency_Clause;
1180 ---------------------------
1181 -- Check_Function_Return --
1182 ---------------------------
1184 procedure Check_Function_Return is
1186 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1187 and then not Result_Seen
1190 ("result of & must appear in exactly one output list",
1193 end Check_Function_Return;
1199 procedure Check_Role
1201 Item_Id : Entity_Id;
1206 (Item_Is_Input : out Boolean;
1207 Item_Is_Output : out Boolean);
1208 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1209 -- Item_Is_Output are set depending on the role.
1211 procedure Role_Error
1212 (Item_Is_Input : Boolean;
1213 Item_Is_Output : Boolean);
1214 -- Emit an error message concerning the incorrect use of Item in
1215 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1216 -- denote whether the item is an input and/or an output.
1223 (Item_Is_Input : out Boolean;
1224 Item_Is_Output : out Boolean)
1227 Item_Is_Input := False;
1228 Item_Is_Output := False;
1232 if Ekind (Item_Id) = E_Abstract_State then
1234 -- When pragma Global is present, the mode of the state may be
1235 -- further constrained by setting a more restrictive mode.
1238 if Appears_In (Subp_Inputs, Item_Id) then
1239 Item_Is_Input := True;
1242 if Appears_In (Subp_Outputs, Item_Id) then
1243 Item_Is_Output := True;
1246 -- Otherwise the state has a default IN OUT mode
1249 Item_Is_Input := True;
1250 Item_Is_Output := True;
1255 elsif Ekind_In (Item_Id, E_Constant,
1259 Item_Is_Input := True;
1263 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1266 Item_Is_Input := True;
1268 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1271 Item_Is_Input := True;
1272 Item_Is_Output := True;
1274 elsif Ekind (Item_Id) = E_Out_Parameter then
1275 if Scope (Item_Id) = Spec_Id then
1277 -- An OUT parameter of the related subprogram has mode IN
1278 -- if its type is unconstrained or tagged because array
1279 -- bounds, discriminants or tags can be read.
1281 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1282 Item_Is_Input := True;
1285 Item_Is_Output := True;
1287 -- An OUT parameter of an enclosing subprogram behaves as a
1288 -- read-write variable in which case the mode is IN OUT.
1291 Item_Is_Input := True;
1292 Item_Is_Output := True;
1297 elsif Ekind (Item_Id) = E_Protected_Type then
1299 -- A protected type acts as a formal parameter of mode IN when
1300 -- it applies to a protected function.
1302 if Ekind (Spec_Id) = E_Function then
1303 Item_Is_Input := True;
1305 -- Otherwise the protected type acts as a formal of mode IN OUT
1308 Item_Is_Input := True;
1309 Item_Is_Output := True;
1314 elsif Ekind (Item_Id) = E_Task_Type then
1315 Item_Is_Input := True;
1316 Item_Is_Output := True;
1320 else pragma Assert (Ekind (Item_Id) = E_Variable);
1322 -- When pragma Global is present, the mode of the variable may
1323 -- be further constrained by setting a more restrictive mode.
1327 -- A variable has mode IN when its type is unconstrained or
1328 -- tagged because array bounds, discriminants or tags can be
1331 if Appears_In (Subp_Inputs, Item_Id)
1332 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1334 Item_Is_Input := True;
1337 if Appears_In (Subp_Outputs, Item_Id) then
1338 Item_Is_Output := True;
1341 -- Otherwise the variable has a default IN OUT mode
1344 Item_Is_Input := True;
1345 Item_Is_Output := True;
1354 procedure Role_Error
1355 (Item_Is_Input : Boolean;
1356 Item_Is_Output : Boolean)
1358 Error_Msg : Name_Id;
1363 -- When the item is not part of the input and the output set of
1364 -- the related subprogram, then it appears as extra in pragma
1365 -- [Refined_]Depends.
1367 if not Item_Is_Input and then not Item_Is_Output then
1368 Add_Item_To_Name_Buffer (Item_Id);
1369 Add_Str_To_Name_Buffer
1370 (" & cannot appear in dependence relation");
1372 Error_Msg := Name_Find;
1373 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1375 Error_Msg_Name_1 := Chars (Spec_Id);
1377 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1378 & "set of subprogram %"), Item, Item_Id);
1380 -- The mode of the item and its role in pragma [Refined_]Depends
1381 -- are in conflict. Construct a detailed message explaining the
1382 -- illegality (SPARK RM 6.1.5(5-6)).
1385 if Item_Is_Input then
1386 Add_Str_To_Name_Buffer ("read-only");
1388 Add_Str_To_Name_Buffer ("write-only");
1391 Add_Char_To_Name_Buffer (' ');
1392 Add_Item_To_Name_Buffer (Item_Id);
1393 Add_Str_To_Name_Buffer (" & cannot appear as ");
1395 if Item_Is_Input then
1396 Add_Str_To_Name_Buffer ("output");
1398 Add_Str_To_Name_Buffer ("input");
1401 Add_Str_To_Name_Buffer (" in dependence relation");
1402 Error_Msg := Name_Find;
1403 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1409 Item_Is_Input : Boolean;
1410 Item_Is_Output : Boolean;
1412 -- Start of processing for Check_Role
1415 Find_Role (Item_Is_Input, Item_Is_Output);
1420 if not Item_Is_Input then
1421 Role_Error (Item_Is_Input, Item_Is_Output);
1424 -- Self-referential item
1427 if not Item_Is_Input or else not Item_Is_Output then
1428 Role_Error (Item_Is_Input, Item_Is_Output);
1433 elsif not Item_Is_Output then
1434 Role_Error (Item_Is_Input, Item_Is_Output);
1442 procedure Check_Usage
1443 (Subp_Items : Elist_Id;
1444 Used_Items : Elist_Id;
1447 procedure Usage_Error (Item_Id : Entity_Id);
1448 -- Emit an error concerning the illegal usage of an item
1454 procedure Usage_Error (Item_Id : Entity_Id) is
1455 Error_Msg : Name_Id;
1462 -- Unconstrained and tagged items are not part of the explicit
1463 -- input set of the related subprogram, they do not have to be
1464 -- present in a dependence relation and should not be flagged
1465 -- (SPARK RM 6.1.5(8)).
1467 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1470 Add_Item_To_Name_Buffer (Item_Id);
1471 Add_Str_To_Name_Buffer
1472 (" & is missing from input dependence list");
1474 Error_Msg := Name_Find;
1475 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1478 -- Output case (SPARK RM 6.1.5(10))
1483 Add_Item_To_Name_Buffer (Item_Id);
1484 Add_Str_To_Name_Buffer
1485 (" & is missing from output dependence list");
1487 Error_Msg := Name_Find;
1488 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1496 Item_Id : Entity_Id;
1498 -- Start of processing for Check_Usage
1501 if No (Subp_Items) then
1505 -- Each input or output of the subprogram must appear in a dependency
1508 Elmt := First_Elmt (Subp_Items);
1509 while Present (Elmt) loop
1510 Item := Node (Elmt);
1512 if Nkind (Item) = N_Defining_Identifier then
1515 Item_Id := Entity_Of (Item);
1518 -- The item does not appear in a dependency
1520 if Present (Item_Id)
1521 and then not Contains (Used_Items, Item_Id)
1523 if Is_Formal (Item_Id) then
1524 Usage_Error (Item_Id);
1526 -- The current instance of a protected type behaves as a formal
1527 -- parameter (SPARK RM 6.1.4).
1529 elsif Ekind (Item_Id) = E_Protected_Type
1530 or else Is_Single_Protected_Object (Item_Id)
1532 Usage_Error (Item_Id);
1534 -- The current instance of a task type behaves as a formal
1535 -- parameter (SPARK RM 6.1.4).
1537 elsif Ekind (Item_Id) = E_Task_Type
1538 or else Is_Single_Task_Object (Item_Id)
1540 -- The dependence of a task unit on itself is implicit and
1541 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1542 -- Emit an error if only one input/output is present.
1544 if Task_Input_Seen /= Task_Output_Seen then
1545 Usage_Error (Item_Id);
1548 -- States and global objects are not used properly only when
1549 -- the subprogram is subject to pragma Global.
1551 elsif Global_Seen then
1552 Usage_Error (Item_Id);
1560 ----------------------
1561 -- Normalize_Clause --
1562 ----------------------
1564 procedure Normalize_Clause (Clause : Node_Id) is
1565 procedure Create_Or_Modify_Clause
1571 Multiple : Boolean);
1572 -- Create a brand new clause to represent the self-reference or
1573 -- modify the input and/or output lists of an existing clause. Output
1574 -- denotes a self-referencial output. Outputs is the output list of a
1575 -- clause. Inputs is the input list of a clause. After denotes the
1576 -- clause after which the new clause is to be inserted. Flag In_Place
1577 -- should be set when normalizing the last output of an output list.
1578 -- Flag Multiple should be set when Output comes from a list with
1581 -----------------------------
1582 -- Create_Or_Modify_Clause --
1583 -----------------------------
1585 procedure Create_Or_Modify_Clause
1593 procedure Propagate_Output
1596 -- Handle the various cases of output propagation to the input
1597 -- list. Output denotes a self-referencial output item. Inputs
1598 -- is the input list of a clause.
1600 ----------------------
1601 -- Propagate_Output --
1602 ----------------------
1604 procedure Propagate_Output
1608 function In_Input_List
1610 Inputs : List_Id) return Boolean;
1611 -- Determine whether a particulat item appears in the input
1612 -- list of a clause.
1618 function In_Input_List
1620 Inputs : List_Id) return Boolean
1625 Elmt := First (Inputs);
1626 while Present (Elmt) loop
1627 if Entity_Of (Elmt) = Item then
1639 Output_Id : constant Entity_Id := Entity_Of (Output);
1642 -- Start of processing for Propagate_Output
1645 -- The clause is of the form:
1647 -- (Output =>+ null)
1649 -- Remove null input and replace it with a copy of the output:
1651 -- (Output => Output)
1653 if Nkind (Inputs) = N_Null then
1654 Rewrite (Inputs, New_Copy_Tree (Output));
1656 -- The clause is of the form:
1658 -- (Output =>+ (Input1, ..., InputN))
1660 -- Determine whether the output is not already mentioned in the
1661 -- input list and if not, add it to the list of inputs:
1663 -- (Output => (Output, Input1, ..., InputN))
1665 elsif Nkind (Inputs) = N_Aggregate then
1666 Grouped := Expressions (Inputs);
1668 if not In_Input_List
1672 Prepend_To (Grouped, New_Copy_Tree (Output));
1675 -- The clause is of the form:
1677 -- (Output =>+ Input)
1679 -- If the input does not mention the output, group the two
1682 -- (Output => (Output, Input))
1684 elsif Entity_Of (Inputs) /= Output_Id then
1686 Make_Aggregate (Loc,
1687 Expressions => New_List (
1688 New_Copy_Tree (Output),
1689 New_Copy_Tree (Inputs))));
1691 end Propagate_Output;
1695 Loc : constant Source_Ptr := Sloc (Clause);
1696 New_Clause : Node_Id;
1698 -- Start of processing for Create_Or_Modify_Clause
1701 -- A null output depending on itself does not require any
1704 if Nkind (Output) = N_Null then
1707 -- A function result cannot depend on itself because it cannot
1708 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1710 elsif Is_Attribute_Result (Output) then
1711 SPARK_Msg_N ("function result cannot depend on itself", Output);
1715 -- When performing the transformation in place, simply add the
1716 -- output to the list of inputs (if not already there). This
1717 -- case arises when dealing with the last output of an output
1718 -- list. Perform the normalization in place to avoid generating
1719 -- a malformed tree.
1722 Propagate_Output (Output, Inputs);
1724 -- A list with multiple outputs is slowly trimmed until only
1725 -- one element remains. When this happens, replace aggregate
1726 -- with the element itself.
1730 Rewrite (Outputs, Output);
1736 -- Unchain the output from its output list as it will appear in
1737 -- a new clause. Note that we cannot simply rewrite the output
1738 -- as null because this will violate the semantics of pragma
1743 -- Generate a new clause of the form:
1744 -- (Output => Inputs)
1747 Make_Component_Association (Loc,
1748 Choices => New_List (Output),
1749 Expression => New_Copy_Tree (Inputs));
1751 -- The new clause contains replicated content that has already
1752 -- been analyzed. There is not need to reanalyze or renormalize
1755 Set_Analyzed (New_Clause);
1758 (Output => First (Choices (New_Clause)),
1759 Inputs => Expression (New_Clause));
1761 Insert_After (After, New_Clause);
1763 end Create_Or_Modify_Clause;
1767 Outputs : constant Node_Id := First (Choices (Clause));
1769 Last_Output : Node_Id;
1770 Next_Output : Node_Id;
1773 -- Start of processing for Normalize_Clause
1776 -- A self-dependency appears as operator "+". Remove the "+" from the
1777 -- tree by moving the real inputs to their proper place.
1779 if Nkind (Expression (Clause)) = N_Op_Plus then
1780 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1781 Inputs := Expression (Clause);
1783 -- Multiple outputs appear as an aggregate
1785 if Nkind (Outputs) = N_Aggregate then
1786 Last_Output := Last (Expressions (Outputs));
1788 Output := First (Expressions (Outputs));
1789 while Present (Output) loop
1791 -- Normalization may remove an output from its list,
1792 -- preserve the subsequent output now.
1794 Next_Output := Next (Output);
1796 Create_Or_Modify_Clause
1801 In_Place => Output = Last_Output,
1804 Output := Next_Output;
1810 Create_Or_Modify_Clause
1819 end Normalize_Clause;
1823 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1824 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1828 Last_Clause : Node_Id;
1829 Restore_Scope : Boolean := False;
1831 -- Start of processing for Analyze_Depends_In_Decl_Part
1834 -- Do not analyze the pragma multiple times
1836 if Is_Analyzed_Pragma (N) then
1840 -- Empty dependency list
1842 if Nkind (Deps) = N_Null then
1844 -- Gather all states, objects and formal parameters that the
1845 -- subprogram may depend on. These items are obtained from the
1846 -- parameter profile or pragma [Refined_]Global (if available).
1848 Collect_Subprogram_Inputs_Outputs
1849 (Subp_Id => Subp_Id,
1850 Subp_Inputs => Subp_Inputs,
1851 Subp_Outputs => Subp_Outputs,
1852 Global_Seen => Global_Seen);
1854 -- Verify that every input or output of the subprogram appear in a
1857 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1858 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1859 Check_Function_Return;
1861 -- Dependency clauses appear as component associations of an aggregate
1863 elsif Nkind (Deps) = N_Aggregate then
1865 -- Do not attempt to perform analysis of a syntactically illegal
1866 -- clause as this will lead to misleading errors.
1868 if Has_Extra_Parentheses (Deps) then
1872 if Present (Component_Associations (Deps)) then
1873 Last_Clause := Last (Component_Associations (Deps));
1875 -- Gather all states, objects and formal parameters that the
1876 -- subprogram may depend on. These items are obtained from the
1877 -- parameter profile or pragma [Refined_]Global (if available).
1879 Collect_Subprogram_Inputs_Outputs
1880 (Subp_Id => Subp_Id,
1881 Subp_Inputs => Subp_Inputs,
1882 Subp_Outputs => Subp_Outputs,
1883 Global_Seen => Global_Seen);
1885 -- When pragma [Refined_]Depends appears on a single concurrent
1886 -- type, it is relocated to the anonymous object.
1888 if Is_Single_Concurrent_Object (Spec_Id) then
1891 -- Ensure that the formal parameters are visible when analyzing
1892 -- all clauses. This falls out of the general rule of aspects
1893 -- pertaining to subprogram declarations.
1895 elsif not In_Open_Scopes (Spec_Id) then
1896 Restore_Scope := True;
1897 Push_Scope (Spec_Id);
1899 if Ekind (Spec_Id) = E_Task_Type then
1900 if Has_Discriminants (Spec_Id) then
1901 Install_Discriminants (Spec_Id);
1904 elsif Is_Generic_Subprogram (Spec_Id) then
1905 Install_Generic_Formals (Spec_Id);
1908 Install_Formals (Spec_Id);
1912 Clause := First (Component_Associations (Deps));
1913 while Present (Clause) loop
1914 Errors := Serious_Errors_Detected;
1916 -- The normalization mechanism may create extra clauses that
1917 -- contain replicated input and output names. There is no need
1918 -- to reanalyze them.
1920 if not Analyzed (Clause) then
1921 Set_Analyzed (Clause);
1923 Analyze_Dependency_Clause
1925 Is_Last => Clause = Last_Clause);
1928 -- Do not normalize a clause if errors were detected (count
1929 -- of Serious_Errors has increased) because the inputs and/or
1930 -- outputs may denote illegal items. Normalization is disabled
1931 -- in ASIS mode as it alters the tree by introducing new nodes
1932 -- similar to expansion.
1934 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1935 Normalize_Clause (Clause);
1941 if Restore_Scope then
1945 -- Verify that every input or output of the subprogram appear in a
1948 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1949 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1950 Check_Function_Return;
1952 -- The dependency list is malformed. This is a syntax error, always
1956 Error_Msg_N ("malformed dependency relation", Deps);
1960 -- The top level dependency relation is malformed. This is a syntax
1961 -- error, always report.
1964 Error_Msg_N ("malformed dependency relation", Deps);
1968 -- Ensure that a state and a corresponding constituent do not appear
1969 -- together in pragma [Refined_]Depends.
1971 Check_State_And_Constituent_Use
1972 (States => States_Seen,
1973 Constits => Constits_Seen,
1977 Set_Is_Analyzed_Pragma (N);
1978 end Analyze_Depends_In_Decl_Part;
1980 --------------------------------------------
1981 -- Analyze_External_Property_In_Decl_Part --
1982 --------------------------------------------
1984 procedure Analyze_External_Property_In_Decl_Part
1986 Expr_Val : out Boolean)
1988 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1989 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1990 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1996 -- Do not analyze the pragma multiple times
1998 if Is_Analyzed_Pragma (N) then
2002 Error_Msg_Name_1 := Pragma_Name (N);
2004 -- An external property pragma must apply to an effectively volatile
2005 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2006 -- The check is performed at the end of the declarative region due to a
2007 -- possible out-of-order arrangement of pragmas:
2010 -- pragma Async_Readers (Obj);
2011 -- pragma Volatile (Obj);
2013 if not Is_Effectively_Volatile (Obj_Id) then
2015 ("external property % must apply to a volatile object", N);
2018 -- Ensure that the Boolean expression (if present) is static. A missing
2019 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2023 if Present (Arg1) then
2024 Expr := Get_Pragma_Arg (Arg1);
2026 if Is_OK_Static_Expression (Expr) then
2027 Expr_Val := Is_True (Expr_Value (Expr));
2031 Set_Is_Analyzed_Pragma (N);
2032 end Analyze_External_Property_In_Decl_Part;
2034 ---------------------------------
2035 -- Analyze_Global_In_Decl_Part --
2036 ---------------------------------
2038 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2039 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2040 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2041 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2043 Constits_Seen : Elist_Id := No_Elist;
2044 -- A list containing the entities of all constituents processed so far.
2045 -- It aids in detecting illegal usage of a state and a corresponding
2046 -- constituent in pragma [Refinde_]Global.
2048 Seen : Elist_Id := No_Elist;
2049 -- A list containing the entities of all the items processed so far. It
2050 -- plays a role in detecting distinct entities.
2052 States_Seen : Elist_Id := No_Elist;
2053 -- A list containing the entities of all states processed so far. It
2054 -- helps in detecting illegal usage of a state and a corresponding
2055 -- constituent in pragma [Refined_]Global.
2057 In_Out_Seen : Boolean := False;
2058 Input_Seen : Boolean := False;
2059 Output_Seen : Boolean := False;
2060 Proof_Seen : Boolean := False;
2061 -- Flags used to verify the consistency of modes
2063 procedure Analyze_Global_List
2065 Global_Mode : Name_Id := Name_Input);
2066 -- Verify the legality of a single global list declaration. Global_Mode
2067 -- denotes the current mode in effect.
2069 -------------------------
2070 -- Analyze_Global_List --
2071 -------------------------
2073 procedure Analyze_Global_List
2075 Global_Mode : Name_Id := Name_Input)
2077 procedure Analyze_Global_Item
2079 Global_Mode : Name_Id);
2080 -- Verify the legality of a single global item declaration denoted by
2081 -- Item. Global_Mode denotes the current mode in effect.
2083 procedure Check_Duplicate_Mode
2085 Status : in out Boolean);
2086 -- Flag Status denotes whether a particular mode has been seen while
2087 -- processing a global list. This routine verifies that Mode is not a
2088 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2090 procedure Check_Mode_Restriction_In_Enclosing_Context
2092 Item_Id : Entity_Id);
2093 -- Verify that an item of mode In_Out or Output does not appear as an
2094 -- input in the Global aspect of an enclosing subprogram. If this is
2095 -- the case, emit an error. Item and Item_Id are respectively the
2096 -- item and its entity.
2098 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2099 -- Mode denotes either In_Out or Output. Depending on the kind of the
2100 -- related subprogram, emit an error if those two modes apply to a
2101 -- function (SPARK RM 6.1.4(10)).
2103 -------------------------
2104 -- Analyze_Global_Item --
2105 -------------------------
2107 procedure Analyze_Global_Item
2109 Global_Mode : Name_Id)
2111 Item_Id : Entity_Id;
2114 -- Detect one of the following cases
2116 -- with Global => (null, Name)
2117 -- with Global => (Name_1, null, Name_2)
2118 -- with Global => (Name, null)
2120 if Nkind (Item) = N_Null then
2121 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2126 Resolve_State (Item);
2128 -- Find the entity of the item. If this is a renaming, climb the
2129 -- renaming chain to reach the root object. Renamings of non-
2130 -- entire objects do not yield an entity (Empty).
2132 Item_Id := Entity_Of (Item);
2134 if Present (Item_Id) then
2136 -- A global item may denote a formal parameter of an enclosing
2137 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2138 -- provide a better error diagnostic.
2140 if Is_Formal (Item_Id) then
2141 if Scope (Item_Id) = Spec_Id then
2143 (Fix_Msg (Spec_Id, "global item cannot reference "
2144 & "parameter of subprogram &"), Item, Spec_Id);
2148 -- A global item may denote a concurrent type as long as it is
2149 -- the current instance of an enclosing protected or task type
2150 -- (SPARK RM 6.1.4).
2152 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2153 if Is_CCT_Instance (Item_Id, Spec_Id) then
2155 -- Pragma [Refined_]Global associated with a protected
2156 -- subprogram cannot mention the current instance of a
2157 -- protected type because the instance behaves as a
2158 -- formal parameter.
2160 if Ekind (Item_Id) = E_Protected_Type then
2161 Error_Msg_Name_1 := Chars (Item_Id);
2163 (Fix_Msg (Spec_Id, "global item of subprogram & "
2164 & "cannot reference current instance of protected "
2165 & "type %"), Item, Spec_Id);
2168 -- Pragma [Refined_]Global associated with a task type
2169 -- cannot mention the current instance of a task type
2170 -- because the instance behaves as a formal parameter.
2172 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2173 Error_Msg_Name_1 := Chars (Item_Id);
2175 (Fix_Msg (Spec_Id, "global item of subprogram & "
2176 & "cannot reference current instance of task type "
2177 & "%"), Item, Spec_Id);
2181 -- Otherwise the global item denotes a subtype mark that is
2182 -- not a current instance.
2186 ("invalid use of subtype mark in global list", Item);
2190 -- A global item may denote the anonymous object created for a
2191 -- single protected/task type as long as the current instance
2192 -- is the same single type (SPARK RM 6.1.4).
2194 elsif Is_Single_Concurrent_Object (Item_Id)
2195 and then Is_CCT_Instance (Item_Id, Spec_Id)
2197 -- Pragma [Refined_]Global associated with a protected
2198 -- subprogram cannot mention the current instance of a
2199 -- protected type because the instance behaves as a formal
2202 if Is_Single_Protected_Object (Item_Id) then
2203 Error_Msg_Name_1 := Chars (Item_Id);
2205 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2206 & "reference current instance of protected type %"),
2210 -- Pragma [Refined_]Global associated with a task type
2211 -- cannot mention the current instance of a task type
2212 -- because the instance behaves as a formal parameter.
2214 else pragma Assert (Is_Single_Task_Object (Item_Id));
2215 Error_Msg_Name_1 := Chars (Item_Id);
2217 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2218 & "reference current instance of task type %"),
2223 -- A formal object may act as a global item inside a generic
2225 elsif Is_Formal_Object (Item_Id) then
2228 -- The only legal references are those to abstract states,
2229 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2231 elsif not Ekind_In (Item_Id, E_Abstract_State,
2238 ("global item must denote object, state or current "
2239 & "instance of concurrent type", Item);
2243 -- State related checks
2245 if Ekind (Item_Id) = E_Abstract_State then
2247 -- Package and subprogram bodies are instantiated
2248 -- individually in a separate compiler pass. Due to this
2249 -- mode of instantiation, the refinement of a state may
2250 -- no longer be visible when a subprogram body contract
2251 -- is instantiated. Since the generic template is legal,
2252 -- do not perform this check in the instance to circumvent
2255 if Is_Generic_Instance (Spec_Id) then
2258 -- An abstract state with visible refinement cannot appear
2259 -- in pragma [Refined_]Global as its place must be taken by
2260 -- some of its constituents (SPARK RM 6.1.4(7)).
2262 elsif Has_Visible_Refinement (Item_Id) then
2264 ("cannot mention state & in global refinement",
2266 SPARK_Msg_N ("\use its constituents instead", Item);
2269 -- An external state cannot appear as a global item of a
2270 -- nonvolatile function (SPARK RM 7.1.3(8)).
2272 elsif Is_External_State (Item_Id)
2273 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2274 and then not Is_Volatile_Function (Spec_Id)
2277 ("external state & cannot act as global item of "
2278 & "nonvolatile function", Item, Item_Id);
2281 -- If the reference to the abstract state appears in an
2282 -- enclosing package body that will eventually refine the
2283 -- state, record the reference for future checks.
2286 Record_Possible_Body_Reference
2287 (State_Id => Item_Id,
2291 -- Constant related checks
2293 elsif Ekind (Item_Id) = E_Constant then
2295 -- A constant is a read-only item, therefore it cannot act
2298 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2300 ("constant & cannot act as output", Item, Item_Id);
2304 -- Discriminant related checks
2306 elsif Ekind (Item_Id) = E_Discriminant then
2308 -- A discriminant is a read-only item, therefore it cannot
2309 -- act as an output.
2311 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2313 ("discriminant & cannot act as output", Item, Item_Id);
2317 -- Loop parameter related checks
2319 elsif Ekind (Item_Id) = E_Loop_Parameter then
2321 -- A loop parameter is a read-only item, therefore it cannot
2322 -- act as an output.
2324 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2326 ("loop parameter & cannot act as output",
2331 -- Variable related checks. These are only relevant when
2332 -- SPARK_Mode is on as they are not standard Ada legality
2335 elsif SPARK_Mode = On
2336 and then Ekind (Item_Id) = E_Variable
2337 and then Is_Effectively_Volatile (Item_Id)
2339 -- An effectively volatile object cannot appear as a global
2340 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2342 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2343 and then not Is_Volatile_Function (Spec_Id)
2346 ("volatile object & cannot act as global item of a "
2347 & "function", Item, Item_Id);
2350 -- An effectively volatile object with external property
2351 -- Effective_Reads set to True must have mode Output or
2352 -- In_Out (SPARK RM 7.1.3(10)).
2354 elsif Effective_Reads_Enabled (Item_Id)
2355 and then Global_Mode = Name_Input
2358 ("volatile object & with property Effective_Reads must "
2359 & "have mode In_Out or Output", Item, Item_Id);
2364 -- When the item renames an entire object, replace the item
2365 -- with a reference to the object.
2367 if Entity (Item) /= Item_Id then
2368 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2372 -- Some form of illegal construct masquerading as a name
2373 -- (SPARK RM 6.1.4(4)).
2377 ("global item must denote object, state or current instance "
2378 & "of concurrent type", Item);
2382 -- Verify that an output does not appear as an input in an
2383 -- enclosing subprogram.
2385 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2386 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2389 -- The same entity might be referenced through various way.
2390 -- Check the entity of the item rather than the item itself
2391 -- (SPARK RM 6.1.4(10)).
2393 if Contains (Seen, Item_Id) then
2394 SPARK_Msg_N ("duplicate global item", Item);
2396 -- Add the entity of the current item to the list of processed
2400 Append_New_Elmt (Item_Id, Seen);
2402 if Ekind (Item_Id) = E_Abstract_State then
2403 Append_New_Elmt (Item_Id, States_Seen);
2405 -- The variable may eventually become a constituent of a single
2406 -- protected/task type. Record the reference now and verify its
2407 -- legality when analyzing the contract of the variable
2410 elsif Ekind (Item_Id) = E_Variable then
2411 Record_Possible_Part_Of_Reference
2416 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2417 and then Present (Encapsulating_State (Item_Id))
2419 Append_New_Elmt (Item_Id, Constits_Seen);
2422 end Analyze_Global_Item;
2424 --------------------------
2425 -- Check_Duplicate_Mode --
2426 --------------------------
2428 procedure Check_Duplicate_Mode
2430 Status : in out Boolean)
2434 SPARK_Msg_N ("duplicate global mode", Mode);
2438 end Check_Duplicate_Mode;
2440 -------------------------------------------------
2441 -- Check_Mode_Restriction_In_Enclosing_Context --
2442 -------------------------------------------------
2444 procedure Check_Mode_Restriction_In_Enclosing_Context
2446 Item_Id : Entity_Id)
2448 Context : Entity_Id;
2450 Inputs : Elist_Id := No_Elist;
2451 Outputs : Elist_Id := No_Elist;
2454 -- Traverse the scope stack looking for enclosing subprograms
2455 -- subject to pragma [Refined_]Global.
2457 Context := Scope (Subp_Id);
2458 while Present (Context) and then Context /= Standard_Standard loop
2459 if Is_Subprogram (Context)
2461 (Present (Get_Pragma (Context, Pragma_Global))
2463 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2465 Collect_Subprogram_Inputs_Outputs
2466 (Subp_Id => Context,
2467 Subp_Inputs => Inputs,
2468 Subp_Outputs => Outputs,
2469 Global_Seen => Dummy);
2471 -- The item is classified as In_Out or Output but appears as
2472 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2474 if Appears_In (Inputs, Item_Id)
2475 and then not Appears_In (Outputs, Item_Id)
2478 ("global item & cannot have mode In_Out or Output",
2482 (Fix_Msg (Subp_Id, "\item already appears as input of "
2483 & "subprogram &"), Item, Context);
2485 -- Stop the traversal once an error has been detected
2491 Context := Scope (Context);
2493 end Check_Mode_Restriction_In_Enclosing_Context;
2495 ----------------------------------------
2496 -- Check_Mode_Restriction_In_Function --
2497 ----------------------------------------
2499 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2501 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2503 ("global mode & is not applicable to functions", Mode);
2505 end Check_Mode_Restriction_In_Function;
2513 -- Start of processing for Analyze_Global_List
2516 if Nkind (List) = N_Null then
2517 Set_Analyzed (List);
2519 -- Single global item declaration
2521 elsif Nkind_In (List, N_Expanded_Name,
2523 N_Selected_Component)
2525 Analyze_Global_Item (List, Global_Mode);
2527 -- Simple global list or moded global list declaration
2529 elsif Nkind (List) = N_Aggregate then
2530 Set_Analyzed (List);
2532 -- The declaration of a simple global list appear as a collection
2535 if Present (Expressions (List)) then
2536 if Present (Component_Associations (List)) then
2538 ("cannot mix moded and non-moded global lists", List);
2541 Item := First (Expressions (List));
2542 while Present (Item) loop
2543 Analyze_Global_Item (Item, Global_Mode);
2547 -- The declaration of a moded global list appears as a collection
2548 -- of component associations where individual choices denote
2551 elsif Present (Component_Associations (List)) then
2552 if Present (Expressions (List)) then
2554 ("cannot mix moded and non-moded global lists", List);
2557 Assoc := First (Component_Associations (List));
2558 while Present (Assoc) loop
2559 Mode := First (Choices (Assoc));
2561 if Nkind (Mode) = N_Identifier then
2562 if Chars (Mode) = Name_In_Out then
2563 Check_Duplicate_Mode (Mode, In_Out_Seen);
2564 Check_Mode_Restriction_In_Function (Mode);
2566 elsif Chars (Mode) = Name_Input then
2567 Check_Duplicate_Mode (Mode, Input_Seen);
2569 elsif Chars (Mode) = Name_Output then
2570 Check_Duplicate_Mode (Mode, Output_Seen);
2571 Check_Mode_Restriction_In_Function (Mode);
2573 elsif Chars (Mode) = Name_Proof_In then
2574 Check_Duplicate_Mode (Mode, Proof_Seen);
2577 SPARK_Msg_N ("invalid mode selector", Mode);
2581 SPARK_Msg_N ("invalid mode selector", Mode);
2584 -- Items in a moded list appear as a collection of
2585 -- expressions. Reuse the existing machinery to analyze
2589 (List => Expression (Assoc),
2590 Global_Mode => Chars (Mode));
2598 raise Program_Error;
2601 -- Any other attempt to declare a global item is illegal. This is a
2602 -- syntax error, always report.
2605 Error_Msg_N ("malformed global list", List);
2607 end Analyze_Global_List;
2611 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2613 Restore_Scope : Boolean := False;
2615 -- Start of processing for Analyze_Global_In_Decl_Part
2618 -- Do not analyze the pragma multiple times
2620 if Is_Analyzed_Pragma (N) then
2624 -- There is nothing to be done for a null global list
2626 if Nkind (Items) = N_Null then
2627 Set_Analyzed (Items);
2629 -- Analyze the various forms of global lists and items. Note that some
2630 -- of these may be malformed in which case the analysis emits error
2634 -- When pragma [Refined_]Global appears on a single concurrent type,
2635 -- it is relocated to the anonymous object.
2637 if Is_Single_Concurrent_Object (Spec_Id) then
2640 -- Ensure that the formal parameters are visible when processing an
2641 -- item. This falls out of the general rule of aspects pertaining to
2642 -- subprogram declarations.
2644 elsif not In_Open_Scopes (Spec_Id) then
2645 Restore_Scope := True;
2646 Push_Scope (Spec_Id);
2648 if Ekind (Spec_Id) = E_Task_Type then
2649 if Has_Discriminants (Spec_Id) then
2650 Install_Discriminants (Spec_Id);
2653 elsif Is_Generic_Subprogram (Spec_Id) then
2654 Install_Generic_Formals (Spec_Id);
2657 Install_Formals (Spec_Id);
2661 Analyze_Global_List (Items);
2663 if Restore_Scope then
2668 -- Ensure that a state and a corresponding constituent do not appear
2669 -- together in pragma [Refined_]Global.
2671 Check_State_And_Constituent_Use
2672 (States => States_Seen,
2673 Constits => Constits_Seen,
2676 Set_Is_Analyzed_Pragma (N);
2677 end Analyze_Global_In_Decl_Part;
2679 --------------------------------------------
2680 -- Analyze_Initial_Condition_In_Decl_Part --
2681 --------------------------------------------
2683 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2684 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2685 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2686 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2688 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2691 -- Do not analyze the pragma multiple times
2693 if Is_Analyzed_Pragma (N) then
2697 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2698 -- analysis of the pragma, the Ghost mode at point of declaration and
2699 -- point of analysis may not necessarily be the same. Use the mode in
2700 -- effect at the point of declaration.
2704 -- The expression is preanalyzed because it has not been moved to its
2705 -- final place yet. A direct analysis may generate side effects and this
2706 -- is not desired at this point.
2708 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2709 Ghost_Mode := Save_Ghost_Mode;
2711 Set_Is_Analyzed_Pragma (N);
2712 end Analyze_Initial_Condition_In_Decl_Part;
2714 --------------------------------------
2715 -- Analyze_Initializes_In_Decl_Part --
2716 --------------------------------------
2718 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2719 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2720 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2722 Constits_Seen : Elist_Id := No_Elist;
2723 -- A list containing the entities of all constituents processed so far.
2724 -- It aids in detecting illegal usage of a state and a corresponding
2725 -- constituent in pragma Initializes.
2727 Items_Seen : Elist_Id := No_Elist;
2728 -- A list of all initialization items processed so far. This list is
2729 -- used to detect duplicate items.
2731 Non_Null_Seen : Boolean := False;
2732 Null_Seen : Boolean := False;
2733 -- Flags used to check the legality of a null initialization list
2735 States_And_Objs : Elist_Id := No_Elist;
2736 -- A list of all abstract states and objects declared in the visible
2737 -- declarations of the related package. This list is used to detect the
2738 -- legality of initialization items.
2740 States_Seen : Elist_Id := No_Elist;
2741 -- A list containing the entities of all states processed so far. It
2742 -- helps in detecting illegal usage of a state and a corresponding
2743 -- constituent in pragma Initializes.
2745 procedure Analyze_Initialization_Item (Item : Node_Id);
2746 -- Verify the legality of a single initialization item
2748 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2749 -- Verify the legality of a single initialization item followed by a
2750 -- list of input items.
2752 procedure Collect_States_And_Objects;
2753 -- Inspect the visible declarations of the related package and gather
2754 -- the entities of all abstract states and objects in States_And_Objs.
2756 ---------------------------------
2757 -- Analyze_Initialization_Item --
2758 ---------------------------------
2760 procedure Analyze_Initialization_Item (Item : Node_Id) is
2761 Item_Id : Entity_Id;
2764 -- Null initialization list
2766 if Nkind (Item) = N_Null then
2768 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2770 elsif Non_Null_Seen then
2772 ("cannot mix null and non-null initialization items", Item);
2777 -- Initialization item
2780 Non_Null_Seen := True;
2784 ("cannot mix null and non-null initialization items", Item);
2788 Resolve_State (Item);
2790 if Is_Entity_Name (Item) then
2791 Item_Id := Entity_Of (Item);
2793 if Ekind_In (Item_Id, E_Abstract_State,
2797 -- The state or variable must be declared in the visible
2798 -- declarations of the package (SPARK RM 7.1.5(7)).
2800 if not Contains (States_And_Objs, Item_Id) then
2801 Error_Msg_Name_1 := Chars (Pack_Id);
2803 ("initialization item & must appear in the visible "
2804 & "declarations of package %", Item, Item_Id);
2806 -- Detect a duplicate use of the same initialization item
2807 -- (SPARK RM 7.1.5(5)).
2809 elsif Contains (Items_Seen, Item_Id) then
2810 SPARK_Msg_N ("duplicate initialization item", Item);
2812 -- The item is legal, add it to the list of processed states
2816 Append_New_Elmt (Item_Id, Items_Seen);
2818 if Ekind (Item_Id) = E_Abstract_State then
2819 Append_New_Elmt (Item_Id, States_Seen);
2822 if Present (Encapsulating_State (Item_Id)) then
2823 Append_New_Elmt (Item_Id, Constits_Seen);
2827 -- The item references something that is not a state or object
2828 -- (SPARK RM 7.1.5(3)).
2832 ("initialization item must denote object or state", Item);
2835 -- Some form of illegal construct masquerading as a name
2836 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2840 ("initialization item must denote object or state", Item);
2843 end Analyze_Initialization_Item;
2845 ---------------------------------------------
2846 -- Analyze_Initialization_Item_With_Inputs --
2847 ---------------------------------------------
2849 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2850 Inputs_Seen : Elist_Id := No_Elist;
2851 -- A list of all inputs processed so far. This list is used to detect
2852 -- duplicate uses of an input.
2854 Non_Null_Seen : Boolean := False;
2855 Null_Seen : Boolean := False;
2856 -- Flags used to check the legality of an input list
2858 procedure Analyze_Input_Item (Input : Node_Id);
2859 -- Verify the legality of a single input item
2861 ------------------------
2862 -- Analyze_Input_Item --
2863 ------------------------
2865 procedure Analyze_Input_Item (Input : Node_Id) is
2866 Input_Id : Entity_Id;
2867 Input_OK : Boolean := True;
2872 if Nkind (Input) = N_Null then
2875 ("multiple null initializations not allowed", Item);
2877 elsif Non_Null_Seen then
2879 ("cannot mix null and non-null initialization item", Item);
2887 Non_Null_Seen := True;
2891 ("cannot mix null and non-null initialization item", Item);
2895 Resolve_State (Input);
2897 if Is_Entity_Name (Input) then
2898 Input_Id := Entity_Of (Input);
2900 if Ekind_In (Input_Id, E_Abstract_State,
2902 E_Generic_In_Out_Parameter,
2903 E_Generic_In_Parameter,
2909 -- The input cannot denote states or objects declared
2910 -- within the related package (SPARK RM 7.1.5(4)).
2912 if Within_Scope (Input_Id, Current_Scope) then
2914 -- Do not consider generic formal parameters or their
2915 -- respective mappings to generic formals. Even though
2916 -- the formals appear within the scope of the package,
2917 -- it is allowed for an initialization item to depend
2918 -- on an input item.
2920 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2921 E_Generic_In_Parameter)
2925 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2926 and then Present (Corresponding_Generic_Association
2927 (Declaration_Node (Input_Id)))
2933 Error_Msg_Name_1 := Chars (Pack_Id);
2935 ("input item & cannot denote a visible object or "
2936 & "state of package %", Input, Input_Id);
2940 -- Detect a duplicate use of the same input item
2941 -- (SPARK RM 7.1.5(5)).
2943 if Contains (Inputs_Seen, Input_Id) then
2945 SPARK_Msg_N ("duplicate input item", Input);
2948 -- Input is legal, add it to the list of processed inputs
2951 Append_New_Elmt (Input_Id, Inputs_Seen);
2953 if Ekind (Input_Id) = E_Abstract_State then
2954 Append_New_Elmt (Input_Id, States_Seen);
2957 if Ekind_In (Input_Id, E_Abstract_State,
2960 and then Present (Encapsulating_State (Input_Id))
2962 Append_New_Elmt (Input_Id, Constits_Seen);
2966 -- The input references something that is not a state or an
2967 -- object (SPARK RM 7.1.5(3)).
2971 ("input item must denote object or state", Input);
2974 -- Some form of illegal construct masquerading as a name
2975 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2979 ("input item must denote object or state", Input);
2982 end Analyze_Input_Item;
2986 Inputs : constant Node_Id := Expression (Item);
2990 Name_Seen : Boolean := False;
2991 -- A flag used to detect multiple item names
2993 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2996 -- Inspect the name of an item with inputs
2998 Elmt := First (Choices (Item));
2999 while Present (Elmt) loop
3001 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3004 Analyze_Initialization_Item (Elmt);
3010 -- Multiple input items appear as an aggregate
3012 if Nkind (Inputs) = N_Aggregate then
3013 if Present (Expressions (Inputs)) then
3014 Input := First (Expressions (Inputs));
3015 while Present (Input) loop
3016 Analyze_Input_Item (Input);
3021 if Present (Component_Associations (Inputs)) then
3023 ("inputs must appear in named association form", Inputs);
3026 -- Single input item
3029 Analyze_Input_Item (Inputs);
3031 end Analyze_Initialization_Item_With_Inputs;
3033 --------------------------------
3034 -- Collect_States_And_Objects --
3035 --------------------------------
3037 procedure Collect_States_And_Objects is
3038 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3042 -- Collect the abstract states defined in the package (if any)
3044 if Present (Abstract_States (Pack_Id)) then
3045 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3048 -- Collect all objects the appear in the visible declarations of the
3051 if Present (Visible_Declarations (Pack_Spec)) then
3052 Decl := First (Visible_Declarations (Pack_Spec));
3053 while Present (Decl) loop
3054 if Comes_From_Source (Decl)
3055 and then Nkind (Decl) = N_Object_Declaration
3057 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3063 end Collect_States_And_Objects;
3067 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3070 -- Start of processing for Analyze_Initializes_In_Decl_Part
3073 -- Do not analyze the pragma multiple times
3075 if Is_Analyzed_Pragma (N) then
3079 -- Nothing to do when the initialization list is empty
3081 if Nkind (Inits) = N_Null then
3085 -- Single and multiple initialization clauses appear as an aggregate. If
3086 -- this is not the case, then either the parser or the analysis of the
3087 -- pragma failed to produce an aggregate.
3089 pragma Assert (Nkind (Inits) = N_Aggregate);
3091 -- Initialize the various lists used during analysis
3093 Collect_States_And_Objects;
3095 if Present (Expressions (Inits)) then
3096 Init := First (Expressions (Inits));
3097 while Present (Init) loop
3098 Analyze_Initialization_Item (Init);
3103 if Present (Component_Associations (Inits)) then
3104 Init := First (Component_Associations (Inits));
3105 while Present (Init) loop
3106 Analyze_Initialization_Item_With_Inputs (Init);
3111 -- Ensure that a state and a corresponding constituent do not appear
3112 -- together in pragma Initializes.
3114 Check_State_And_Constituent_Use
3115 (States => States_Seen,
3116 Constits => Constits_Seen,
3119 Set_Is_Analyzed_Pragma (N);
3120 end Analyze_Initializes_In_Decl_Part;
3122 ---------------------
3123 -- Analyze_Part_Of --
3124 ---------------------
3126 procedure Analyze_Part_Of
3128 Item_Id : Entity_Id;
3130 Encap_Id : out Entity_Id;
3131 Legal : out Boolean)
3133 Encap_Typ : Entity_Id;
3134 Item_Decl : Node_Id;
3135 Pack_Id : Entity_Id;
3136 Placement : State_Space_Kind;
3137 Parent_Unit : Entity_Id;
3140 -- Assume that the indicator is illegal
3145 if Nkind_In (Encap, N_Expanded_Name,
3147 N_Selected_Component)
3150 Resolve_State (Encap);
3152 Encap_Id := Entity (Encap);
3154 -- The encapsulator is an abstract state
3156 if Ekind (Encap_Id) = E_Abstract_State then
3159 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3161 elsif Is_Single_Concurrent_Object (Encap_Id) then
3164 -- Otherwise the encapsulator is not a legal choice
3168 ("indicator Part_Of must denote abstract state, single "
3169 & "protected type or single task type", Encap);
3173 -- This is a syntax error, always report
3177 ("indicator Part_Of must denote abstract state, single protected "
3178 & "type or single task type", Encap);
3182 -- Catch a case where indicator Part_Of denotes the abstract view of a
3183 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3185 if From_Limited_With (Encap_Id)
3186 and then Present (Non_Limited_View (Encap_Id))
3187 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3189 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3190 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3194 -- The encapsulator is an abstract state
3196 if Ekind (Encap_Id) = E_Abstract_State then
3198 -- Determine where the object, package instantiation or state lives
3199 -- with respect to the enclosing packages or package bodies.
3201 Find_Placement_In_State_Space
3202 (Item_Id => Item_Id,
3203 Placement => Placement,
3204 Pack_Id => Pack_Id);
3206 -- The item appears in a non-package construct with a declarative
3207 -- part (subprogram, block, etc). As such, the item is not allowed
3208 -- to be a part of an encapsulating state because the item is not
3211 if Placement = Not_In_Package then
3213 ("indicator Part_Of cannot appear in this context "
3214 & "(SPARK RM 7.2.6(5))", Indic);
3215 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3217 ("\& is not part of the hidden state of package %",
3220 -- The item appears in the visible state space of some package. In
3221 -- general this scenario does not warrant Part_Of except when the
3222 -- package is a private child unit and the encapsulating state is
3223 -- declared in a parent unit or a public descendant of that parent
3226 elsif Placement = Visible_State_Space then
3227 if Is_Child_Unit (Pack_Id)
3228 and then Is_Private_Descendant (Pack_Id)
3230 -- A variable or state abstraction which is part of the visible
3231 -- state of a private child unit (or one of its public
3232 -- descendants) must have its Part_Of indicator specified. The
3233 -- Part_Of indicator must denote a state abstraction declared
3234 -- by either the parent unit of the private unit or by a public
3235 -- descendant of that parent unit.
3237 -- Find nearest private ancestor (which can be the current unit
3240 Parent_Unit := Pack_Id;
3241 while Present (Parent_Unit) loop
3244 (Parent (Unit_Declaration_Node (Parent_Unit)));
3245 Parent_Unit := Scope (Parent_Unit);
3248 Parent_Unit := Scope (Parent_Unit);
3250 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3252 ("indicator Part_Of must denote abstract state or public "
3253 & "descendant of & (SPARK RM 7.2.6(3))",
3254 Indic, Parent_Unit);
3256 elsif Scope (Encap_Id) = Parent_Unit
3258 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3259 and then not Is_Private_Descendant (Scope (Encap_Id)))
3265 ("indicator Part_Of must denote abstract state or public "
3266 & "descendant of & (SPARK RM 7.2.6(3))",
3267 Indic, Parent_Unit);
3270 -- Indicator Part_Of is not needed when the related package is not
3271 -- a private child unit or a public descendant thereof.
3275 ("indicator Part_Of cannot appear in this context "
3276 & "(SPARK RM 7.2.6(5))", Indic);
3277 Error_Msg_Name_1 := Chars (Pack_Id);
3279 ("\& is declared in the visible part of package %",
3283 -- When the item appears in the private state space of a package, the
3284 -- encapsulating state must be declared in the same package.
3286 elsif Placement = Private_State_Space then
3287 if Scope (Encap_Id) /= Pack_Id then
3289 ("indicator Part_Of must designate an abstract state of "
3290 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3291 Error_Msg_Name_1 := Chars (Pack_Id);
3293 ("\& is declared in the private part of package %",
3297 -- Items declared in the body state space of a package do not need
3298 -- Part_Of indicators as the refinement has already been seen.
3302 ("indicator Part_Of cannot appear in this context "
3303 & "(SPARK RM 7.2.6(5))", Indic);
3305 if Scope (Encap_Id) = Pack_Id then
3306 Error_Msg_Name_1 := Chars (Pack_Id);
3308 ("\& is declared in the body of package %", Indic, Item_Id);
3312 -- The encapsulator is a single concurrent type
3315 Encap_Typ := Etype (Encap_Id);
3317 -- Only abstract states and variables can act as constituents of an
3318 -- encapsulating single concurrent type.
3320 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3323 -- The constituent is a constant
3325 elsif Ekind (Item_Id) = E_Constant then
3326 Error_Msg_Name_1 := Chars (Encap_Id);
3328 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3329 & "single protected type %"), Indic, Item_Id);
3331 -- The constituent is a package instantiation
3334 Error_Msg_Name_1 := Chars (Encap_Id);
3336 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3337 & "constituent of single protected type %"), Indic, Item_Id);
3340 -- When the item denotes an abstract state of a nested package, use
3341 -- the declaration of the package to detect proper placement.
3346 -- with Abstract_State => (State with Part_Of => T)
3348 if Ekind (Item_Id) = E_Abstract_State then
3349 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3351 Item_Decl := Declaration_Node (Item_Id);
3354 -- Both the item and its encapsulating single concurrent type must
3355 -- appear in the same declarative region (SPARK RM 9.3). Note that
3356 -- privacy is ignored.
3358 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3359 Error_Msg_Name_1 := Chars (Encap_Id);
3361 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3362 & "immediately within the same region as single protected "
3363 & "type %"), Indic, Item_Id);
3368 end Analyze_Part_Of;
3370 ----------------------------------
3371 -- Analyze_Part_Of_In_Decl_Part --
3372 ----------------------------------
3374 procedure Analyze_Part_Of_In_Decl_Part
3376 Freeze_Id : Entity_Id := Empty)
3378 Encap : constant Node_Id :=
3379 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3380 Errors : constant Nat := Serious_Errors_Detected;
3381 Var_Decl : constant Node_Id := Find_Related_Context (N);
3382 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3383 Constits : Elist_Id;
3384 Encap_Id : Entity_Id;
3388 -- Detect any discrepancies between the placement of the variable with
3389 -- respect to general state space and the encapsulating state or single
3396 Encap_Id => Encap_Id,
3399 -- The Part_Of indicator turns the variable into a constituent of the
3400 -- encapsulating state or single concurrent type.
3403 pragma Assert (Present (Encap_Id));
3404 Constits := Part_Of_Constituents (Encap_Id);
3406 if No (Constits) then
3407 Constits := New_Elmt_List;
3408 Set_Part_Of_Constituents (Encap_Id, Constits);
3411 Append_Elmt (Var_Id, Constits);
3412 Set_Encapsulating_State (Var_Id, Encap_Id);
3415 -- Emit a clarification message when the encapsulator is undefined,
3416 -- possibly due to contract "freezing".
3418 if Errors /= Serious_Errors_Detected
3419 and then Present (Freeze_Id)
3420 and then Has_Undefined_Reference (Encap)
3422 Contract_Freeze_Error (Var_Id, Freeze_Id);
3424 end Analyze_Part_Of_In_Decl_Part;
3426 --------------------
3427 -- Analyze_Pragma --
3428 --------------------
3430 procedure Analyze_Pragma (N : Node_Id) is
3431 Loc : constant Source_Ptr := Sloc (N);
3432 Prag_Id : Pragma_Id;
3435 -- Name of the source pragma, or name of the corresponding aspect for
3436 -- pragmas which originate in a source aspect. In the latter case, the
3437 -- name may be different from the pragma name.
3439 Pragma_Exit : exception;
3440 -- This exception is used to exit pragma processing completely. It
3441 -- is used when an error is detected, and no further processing is
3442 -- required. It is also used if an earlier error has left the tree in
3443 -- a state where the pragma should not be processed.
3446 -- Number of pragma argument associations
3452 -- First four pragma arguments (pragma argument association nodes, or
3453 -- Empty if the corresponding argument does not exist).
3455 type Name_List is array (Natural range <>) of Name_Id;
3456 type Args_List is array (Natural range <>) of Node_Id;
3457 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3459 -----------------------
3460 -- Local Subprograms --
3461 -----------------------
3463 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3464 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3465 -- get the given string argument, and place it in Name_Buffer, adding
3466 -- leading and trailing asterisks if they are not already present. The
3467 -- caller has already checked that Arg is a static string expression.
3469 procedure Ada_2005_Pragma;
3470 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3471 -- Ada 95 mode, these are implementation defined pragmas, so should be
3472 -- caught by the No_Implementation_Pragmas restriction.
3474 procedure Ada_2012_Pragma;
3475 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3476 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3477 -- should be caught by the No_Implementation_Pragmas restriction.
3479 procedure Analyze_Depends_Global
3480 (Spec_Id : out Entity_Id;
3481 Subp_Decl : out Node_Id;
3482 Legal : out Boolean);
3483 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3484 -- legality of the placement and related context of the pragma. Spec_Id
3485 -- is the entity of the related subprogram. Subp_Decl is the declaration
3486 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3488 procedure Analyze_If_Present (Id : Pragma_Id);
3489 -- Inspect the remainder of the list containing pragma N and look for
3490 -- a pragma that matches Id. If found, analyze the pragma.
3492 procedure Analyze_Pre_Post_Condition;
3493 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3495 procedure Analyze_Refined_Depends_Global_Post
3496 (Spec_Id : out Entity_Id;
3497 Body_Id : out Entity_Id;
3498 Legal : out Boolean);
3499 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3500 -- Refined_Global and Refined_Post. Verify the legality of the placement
3501 -- and related context of the pragma. Spec_Id is the entity of the
3502 -- related subprogram. Body_Id is the entity of the subprogram body.
3503 -- Flag Legal is set when the pragma is legal.
3505 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3506 -- Perform full analysis of pragma Unmodified and the write aspect of
3507 -- pragma Unused. Flag Is_Unused should be set when verifying the
3508 -- semantics of pragma Unused.
3510 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3511 -- Perform full analysis of pragma Unreferenced and the read aspect of
3512 -- pragma Unused. Flag Is_Unused should be set when verifying the
3513 -- semantics of pragma Unused.
3515 procedure Check_Ada_83_Warning;
3516 -- Issues a warning message for the current pragma if operating in Ada
3517 -- 83 mode (used for language pragmas that are not a standard part of
3518 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3521 procedure Check_Arg_Count (Required : Nat);
3522 -- Check argument count for pragma is equal to given parameter. If not,
3523 -- then issue an error message and raise Pragma_Exit.
3525 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3526 -- Arg which can either be a pragma argument association, in which case
3527 -- the check is applied to the expression of the association or an
3528 -- expression directly.
3530 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3531 -- Check that an argument has the right form for an EXTERNAL_NAME
3532 -- parameter of an extended import/export pragma. The rule is that the
3533 -- name must be an identifier or string literal (in Ada 83 mode) or a
3534 -- static string expression (in Ada 95 mode).
3536 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3537 -- Check the specified argument Arg to make sure that it is an
3538 -- identifier. If not give error and raise Pragma_Exit.
3540 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3541 -- Check the specified argument Arg to make sure that it is an integer
3542 -- literal. If not give error and raise Pragma_Exit.
3544 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3545 -- Check the specified argument Arg to make sure that it has the proper
3546 -- syntactic form for a local name and meets the semantic requirements
3547 -- for a local name. The local name is analyzed as part of the
3548 -- processing for this call. In addition, the local name is required
3549 -- to represent an entity at the library level.
3551 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3552 -- Check the specified argument Arg to make sure that it has the proper
3553 -- syntactic form for a local name and meets the semantic requirements
3554 -- for a local name. The local name is analyzed as part of the
3555 -- processing for this call.
3557 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3558 -- Check the specified argument Arg to make sure that it is a valid
3559 -- locking policy name. If not give error and raise Pragma_Exit.
3561 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3562 -- Check the specified argument Arg to make sure that it is a valid
3563 -- elaboration policy name. If not give error and raise Pragma_Exit.
3565 procedure Check_Arg_Is_One_Of
3568 procedure Check_Arg_Is_One_Of
3570 N1, N2, N3 : Name_Id);
3571 procedure Check_Arg_Is_One_Of
3573 N1, N2, N3, N4 : Name_Id);
3574 procedure Check_Arg_Is_One_Of
3576 N1, N2, N3, N4, N5 : Name_Id);
3577 -- Check the specified argument Arg to make sure that it is an
3578 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3579 -- present). If not then give error and raise Pragma_Exit.
3581 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3582 -- Check the specified argument Arg to make sure that it is a valid
3583 -- queuing policy name. If not give error and raise Pragma_Exit.
3585 procedure Check_Arg_Is_OK_Static_Expression
3587 Typ : Entity_Id := Empty);
3588 -- Check the specified argument Arg to make sure that it is a static
3589 -- expression of the given type (i.e. it will be analyzed and resolved
3590 -- using this type, which can be any valid argument to Resolve, e.g.
3591 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3592 -- Typ is left Empty, then any static expression is allowed. Includes
3593 -- checking that the argument does not raise Constraint_Error.
3595 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3596 -- Check the specified argument Arg to make sure that it is a valid task
3597 -- dispatching policy name. If not give error and raise Pragma_Exit.
3599 procedure Check_Arg_Order (Names : Name_List);
3600 -- Checks for an instance of two arguments with identifiers for the
3601 -- current pragma which are not in the sequence indicated by Names,
3602 -- and if so, generates a fatal message about bad order of arguments.
3604 procedure Check_At_Least_N_Arguments (N : Nat);
3605 -- Check there are at least N arguments present
3607 procedure Check_At_Most_N_Arguments (N : Nat);
3608 -- Check there are no more than N arguments present
3610 procedure Check_Component
3613 In_Variant_Part : Boolean := False);
3614 -- Examine an Unchecked_Union component for correct use of per-object
3615 -- constrained subtypes, and for restrictions on finalizable components.
3616 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3617 -- should be set when Comp comes from a record variant.
3619 procedure Check_Duplicate_Pragma (E : Entity_Id);
3620 -- Check if a rep item of the same name as the current pragma is already
3621 -- chained as a rep pragma to the given entity. If so give a message
3622 -- about the duplicate, and then raise Pragma_Exit so does not return.
3623 -- Note that if E is a type, then this routine avoids flagging a pragma
3624 -- which applies to a parent type from which E is derived.
3626 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3627 -- Nam is an N_String_Literal node containing the external name set by
3628 -- an Import or Export pragma (or extended Import or Export pragma).
3629 -- This procedure checks for possible duplications if this is the export
3630 -- case, and if found, issues an appropriate error message.
3632 procedure Check_Expr_Is_OK_Static_Expression
3634 Typ : Entity_Id := Empty);
3635 -- Check the specified expression Expr to make sure that it is a static
3636 -- expression of the given type (i.e. it will be analyzed and resolved
3637 -- using this type, which can be any valid argument to Resolve, e.g.
3638 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3639 -- Typ is left Empty, then any static expression is allowed. Includes
3640 -- checking that the expression does not raise Constraint_Error.
3642 procedure Check_First_Subtype (Arg : Node_Id);
3643 -- Checks that Arg, whose expression is an entity name, references a
3646 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3647 -- Checks that the given argument has an identifier, and if so, requires
3648 -- it to match the given identifier name. If there is no identifier, or
3649 -- a non-matching identifier, then an error message is given and
3650 -- Pragma_Exit is raised.
3652 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3653 -- Checks that the given argument has an identifier, and if so, requires
3654 -- it to match one of the given identifier names. If there is no
3655 -- identifier, or a non-matching identifier, then an error message is
3656 -- given and Pragma_Exit is raised.
3658 procedure Check_In_Main_Program;
3659 -- Common checks for pragmas that appear within a main program
3660 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3662 procedure Check_Interrupt_Or_Attach_Handler;
3663 -- Common processing for first argument of pragma Interrupt_Handler or
3664 -- pragma Attach_Handler.
3666 procedure Check_Loop_Pragma_Placement;
3667 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3668 -- appear immediately within a construct restricted to loops, and that
3669 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3671 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3672 -- Check that pragma appears in a declarative part, or in a package
3673 -- specification, i.e. that it does not occur in a statement sequence
3676 procedure Check_No_Identifier (Arg : Node_Id);
3677 -- Checks that the given argument does not have an identifier. If
3678 -- an identifier is present, then an error message is issued, and
3679 -- Pragma_Exit is raised.
3681 procedure Check_No_Identifiers;
3682 -- Checks that none of the arguments to the pragma has an identifier.
3683 -- If any argument has an identifier, then an error message is issued,
3684 -- and Pragma_Exit is raised.
3686 procedure Check_No_Link_Name;
3687 -- Checks that no link name is specified
3689 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3690 -- Checks if the given argument has an identifier, and if so, requires
3691 -- it to match the given identifier name. If there is a non-matching
3692 -- identifier, then an error message is given and Pragma_Exit is raised.
3694 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3695 -- Checks if the given argument has an identifier, and if so, requires
3696 -- it to match the given identifier name. If there is a non-matching
3697 -- identifier, then an error message is given and Pragma_Exit is raised.
3698 -- In this version of the procedure, the identifier name is given as
3699 -- a string with lower case letters.
3701 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3702 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3703 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3704 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3705 -- is an OK static boolean expression. Emit an error if this is not the
3708 procedure Check_Static_Constraint (Constr : Node_Id);
3709 -- Constr is a constraint from an N_Subtype_Indication node from a
3710 -- component constraint in an Unchecked_Union type. This routine checks
3711 -- that the constraint is static as required by the restrictions for
3714 procedure Check_Valid_Configuration_Pragma;
3715 -- Legality checks for placement of a configuration pragma
3717 procedure Check_Valid_Library_Unit_Pragma;
3718 -- Legality checks for library unit pragmas. A special case arises for
3719 -- pragmas in generic instances that come from copies of the original
3720 -- library unit pragmas in the generic templates. In the case of other
3721 -- than library level instantiations these can appear in contexts which
3722 -- would normally be invalid (they only apply to the original template
3723 -- and to library level instantiations), and they are simply ignored,
3724 -- which is implemented by rewriting them as null statements.
3726 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3727 -- Check an Unchecked_Union variant for lack of nested variants and
3728 -- presence of at least one component. UU_Typ is the related Unchecked_
3731 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3732 -- Subsidiary routine to the processing of pragmas Abstract_State,
3733 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3734 -- Refined_Global and Refined_State. Transform argument Arg into
3735 -- an aggregate if not one already. N_Null is never transformed.
3736 -- Arg may denote an aspect specification or a pragma argument
3739 procedure Error_Pragma (Msg : String);
3740 pragma No_Return (Error_Pragma);
3741 -- Outputs error message for current pragma. The message contains a %
3742 -- that will be replaced with the pragma name, and the flag is placed
3743 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3744 -- calls Fix_Error (see spec of that procedure for details).
3746 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3747 pragma No_Return (Error_Pragma_Arg);
3748 -- Outputs error message for current pragma. The message may contain
3749 -- a % that will be replaced with the pragma name. The parameter Arg
3750 -- may either be a pragma argument association, in which case the flag
3751 -- is placed on the expression of this association, or an expression,
3752 -- in which case the flag is placed directly on the expression. The
3753 -- message is placed using Error_Msg_N, so the message may also contain
3754 -- an & insertion character which will reference the given Arg value.
3755 -- After placing the message, Pragma_Exit is raised. Note: this routine
3756 -- calls Fix_Error (see spec of that procedure for details).
3758 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3759 pragma No_Return (Error_Pragma_Arg);
3760 -- Similar to above form of Error_Pragma_Arg except that two messages
3761 -- are provided, the second is a continuation comment starting with \.
3763 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3764 pragma No_Return (Error_Pragma_Arg_Ident);
3765 -- Outputs error message for current pragma. The message may contain a %
3766 -- that will be replaced with the pragma name. The parameter Arg must be
3767 -- a pragma argument association with a non-empty identifier (i.e. its
3768 -- Chars field must be set), and the error message is placed on the
3769 -- identifier. The message is placed using Error_Msg_N so the message
3770 -- may also contain an & insertion character which will reference
3771 -- the identifier. After placing the message, Pragma_Exit is raised.
3772 -- Note: this routine calls Fix_Error (see spec of that procedure for
3775 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3776 pragma No_Return (Error_Pragma_Ref);
3777 -- Outputs error message for current pragma. The message may contain
3778 -- a % that will be replaced with the pragma name. The parameter Ref
3779 -- must be an entity whose name can be referenced by & and sloc by #.
3780 -- After placing the message, Pragma_Exit is raised. Note: this routine
3781 -- calls Fix_Error (see spec of that procedure for details).
3783 function Find_Lib_Unit_Name return Entity_Id;
3784 -- Used for a library unit pragma to find the entity to which the
3785 -- library unit pragma applies, returns the entity found.
3787 procedure Find_Program_Unit_Name (Id : Node_Id);
3788 -- If the pragma is a compilation unit pragma, the id must denote the
3789 -- compilation unit in the same compilation, and the pragma must appear
3790 -- in the list of preceding or trailing pragmas. If it is a program
3791 -- unit pragma that is not a compilation unit pragma, then the
3792 -- identifier must be visible.
3794 function Find_Unique_Parameterless_Procedure
3796 Arg : Node_Id) return Entity_Id;
3797 -- Used for a procedure pragma to find the unique parameterless
3798 -- procedure identified by Name, returns it if it exists, otherwise
3799 -- errors out and uses Arg as the pragma argument for the message.
3801 function Fix_Error (Msg : String) return String;
3802 -- This is called prior to issuing an error message. Msg is the normal
3803 -- error message issued in the pragma case. This routine checks for the
3804 -- case of a pragma coming from an aspect in the source, and returns a
3805 -- message suitable for the aspect case as follows:
3807 -- Each substring "pragma" is replaced by "aspect"
3809 -- If "argument of" is at the start of the error message text, it is
3810 -- replaced by "entity for".
3812 -- If "argument" is at the start of the error message text, it is
3813 -- replaced by "entity".
3815 -- So for example, "argument of pragma X must be discrete type"
3816 -- returns "entity for aspect X must be a discrete type".
3818 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3819 -- be different from the pragma name). If the current pragma results
3820 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3821 -- original pragma name.
3823 procedure Gather_Associations
3825 Args : out Args_List);
3826 -- This procedure is used to gather the arguments for a pragma that
3827 -- permits arbitrary ordering of parameters using the normal rules
3828 -- for named and positional parameters. The Names argument is a list
3829 -- of Name_Id values that corresponds to the allowed pragma argument
3830 -- association identifiers in order. The result returned in Args is
3831 -- a list of corresponding expressions that are the pragma arguments.
3832 -- Note that this is a list of expressions, not of pragma argument
3833 -- associations (Gather_Associations has completely checked all the
3834 -- optional identifiers when it returns). An entry in Args is Empty
3835 -- on return if the corresponding argument is not present.
3837 procedure GNAT_Pragma;
3838 -- Called for all GNAT defined pragmas to check the relevant restriction
3839 -- (No_Implementation_Pragmas).
3841 function Is_Before_First_Decl
3842 (Pragma_Node : Node_Id;
3843 Decls : List_Id) return Boolean;
3844 -- Return True if Pragma_Node is before the first declarative item in
3845 -- Decls where Decls is the list of declarative items.
3847 function Is_Configuration_Pragma return Boolean;
3848 -- Determines if the placement of the current pragma is appropriate
3849 -- for a configuration pragma.
3851 function Is_In_Context_Clause return Boolean;
3852 -- Returns True if pragma appears within the context clause of a unit,
3853 -- and False for any other placement (does not generate any messages).
3855 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3856 -- Analyzes the argument, and determines if it is a static string
3857 -- expression, returns True if so, False if non-static or not String.
3858 -- A special case is that a string literal returns True in Ada 83 mode
3859 -- (which has no such thing as static string expressions). Note that
3860 -- the call analyzes its argument, so this cannot be used for the case
3861 -- where an identifier might not be declared.
3863 procedure Pragma_Misplaced;
3864 pragma No_Return (Pragma_Misplaced);
3865 -- Issue fatal error message for misplaced pragma
3867 procedure Process_Atomic_Independent_Shared_Volatile;
3868 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3869 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3870 -- and treated as being identical in effect to pragma Atomic.
3872 procedure Process_Compile_Time_Warning_Or_Error;
3873 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3875 procedure Process_Convention
3876 (C : out Convention_Id;
3877 Ent : out Entity_Id);
3878 -- Common processing for Convention, Interface, Import and Export.
3879 -- Checks first two arguments of pragma, and sets the appropriate
3880 -- convention value in the specified entity or entities. On return
3881 -- C is the convention, Ent is the referenced entity.
3883 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3884 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3885 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3887 procedure Process_Extended_Import_Export_Object_Pragma
3888 (Arg_Internal : Node_Id;
3889 Arg_External : Node_Id;
3890 Arg_Size : Node_Id);
3891 -- Common processing for the pragmas Import/Export_Object. The three
3892 -- arguments correspond to the three named parameters of the pragmas. An
3893 -- argument is empty if the corresponding parameter is not present in
3896 procedure Process_Extended_Import_Export_Internal_Arg
3897 (Arg_Internal : Node_Id := Empty);
3898 -- Common processing for all extended Import and Export pragmas. The
3899 -- argument is the pragma parameter for the Internal argument. If
3900 -- Arg_Internal is empty or inappropriate, an error message is posted.
3901 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3902 -- set to identify the referenced entity.
3904 procedure Process_Extended_Import_Export_Subprogram_Pragma
3905 (Arg_Internal : Node_Id;
3906 Arg_External : Node_Id;
3907 Arg_Parameter_Types : Node_Id;
3908 Arg_Result_Type : Node_Id := Empty;
3909 Arg_Mechanism : Node_Id;
3910 Arg_Result_Mechanism : Node_Id := Empty);
3911 -- Common processing for all extended Import and Export pragmas applying
3912 -- to subprograms. The caller omits any arguments that do not apply to
3913 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3914 -- only in the Import_Function and Export_Function cases). The argument
3915 -- names correspond to the allowed pragma association identifiers.
3917 procedure Process_Generic_List;
3918 -- Common processing for Share_Generic and Inline_Generic
3920 procedure Process_Import_Or_Interface;
3921 -- Common processing for Import or Interface
3923 procedure Process_Import_Predefined_Type;
3924 -- Processing for completing a type with pragma Import. This is used
3925 -- to declare types that match predefined C types, especially for cases
3926 -- without corresponding Ada predefined type.
3928 type Inline_Status is (Suppressed, Disabled, Enabled);
3929 -- Inline status of a subprogram, indicated as follows:
3930 -- Suppressed: inlining is suppressed for the subprogram
3931 -- Disabled: no inlining is requested for the subprogram
3932 -- Enabled: inlining is requested/required for the subprogram
3934 procedure Process_Inline (Status : Inline_Status);
3935 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3936 -- indicates the inline status specified by the pragma.
3938 procedure Process_Interface_Name
3939 (Subprogram_Def : Entity_Id;
3941 Link_Arg : Node_Id);
3942 -- Given the last two arguments of pragma Import, pragma Export, or
3943 -- pragma Interface_Name, performs validity checks and sets the
3944 -- Interface_Name field of the given subprogram entity to the
3945 -- appropriate external or link name, depending on the arguments given.
3946 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3947 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3948 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3949 -- nor Link_Arg is present, the interface name is set to the default
3950 -- from the subprogram name.
3952 procedure Process_Interrupt_Or_Attach_Handler;
3953 -- Common processing for Interrupt and Attach_Handler pragmas
3955 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3956 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3957 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3958 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3959 -- is not set in the Restrictions case.
3961 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3962 -- Common processing for Suppress and Unsuppress. The boolean parameter
3963 -- Suppress_Case is True for the Suppress case, and False for the
3966 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3967 -- Subsidiary to the analysis of pragmas Independent[_Components].
3968 -- Record such a pragma N applied to entity E for future checks.
3970 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3971 -- This procedure sets the Is_Exported flag for the given entity,
3972 -- checking that the entity was not previously imported. Arg is
3973 -- the argument that specified the entity. A check is also made
3974 -- for exporting inappropriate entities.
3976 procedure Set_Extended_Import_Export_External_Name
3977 (Internal_Ent : Entity_Id;
3978 Arg_External : Node_Id);
3979 -- Common processing for all extended import export pragmas. The first
3980 -- argument, Internal_Ent, is the internal entity, which has already
3981 -- been checked for validity by the caller. Arg_External is from the
3982 -- Import or Export pragma, and may be null if no External parameter
3983 -- was present. If Arg_External is present and is a non-null string
3984 -- (a null string is treated as the default), then the Interface_Name
3985 -- field of Internal_Ent is set appropriately.
3987 procedure Set_Imported (E : Entity_Id);
3988 -- This procedure sets the Is_Imported flag for the given entity,
3989 -- checking that it is not previously exported or imported.
3991 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3992 -- Mech is a parameter passing mechanism (see Import_Function syntax
3993 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3994 -- has the right form, and if not issues an error message. If the
3995 -- argument has the right form then the Mechanism field of Ent is
3996 -- set appropriately.
3998 procedure Set_Rational_Profile;
3999 -- Activate the set of configuration pragmas and permissions that make
4000 -- up the Rational profile.
4002 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4003 -- Activate the set of configuration pragmas and restrictions that make
4004 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
4005 -- Ravenscar. N is the corresponding pragma node, which is used for
4006 -- error messages on any constructs violating the profile.
4008 ----------------------------------
4009 -- Acquire_Warning_Match_String --
4010 ----------------------------------
4012 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4014 String_To_Name_Buffer
4015 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4017 -- Add asterisk at start if not already there
4019 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4020 Name_Buffer (2 .. Name_Len + 1) :=
4021 Name_Buffer (1 .. Name_Len);
4022 Name_Buffer (1) := '*';
4023 Name_Len := Name_Len + 1;
4026 -- Add asterisk at end if not already there
4028 if Name_Buffer (Name_Len) /= '*' then
4029 Name_Len := Name_Len + 1;
4030 Name_Buffer (Name_Len) := '*';
4032 end Acquire_Warning_Match_String;
4034 ---------------------
4035 -- Ada_2005_Pragma --
4036 ---------------------
4038 procedure Ada_2005_Pragma is
4040 if Ada_Version <= Ada_95 then
4041 Check_Restriction (No_Implementation_Pragmas, N);
4043 end Ada_2005_Pragma;
4045 ---------------------
4046 -- Ada_2012_Pragma --
4047 ---------------------
4049 procedure Ada_2012_Pragma is
4051 if Ada_Version <= Ada_2005 then
4052 Check_Restriction (No_Implementation_Pragmas, N);
4054 end Ada_2012_Pragma;
4056 ----------------------------
4057 -- Analyze_Depends_Global --
4058 ----------------------------
4060 procedure Analyze_Depends_Global
4061 (Spec_Id : out Entity_Id;
4062 Subp_Decl : out Node_Id;
4063 Legal : out Boolean)
4066 -- Assume that the pragma is illegal
4073 Check_Arg_Count (1);
4075 -- Ensure the proper placement of the pragma. Depends/Global must be
4076 -- associated with a subprogram declaration or a body that acts as a
4079 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4083 if Nkind (Subp_Decl) = N_Entry_Declaration then
4086 -- Generic subprogram
4088 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4091 -- Object declaration of a single concurrent type
4093 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4098 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4101 -- Subprogram body acts as spec
4103 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4104 and then No (Corresponding_Spec (Subp_Decl))
4108 -- Subprogram body stub acts as spec
4110 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4111 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4115 -- Subprogram declaration
4117 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4122 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4130 -- If we get here, then the pragma is legal
4133 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4135 -- When the related context is an entry, the entry must belong to a
4136 -- protected unit (SPARK RM 6.1.4(6)).
4138 if Is_Entry_Declaration (Spec_Id)
4139 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4144 -- When the related context is an anonymous object created for a
4145 -- simple concurrent type, the type must be a task
4146 -- (SPARK RM 6.1.4(6)).
4148 elsif Is_Single_Concurrent_Object (Spec_Id)
4149 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4155 -- A pragma that applies to a Ghost entity becomes Ghost for the
4156 -- purposes of legality checks and removal of ignored Ghost code.
4158 Mark_Pragma_As_Ghost (N, Spec_Id);
4159 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4160 end Analyze_Depends_Global;
4162 ------------------------
4163 -- Analyze_If_Present --
4164 ------------------------
4166 procedure Analyze_If_Present (Id : Pragma_Id) is
4170 pragma Assert (Is_List_Member (N));
4172 -- Inspect the declarations or statements following pragma N looking
4173 -- for another pragma whose Id matches the caller's request. If it is
4174 -- available, analyze it.
4177 while Present (Stmt) loop
4178 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4179 Analyze_Pragma (Stmt);
4182 -- The first source declaration or statement immediately following
4183 -- N ends the region where a pragma may appear.
4185 elsif Comes_From_Source (Stmt) then
4191 end Analyze_If_Present;
4193 --------------------------------
4194 -- Analyze_Pre_Post_Condition --
4195 --------------------------------
4197 procedure Analyze_Pre_Post_Condition is
4198 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4199 Subp_Decl : Node_Id;
4200 Subp_Id : Entity_Id;
4202 Duplicates_OK : Boolean := False;
4203 -- Flag set when a pre/postcondition allows multiple pragmas of the
4206 In_Body_OK : Boolean := False;
4207 -- Flag set when a pre/postcondition is allowed to appear on a body
4208 -- even though the subprogram may have a spec.
4210 Is_Pre_Post : Boolean := False;
4211 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4215 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4216 -- offer uniformity among the various kinds of pre/postconditions by
4217 -- rewriting the pragma identifier. This allows the retrieval of the
4218 -- original pragma name by routine Original_Aspect_Pragma_Name.
4220 if Comes_From_Source (N) then
4221 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4222 Is_Pre_Post := True;
4223 Set_Class_Present (N, Pname = Name_Pre_Class);
4224 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4226 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4227 Is_Pre_Post := True;
4228 Set_Class_Present (N, Pname = Name_Post_Class);
4229 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4233 -- Determine the semantics with respect to duplicates and placement
4234 -- in a body. Pragmas Precondition and Postcondition were introduced
4235 -- before aspects and are not subject to the same aspect-like rules.
4237 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4238 Duplicates_OK := True;
4244 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4245 -- argument without an identifier.
4248 Check_Arg_Count (1);
4249 Check_No_Identifiers;
4251 -- Pragmas Precondition and Postcondition have complex argument
4255 Check_At_Least_N_Arguments (1);
4256 Check_At_Most_N_Arguments (2);
4257 Check_Optional_Identifier (Arg1, Name_Check);
4259 if Present (Arg2) then
4260 Check_Optional_Identifier (Arg2, Name_Message);
4261 Preanalyze_Spec_Expression
4262 (Get_Pragma_Arg (Arg2), Standard_String);
4266 -- For a pragma PPC in the extended main source unit, record enabled
4268 -- ??? nothing checks that the pragma is in the main source unit
4270 if Is_Checked (N) and then not Split_PPC (N) then
4271 Set_SCO_Pragma_Enabled (Loc);
4274 -- Ensure the proper placement of the pragma
4277 Find_Related_Declaration_Or_Body
4278 (N, Do_Checks => not Duplicates_OK);
4280 -- When a pre/postcondition pragma applies to an abstract subprogram,
4281 -- its original form must be an aspect with 'Class.
4283 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4284 if not From_Aspect_Specification (N) then
4286 ("pragma % cannot be applied to abstract subprogram");
4288 elsif not Class_Present (N) then
4290 ("aspect % requires ''Class for abstract subprogram");
4293 -- Entry declaration
4295 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4298 -- Generic subprogram declaration
4300 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4305 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4306 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4310 -- Subprogram body stub
4312 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4313 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4317 -- Subprogram declaration
4319 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4321 -- AI05-0230: When a pre/postcondition pragma applies to a null
4322 -- procedure, its original form must be an aspect with 'Class.
4324 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4325 and then Null_Present (Specification (Subp_Decl))
4326 and then From_Aspect_Specification (N)
4327 and then not Class_Present (N)
4329 Error_Pragma ("aspect % requires ''Class for null procedure");
4332 -- Otherwise the placement is illegal
4339 Subp_Id := Defining_Entity (Subp_Decl);
4341 -- Chain the pragma on the contract for further processing by
4342 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4344 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4346 -- A pragma that applies to a Ghost entity becomes Ghost for the
4347 -- purposes of legality checks and removal of ignored Ghost code.
4349 Mark_Pragma_As_Ghost (N, Subp_Id);
4351 -- Fully analyze the pragma when it appears inside an entry or
4352 -- subprogram body because it cannot benefit from forward references.
4354 if Nkind_In (Subp_Decl, N_Entry_Body,
4356 N_Subprogram_Body_Stub)
4358 -- The legality checks of pragmas Precondition and Postcondition
4359 -- are affected by the SPARK mode in effect and the volatility of
4360 -- the context. Analyze all pragmas in a specific order.
4362 Analyze_If_Present (Pragma_SPARK_Mode);
4363 Analyze_If_Present (Pragma_Volatile_Function);
4364 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4366 end Analyze_Pre_Post_Condition;
4368 -----------------------------------------
4369 -- Analyze_Refined_Depends_Global_Post --
4370 -----------------------------------------
4372 procedure Analyze_Refined_Depends_Global_Post
4373 (Spec_Id : out Entity_Id;
4374 Body_Id : out Entity_Id;
4375 Legal : out Boolean)
4377 Body_Decl : Node_Id;
4378 Spec_Decl : Node_Id;
4381 -- Assume that the pragma is illegal
4388 Check_Arg_Count (1);
4389 Check_No_Identifiers;
4391 -- Verify the placement of the pragma and check for duplicates. The
4392 -- pragma must apply to a subprogram body [stub].
4394 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4398 if Nkind (Body_Decl) = N_Entry_Body then
4403 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4406 -- Subprogram body stub
4408 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4413 elsif Nkind (Body_Decl) = N_Task_Body then
4421 Body_Id := Defining_Entity (Body_Decl);
4422 Spec_Id := Unique_Defining_Entity (Body_Decl);
4424 -- The pragma must apply to the second declaration of a subprogram.
4425 -- In other words, the body [stub] cannot acts as a spec.
4427 if No (Spec_Id) then
4428 Error_Pragma ("pragma % cannot apply to a stand alone body");
4431 -- Catch the case where the subprogram body is a subunit and acts as
4432 -- the third declaration of the subprogram.
4434 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4435 Error_Pragma ("pragma % cannot apply to a subunit");
4439 -- A refined pragma can only apply to the body [stub] of a subprogram
4440 -- declared in the visible part of a package. Retrieve the context of
4441 -- the subprogram declaration.
4443 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4445 -- When dealing with protected entries or protected subprograms, use
4446 -- the enclosing protected type as the proper context.
4448 if Ekind_In (Spec_Id, E_Entry,
4452 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4454 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4457 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4459 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4460 & "subprogram declared in a package specification"));
4464 -- If we get here, then the pragma is legal
4468 -- A pragma that applies to a Ghost entity becomes Ghost for the
4469 -- purposes of legality checks and removal of ignored Ghost code.
4471 Mark_Pragma_As_Ghost (N, Spec_Id);
4473 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4474 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4476 end Analyze_Refined_Depends_Global_Post;
4478 ----------------------------------
4479 -- Analyze_Unmodified_Or_Unused --
4480 ----------------------------------
4482 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4487 Ghost_Error_Posted : Boolean := False;
4488 -- Flag set when an error concerning the illegal mix of Ghost and
4489 -- non-Ghost variables is emitted.
4491 Ghost_Id : Entity_Id := Empty;
4492 -- The entity of the first Ghost variable encountered while
4493 -- processing the arguments of the pragma.
4497 Check_At_Least_N_Arguments (1);
4499 -- Loop through arguments
4502 while Present (Arg) loop
4503 Check_No_Identifier (Arg);
4505 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4506 -- in fact generate reference, so that the entity will have a
4507 -- reference, which will inhibit any warnings about it not
4508 -- being referenced, and also properly show up in the ali file
4509 -- as a reference. But this reference is recorded before the
4510 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4511 -- generated for this reference.
4513 Check_Arg_Is_Local_Name (Arg);
4514 Arg_Expr := Get_Pragma_Arg (Arg);
4516 if Is_Entity_Name (Arg_Expr) then
4517 Arg_Id := Entity (Arg_Expr);
4519 -- Skip processing the argument if already flagged
4521 if Is_Assignable (Arg_Id)
4522 and then not Has_Pragma_Unmodified (Arg_Id)
4523 and then not Has_Pragma_Unused (Arg_Id)
4525 Set_Has_Pragma_Unmodified (Arg_Id);
4528 Set_Has_Pragma_Unused (Arg_Id);
4531 -- A pragma that applies to a Ghost entity becomes Ghost for
4532 -- the purposes of legality checks and removal of ignored
4535 Mark_Pragma_As_Ghost (N, Arg_Id);
4537 -- Capture the entity of the first Ghost variable being
4538 -- processed for error detection purposes.
4540 if Is_Ghost_Entity (Arg_Id) then
4541 if No (Ghost_Id) then
4545 -- Otherwise the variable is non-Ghost. It is illegal to mix
4546 -- references to Ghost and non-Ghost entities
4549 elsif Present (Ghost_Id)
4550 and then not Ghost_Error_Posted
4552 Ghost_Error_Posted := True;
4554 Error_Msg_Name_1 := Pname;
4556 ("pragma % cannot mention ghost and non-ghost "
4559 Error_Msg_Sloc := Sloc (Ghost_Id);
4560 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4562 Error_Msg_Sloc := Sloc (Arg_Id);
4563 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4566 -- Warn if already flagged as Unused or Unmodified
4568 elsif Has_Pragma_Unmodified (Arg_Id) then
4569 if Has_Pragma_Unused (Arg_Id) then
4571 ("??pragma Unused already given for &!", Arg_Expr,
4575 ("??pragma Unmodified already given for &!", Arg_Expr,
4579 -- Otherwise the pragma referenced an illegal entity
4583 ("pragma% can only be applied to a variable", Arg_Expr);
4589 end Analyze_Unmodified_Or_Unused;
4591 -----------------------------------
4592 -- Analyze_Unreference_Or_Unused --
4593 -----------------------------------
4595 procedure Analyze_Unreferenced_Or_Unused
4596 (Is_Unused : Boolean := False)
4603 Ghost_Error_Posted : Boolean := False;
4604 -- Flag set when an error concerning the illegal mix of Ghost and
4605 -- non-Ghost names is emitted.
4607 Ghost_Id : Entity_Id := Empty;
4608 -- The entity of the first Ghost name encountered while processing
4609 -- the arguments of the pragma.
4613 Check_At_Least_N_Arguments (1);
4615 -- Check case of appearing within context clause
4617 if not Is_Unused and then Is_In_Context_Clause then
4619 -- The arguments must all be units mentioned in a with clause in
4620 -- the same context clause. Note that Par.Prag already checked
4621 -- that the arguments are either identifiers or selected
4625 while Present (Arg) loop
4626 Citem := First (List_Containing (N));
4627 while Citem /= N loop
4628 Arg_Expr := Get_Pragma_Arg (Arg);
4630 if Nkind (Citem) = N_With_Clause
4631 and then Same_Name (Name (Citem), Arg_Expr)
4633 Set_Has_Pragma_Unreferenced
4636 (Library_Unit (Citem))));
4637 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
4646 ("argument of pragma% is not withed unit", Arg);
4652 -- Case of not in list of context items
4656 while Present (Arg) loop
4657 Check_No_Identifier (Arg);
4659 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4660 -- in fact generate reference, so that the entity will have a
4661 -- reference, which will inhibit any warnings about it not
4662 -- being referenced, and also properly show up in the ali file
4663 -- as a reference. But this reference is recorded before the
4664 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4665 -- generated for this reference.
4667 Check_Arg_Is_Local_Name (Arg);
4668 Arg_Expr := Get_Pragma_Arg (Arg);
4670 if Is_Entity_Name (Arg_Expr) then
4671 Arg_Id := Entity (Arg_Expr);
4673 -- Warn if already flagged as Unused or Unreferenced and
4674 -- skip processing the argument.
4676 if Has_Pragma_Unreferenced (Arg_Id) then
4677 if Has_Pragma_Unused (Arg_Id) then
4679 ("??pragma Unused already given for &!", Arg_Expr,
4683 ("??pragma Unreferenced already given for &!",
4687 -- Apply Unreferenced to the entity
4690 -- If the entity is overloaded, the pragma applies to the
4691 -- most recent overloading, as documented. In this case,
4692 -- name resolution does not generate a reference, so it
4693 -- must be done here explicitly.
4695 if Is_Overloaded (Arg_Expr) then
4696 Generate_Reference (Arg_Id, N);
4699 Set_Has_Pragma_Unreferenced (Arg_Id);
4702 Set_Has_Pragma_Unused (Arg_Id);
4705 -- A pragma that applies to a Ghost entity becomes Ghost
4706 -- for the purposes of legality checks and removal of
4707 -- ignored Ghost code.
4709 Mark_Pragma_As_Ghost (N, Arg_Id);
4711 -- Capture the entity of the first Ghost name being
4712 -- processed for error detection purposes.
4714 if Is_Ghost_Entity (Arg_Id) then
4715 if No (Ghost_Id) then
4719 -- Otherwise the name is non-Ghost. It is illegal to mix
4720 -- references to Ghost and non-Ghost entities
4723 elsif Present (Ghost_Id)
4724 and then not Ghost_Error_Posted
4726 Ghost_Error_Posted := True;
4728 Error_Msg_Name_1 := Pname;
4730 ("pragma % cannot mention ghost and non-ghost "
4733 Error_Msg_Sloc := Sloc (Ghost_Id);
4735 ("\& # declared as ghost", N, Ghost_Id);
4737 Error_Msg_Sloc := Sloc (Arg_Id);
4739 ("\& # declared as non-ghost", N, Arg_Id);
4747 end Analyze_Unreferenced_Or_Unused;
4749 --------------------------
4750 -- Check_Ada_83_Warning --
4751 --------------------------
4753 procedure Check_Ada_83_Warning is
4755 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4756 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4758 end Check_Ada_83_Warning;
4760 ---------------------
4761 -- Check_Arg_Count --
4762 ---------------------
4764 procedure Check_Arg_Count (Required : Nat) is
4766 if Arg_Count /= Required then
4767 Error_Pragma ("wrong number of arguments for pragma%");
4769 end Check_Arg_Count;
4771 --------------------------------
4772 -- Check_Arg_Is_External_Name --
4773 --------------------------------
4775 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4776 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4779 if Nkind (Argx) = N_Identifier then
4783 Analyze_And_Resolve (Argx, Standard_String);
4785 if Is_OK_Static_Expression (Argx) then
4788 elsif Etype (Argx) = Any_Type then
4791 -- An interesting special case, if we have a string literal and
4792 -- we are in Ada 83 mode, then we allow it even though it will
4793 -- not be flagged as static. This allows expected Ada 83 mode
4794 -- use of external names which are string literals, even though
4795 -- technically these are not static in Ada 83.
4797 elsif Ada_Version = Ada_83
4798 and then Nkind (Argx) = N_String_Literal
4802 -- Static expression that raises Constraint_Error. This has
4803 -- already been flagged, so just exit from pragma processing.
4805 elsif Is_OK_Static_Expression (Argx) then
4808 -- Here we have a real error (non-static expression)
4811 Error_Msg_Name_1 := Pname;
4814 Msg : constant String :=
4815 "argument for pragma% must be a identifier or "
4816 & "static string expression!";
4818 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4823 end Check_Arg_Is_External_Name;
4825 -----------------------------
4826 -- Check_Arg_Is_Identifier --
4827 -----------------------------
4829 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4830 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4832 if Nkind (Argx) /= N_Identifier then
4834 ("argument for pragma% must be identifier", Argx);
4836 end Check_Arg_Is_Identifier;
4838 ----------------------------------
4839 -- Check_Arg_Is_Integer_Literal --
4840 ----------------------------------
4842 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4843 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4845 if Nkind (Argx) /= N_Integer_Literal then
4847 ("argument for pragma% must be integer literal", Argx);
4849 end Check_Arg_Is_Integer_Literal;
4851 -------------------------------------------
4852 -- Check_Arg_Is_Library_Level_Local_Name --
4853 -------------------------------------------
4857 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4858 -- | library_unit_NAME
4860 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4862 Check_Arg_Is_Local_Name (Arg);
4864 -- If it came from an aspect, we want to give the error just as if it
4865 -- came from source.
4867 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4868 and then (Comes_From_Source (N)
4869 or else Present (Corresponding_Aspect (Parent (Arg))))
4872 ("argument for pragma% must be library level entity", Arg);
4874 end Check_Arg_Is_Library_Level_Local_Name;
4876 -----------------------------
4877 -- Check_Arg_Is_Local_Name --
4878 -----------------------------
4882 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4883 -- | library_unit_NAME
4885 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4886 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4889 -- If this pragma came from an aspect specification, we don't want to
4890 -- check for this error, because that would cause spurious errors, in
4891 -- case a type is frozen in a scope more nested than the type. The
4892 -- aspect itself of course can't be anywhere but on the declaration
4895 if Nkind (Arg) = N_Pragma_Argument_Association then
4896 if From_Aspect_Specification (Parent (Arg)) then
4900 -- Arg is the Expression of an N_Pragma_Argument_Association
4903 if From_Aspect_Specification (Parent (Parent (Arg))) then
4910 if Nkind (Argx) not in N_Direct_Name
4911 and then (Nkind (Argx) /= N_Attribute_Reference
4912 or else Present (Expressions (Argx))
4913 or else Nkind (Prefix (Argx)) /= N_Identifier)
4914 and then (not Is_Entity_Name (Argx)
4915 or else not Is_Compilation_Unit (Entity (Argx)))
4917 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4920 -- No further check required if not an entity name
4922 if not Is_Entity_Name (Argx) then
4928 Ent : constant Entity_Id := Entity (Argx);
4929 Scop : constant Entity_Id := Scope (Ent);
4932 -- Case of a pragma applied to a compilation unit: pragma must
4933 -- occur immediately after the program unit in the compilation.
4935 if Is_Compilation_Unit (Ent) then
4937 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4940 -- Case of pragma placed immediately after spec
4942 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4945 -- Case of pragma placed immediately after body
4947 elsif Nkind (Decl) = N_Subprogram_Declaration
4948 and then Present (Corresponding_Body (Decl))
4952 (Parent (Unit_Declaration_Node
4953 (Corresponding_Body (Decl))));
4955 -- All other cases are illegal
4962 -- Special restricted placement rule from 10.2.1(11.8/2)
4964 elsif Is_Generic_Formal (Ent)
4965 and then Prag_Id = Pragma_Preelaborable_Initialization
4967 OK := List_Containing (N) =
4968 Generic_Formal_Declarations
4969 (Unit_Declaration_Node (Scop));
4971 -- If this is an aspect applied to a subprogram body, the
4972 -- pragma is inserted in its declarative part.
4974 elsif From_Aspect_Specification (N)
4975 and then Ent = Current_Scope
4977 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4981 -- If the aspect is a predicate (possibly others ???) and the
4982 -- context is a record type, this is a discriminant expression
4983 -- within a type declaration, that freezes the predicated
4986 elsif From_Aspect_Specification (N)
4987 and then Prag_Id = Pragma_Predicate
4988 and then Ekind (Current_Scope) = E_Record_Type
4989 and then Scop = Scope (Current_Scope)
4993 -- Default case, just check that the pragma occurs in the scope
4994 -- of the entity denoted by the name.
4997 OK := Current_Scope = Scop;
5002 ("pragma% argument must be in same declarative part", Arg);
5006 end Check_Arg_Is_Local_Name;
5008 ---------------------------------
5009 -- Check_Arg_Is_Locking_Policy --
5010 ---------------------------------
5012 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5013 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5016 Check_Arg_Is_Identifier (Argx);
5018 if not Is_Locking_Policy_Name (Chars (Argx)) then
5019 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5021 end Check_Arg_Is_Locking_Policy;
5023 -----------------------------------------------
5024 -- Check_Arg_Is_Partition_Elaboration_Policy --
5025 -----------------------------------------------
5027 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5028 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5031 Check_Arg_Is_Identifier (Argx);
5033 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5035 ("& is not a valid partition elaboration policy name", Argx);
5037 end Check_Arg_Is_Partition_Elaboration_Policy;
5039 -------------------------
5040 -- Check_Arg_Is_One_Of --
5041 -------------------------
5043 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5044 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5047 Check_Arg_Is_Identifier (Argx);
5049 if not Nam_In (Chars (Argx), N1, N2) then
5050 Error_Msg_Name_2 := N1;
5051 Error_Msg_Name_3 := N2;
5052 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5054 end Check_Arg_Is_One_Of;
5056 procedure Check_Arg_Is_One_Of
5058 N1, N2, N3 : Name_Id)
5060 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5063 Check_Arg_Is_Identifier (Argx);
5065 if not Nam_In (Chars (Argx), N1, N2, N3) then
5066 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5068 end Check_Arg_Is_One_Of;
5070 procedure Check_Arg_Is_One_Of
5072 N1, N2, N3, N4 : Name_Id)
5074 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5077 Check_Arg_Is_Identifier (Argx);
5079 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5080 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5082 end Check_Arg_Is_One_Of;
5084 procedure Check_Arg_Is_One_Of
5086 N1, N2, N3, N4, N5 : Name_Id)
5088 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5091 Check_Arg_Is_Identifier (Argx);
5093 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5094 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5096 end Check_Arg_Is_One_Of;
5098 ---------------------------------
5099 -- Check_Arg_Is_Queuing_Policy --
5100 ---------------------------------
5102 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5103 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5106 Check_Arg_Is_Identifier (Argx);
5108 if not Is_Queuing_Policy_Name (Chars (Argx)) then
5109 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5111 end Check_Arg_Is_Queuing_Policy;
5113 ---------------------------------------
5114 -- Check_Arg_Is_OK_Static_Expression --
5115 ---------------------------------------
5117 procedure Check_Arg_Is_OK_Static_Expression
5119 Typ : Entity_Id := Empty)
5122 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5123 end Check_Arg_Is_OK_Static_Expression;
5125 ------------------------------------------
5126 -- Check_Arg_Is_Task_Dispatching_Policy --
5127 ------------------------------------------
5129 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5130 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5133 Check_Arg_Is_Identifier (Argx);
5135 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5137 ("& is not an allowed task dispatching policy name", Argx);
5139 end Check_Arg_Is_Task_Dispatching_Policy;
5141 ---------------------
5142 -- Check_Arg_Order --
5143 ---------------------
5145 procedure Check_Arg_Order (Names : Name_List) is
5148 Highest_So_Far : Natural := 0;
5149 -- Highest index in Names seen do far
5153 for J in 1 .. Arg_Count loop
5154 if Chars (Arg) /= No_Name then
5155 for K in Names'Range loop
5156 if Chars (Arg) = Names (K) then
5157 if K < Highest_So_Far then
5158 Error_Msg_Name_1 := Pname;
5160 ("parameters out of order for pragma%", Arg);
5161 Error_Msg_Name_1 := Names (K);
5162 Error_Msg_Name_2 := Names (Highest_So_Far);
5163 Error_Msg_N ("\% must appear before %", Arg);
5167 Highest_So_Far := K;
5175 end Check_Arg_Order;
5177 --------------------------------
5178 -- Check_At_Least_N_Arguments --
5179 --------------------------------
5181 procedure Check_At_Least_N_Arguments (N : Nat) is
5183 if Arg_Count < N then
5184 Error_Pragma ("too few arguments for pragma%");
5186 end Check_At_Least_N_Arguments;
5188 -------------------------------
5189 -- Check_At_Most_N_Arguments --
5190 -------------------------------
5192 procedure Check_At_Most_N_Arguments (N : Nat) is
5195 if Arg_Count > N then
5197 for J in 1 .. N loop
5199 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5202 end Check_At_Most_N_Arguments;
5204 ---------------------
5205 -- Check_Component --
5206 ---------------------
5208 procedure Check_Component
5211 In_Variant_Part : Boolean := False)
5213 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5214 Sindic : constant Node_Id :=
5215 Subtype_Indication (Component_Definition (Comp));
5216 Typ : constant Entity_Id := Etype (Comp_Id);
5219 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5220 -- object constraint, then the component type shall be an Unchecked_
5223 if Nkind (Sindic) = N_Subtype_Indication
5224 and then Has_Per_Object_Constraint (Comp_Id)
5225 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5228 ("component subtype subject to per-object constraint "
5229 & "must be an Unchecked_Union", Comp);
5231 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5232 -- the body of a generic unit, or within the body of any of its
5233 -- descendant library units, no part of the type of a component
5234 -- declared in a variant_part of the unchecked union type shall be of
5235 -- a formal private type or formal private extension declared within
5236 -- the formal part of the generic unit.
5238 elsif Ada_Version >= Ada_2012
5239 and then In_Generic_Body (UU_Typ)
5240 and then In_Variant_Part
5241 and then Is_Private_Type (Typ)
5242 and then Is_Generic_Type (Typ)
5245 ("component of unchecked union cannot be of generic type", Comp);
5247 elsif Needs_Finalization (Typ) then
5249 ("component of unchecked union cannot be controlled", Comp);
5251 elsif Has_Task (Typ) then
5253 ("component of unchecked union cannot have tasks", Comp);
5255 end Check_Component;
5257 ----------------------------
5258 -- Check_Duplicate_Pragma --
5259 ----------------------------
5261 procedure Check_Duplicate_Pragma (E : Entity_Id) is
5262 Id : Entity_Id := E;
5266 -- Nothing to do if this pragma comes from an aspect specification,
5267 -- since we could not be duplicating a pragma, and we dealt with the
5268 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5270 if From_Aspect_Specification (N) then
5274 -- Otherwise current pragma may duplicate previous pragma or a
5275 -- previously given aspect specification or attribute definition
5276 -- clause for the same pragma.
5278 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5282 -- If the entity is a type, then we have to make sure that the
5283 -- ostensible duplicate is not for a parent type from which this
5287 if Nkind (P) = N_Pragma then
5289 Args : constant List_Id :=
5290 Pragma_Argument_Associations (P);
5293 and then Is_Entity_Name (Expression (First (Args)))
5294 and then Is_Type (Entity (Expression (First (Args))))
5295 and then Entity (Expression (First (Args))) /= E
5301 elsif Nkind (P) = N_Aspect_Specification
5302 and then Is_Type (Entity (P))
5303 and then Entity (P) /= E
5309 -- Here we have a definite duplicate
5311 Error_Msg_Name_1 := Pragma_Name (N);
5312 Error_Msg_Sloc := Sloc (P);
5314 -- For a single protected or a single task object, the error is
5315 -- issued on the original entity.
5317 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5318 Id := Defining_Identifier (Original_Node (Parent (Id)));
5321 if Nkind (P) = N_Aspect_Specification
5322 or else From_Aspect_Specification (P)
5324 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5326 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5331 end Check_Duplicate_Pragma;
5333 ----------------------------------
5334 -- Check_Duplicated_Export_Name --
5335 ----------------------------------
5337 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5338 String_Val : constant String_Id := Strval (Nam);
5341 -- We are only interested in the export case, and in the case of
5342 -- generics, it is the instance, not the template, that is the
5343 -- problem (the template will generate a warning in any case).
5345 if not Inside_A_Generic
5346 and then (Prag_Id = Pragma_Export
5348 Prag_Id = Pragma_Export_Procedure
5350 Prag_Id = Pragma_Export_Valued_Procedure
5352 Prag_Id = Pragma_Export_Function)
5354 for J in Externals.First .. Externals.Last loop
5355 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5356 Error_Msg_Sloc := Sloc (Externals.Table (J));
5357 Error_Msg_N ("external name duplicates name given#", Nam);
5362 Externals.Append (Nam);
5364 end Check_Duplicated_Export_Name;
5366 ----------------------------------------
5367 -- Check_Expr_Is_OK_Static_Expression --
5368 ----------------------------------------
5370 procedure Check_Expr_Is_OK_Static_Expression
5372 Typ : Entity_Id := Empty)
5375 if Present (Typ) then
5376 Analyze_And_Resolve (Expr, Typ);
5378 Analyze_And_Resolve (Expr);
5381 -- An expression cannot be considered static if its resolution failed
5382 -- or if it's erroneous. Stop the analysis of the related pragma.
5384 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5387 elsif Is_OK_Static_Expression (Expr) then
5390 -- An interesting special case, if we have a string literal and we
5391 -- are in Ada 83 mode, then we allow it even though it will not be
5392 -- flagged as static. This allows the use of Ada 95 pragmas like
5393 -- Import in Ada 83 mode. They will of course be flagged with
5394 -- warnings as usual, but will not cause errors.
5396 elsif Ada_Version = Ada_83
5397 and then Nkind (Expr) = N_String_Literal
5401 -- Finally, we have a real error
5404 Error_Msg_Name_1 := Pname;
5405 Flag_Non_Static_Expr
5406 (Fix_Error ("argument for pragma% must be a static expression!"),
5410 end Check_Expr_Is_OK_Static_Expression;
5412 -------------------------
5413 -- Check_First_Subtype --
5414 -------------------------
5416 procedure Check_First_Subtype (Arg : Node_Id) is
5417 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5418 Ent : constant Entity_Id := Entity (Argx);
5421 if Is_First_Subtype (Ent) then
5424 elsif Is_Type (Ent) then
5426 ("pragma% cannot apply to subtype", Argx);
5428 elsif Is_Object (Ent) then
5430 ("pragma% cannot apply to object, requires a type", Argx);
5434 ("pragma% cannot apply to&, requires a type", Argx);
5436 end Check_First_Subtype;
5438 ----------------------
5439 -- Check_Identifier --
5440 ----------------------
5442 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5445 and then Nkind (Arg) = N_Pragma_Argument_Association
5447 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5448 Error_Msg_Name_1 := Pname;
5449 Error_Msg_Name_2 := Id;
5450 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5454 end Check_Identifier;
5456 --------------------------------
5457 -- Check_Identifier_Is_One_Of --
5458 --------------------------------
5460 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5463 and then Nkind (Arg) = N_Pragma_Argument_Association
5465 if Chars (Arg) = No_Name then
5466 Error_Msg_Name_1 := Pname;
5467 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5470 elsif Chars (Arg) /= N1
5471 and then Chars (Arg) /= N2
5473 Error_Msg_Name_1 := Pname;
5474 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5478 end Check_Identifier_Is_One_Of;
5480 ---------------------------
5481 -- Check_In_Main_Program --
5482 ---------------------------
5484 procedure Check_In_Main_Program is
5485 P : constant Node_Id := Parent (N);
5488 -- Must be in subprogram body
5490 if Nkind (P) /= N_Subprogram_Body then
5491 Error_Pragma ("% pragma allowed only in subprogram");
5493 -- Otherwise warn if obviously not main program
5495 elsif Present (Parameter_Specifications (Specification (P)))
5496 or else not Is_Compilation_Unit (Defining_Entity (P))
5498 Error_Msg_Name_1 := Pname;
5500 ("??pragma% is only effective in main program", N);
5502 end Check_In_Main_Program;
5504 ---------------------------------------
5505 -- Check_Interrupt_Or_Attach_Handler --
5506 ---------------------------------------
5508 procedure Check_Interrupt_Or_Attach_Handler is
5509 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5510 Handler_Proc, Proc_Scope : Entity_Id;
5515 if Prag_Id = Pragma_Interrupt_Handler then
5516 Check_Restriction (No_Dynamic_Attachment, N);
5519 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5520 Proc_Scope := Scope (Handler_Proc);
5522 if Ekind (Proc_Scope) /= E_Protected_Type then
5524 ("argument of pragma% must be protected procedure", Arg1);
5527 -- For pragma case (as opposed to access case), check placement.
5528 -- We don't need to do that for aspects, because we have the
5529 -- check that they aspect applies an appropriate procedure.
5531 if not From_Aspect_Specification (N)
5532 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5534 Error_Pragma ("pragma% must be in protected definition");
5537 if not Is_Library_Level_Entity (Proc_Scope) then
5539 ("argument for pragma% must be library level entity", Arg1);
5542 -- AI05-0033: A pragma cannot appear within a generic body, because
5543 -- instance can be in a nested scope. The check that protected type
5544 -- is itself a library-level declaration is done elsewhere.
5546 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5547 -- handle code prior to AI-0033. Analysis tools typically are not
5548 -- interested in this pragma in any case, so no need to worry too
5549 -- much about its placement.
5551 if Inside_A_Generic then
5552 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5553 and then In_Package_Body (Scope (Current_Scope))
5554 and then not Relaxed_RM_Semantics
5556 Error_Pragma ("pragma% cannot be used inside a generic");
5559 end Check_Interrupt_Or_Attach_Handler;
5561 ---------------------------------
5562 -- Check_Loop_Pragma_Placement --
5563 ---------------------------------
5565 procedure Check_Loop_Pragma_Placement is
5566 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5567 -- Verify whether the current pragma is properly grouped with other
5568 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5569 -- related loop where the pragma appears.
5571 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5572 -- Determine whether an arbitrary statement Stmt denotes pragma
5573 -- Loop_Invariant or Loop_Variant.
5575 procedure Placement_Error (Constr : Node_Id);
5576 pragma No_Return (Placement_Error);
5577 -- Node Constr denotes the last loop restricted construct before we
5578 -- encountered an illegal relation between enclosing constructs. Emit
5579 -- an error depending on what Constr was.
5581 --------------------------------
5582 -- Check_Loop_Pragma_Grouping --
5583 --------------------------------
5585 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5586 Stop_Search : exception;
5587 -- This exception is used to terminate the recursive descent of
5588 -- routine Check_Grouping.
5590 procedure Check_Grouping (L : List_Id);
5591 -- Find the first group of pragmas in list L and if successful,
5592 -- ensure that the current pragma is part of that group. The
5593 -- routine raises Stop_Search once such a check is performed to
5594 -- halt the recursive descent.
5596 procedure Grouping_Error (Prag : Node_Id);
5597 pragma No_Return (Grouping_Error);
5598 -- Emit an error concerning the current pragma indicating that it
5599 -- should be placed after pragma Prag.
5601 --------------------
5602 -- Check_Grouping --
5603 --------------------
5605 procedure Check_Grouping (L : List_Id) is
5611 -- Inspect the list of declarations or statements looking for
5612 -- the first grouping of pragmas:
5615 -- pragma Loop_Invariant ...;
5616 -- pragma Loop_Variant ...;
5618 -- pragma Loop_Variant ...; -- current pragma
5620 -- If the current pragma is not in the grouping, then it must
5621 -- either appear in a different declarative or statement list
5622 -- or the construct at (1) is separating the pragma from the
5626 while Present (Stmt) loop
5628 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5629 -- inside a loop or a block housed inside a loop. Inspect
5630 -- the declarations and statements of the block as they may
5631 -- contain the first grouping.
5633 if Nkind (Stmt) = N_Block_Statement then
5634 HSS := Handled_Statement_Sequence (Stmt);
5636 Check_Grouping (Declarations (Stmt));
5638 if Present (HSS) then
5639 Check_Grouping (Statements (HSS));
5642 -- First pragma of the first topmost grouping has been found
5644 elsif Is_Loop_Pragma (Stmt) then
5646 -- The group and the current pragma are not in the same
5647 -- declarative or statement list.
5649 if List_Containing (Stmt) /= List_Containing (N) then
5650 Grouping_Error (Stmt);
5652 -- Try to reach the current pragma from the first pragma
5653 -- of the grouping while skipping other members:
5655 -- pragma Loop_Invariant ...; -- first pragma
5656 -- pragma Loop_Variant ...; -- member
5658 -- pragma Loop_Variant ...; -- current pragma
5661 while Present (Stmt) loop
5663 -- The current pragma is either the first pragma
5664 -- of the group or is a member of the group. Stop
5665 -- the search as the placement is legal.
5670 -- Skip group members, but keep track of the last
5671 -- pragma in the group.
5673 elsif Is_Loop_Pragma (Stmt) then
5676 -- Skip declarations and statements generated by
5677 -- the compiler during expansion.
5679 elsif not Comes_From_Source (Stmt) then
5682 -- A non-pragma is separating the group from the
5683 -- current pragma, the placement is illegal.
5686 Grouping_Error (Prag);
5692 -- If the traversal did not reach the current pragma,
5693 -- then the list must be malformed.
5695 raise Program_Error;
5703 --------------------
5704 -- Grouping_Error --
5705 --------------------
5707 procedure Grouping_Error (Prag : Node_Id) is
5709 Error_Msg_Sloc := Sloc (Prag);
5710 Error_Pragma ("pragma% must appear next to pragma#");
5713 -- Start of processing for Check_Loop_Pragma_Grouping
5716 -- Inspect the statements of the loop or nested blocks housed
5717 -- within to determine whether the current pragma is part of the
5718 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5720 Check_Grouping (Statements (Loop_Stmt));
5723 when Stop_Search => null;
5724 end Check_Loop_Pragma_Grouping;
5726 --------------------
5727 -- Is_Loop_Pragma --
5728 --------------------
5730 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5732 -- Inspect the original node as Loop_Invariant and Loop_Variant
5733 -- pragmas are rewritten to null when assertions are disabled.
5735 if Nkind (Original_Node (Stmt)) = N_Pragma then
5737 Nam_In (Pragma_Name (Original_Node (Stmt)),
5738 Name_Loop_Invariant,
5745 ---------------------
5746 -- Placement_Error --
5747 ---------------------
5749 procedure Placement_Error (Constr : Node_Id) is
5750 LA : constant String := " with Loop_Entry";
5753 if Prag_Id = Pragma_Assert then
5754 Error_Msg_String (1 .. LA'Length) := LA;
5755 Error_Msg_Strlen := LA'Length;
5757 Error_Msg_Strlen := 0;
5760 if Nkind (Constr) = N_Pragma then
5762 ("pragma %~ must appear immediately within the statements "
5766 ("block containing pragma %~ must appear immediately within "
5767 & "the statements of a loop", Constr);
5769 end Placement_Error;
5771 -- Local declarations
5776 -- Start of processing for Check_Loop_Pragma_Placement
5779 -- Check that pragma appears immediately within a loop statement,
5780 -- ignoring intervening block statements.
5784 while Present (Stmt) loop
5786 -- The pragma or previous block must appear immediately within the
5787 -- current block's declarative or statement part.
5789 if Nkind (Stmt) = N_Block_Statement then
5790 if (No (Declarations (Stmt))
5791 or else List_Containing (Prev) /= Declarations (Stmt))
5793 List_Containing (Prev) /=
5794 Statements (Handled_Statement_Sequence (Stmt))
5796 Placement_Error (Prev);
5799 -- Keep inspecting the parents because we are now within a
5800 -- chain of nested blocks.
5804 Stmt := Parent (Stmt);
5807 -- The pragma or previous block must appear immediately within the
5808 -- statements of the loop.
5810 elsif Nkind (Stmt) = N_Loop_Statement then
5811 if List_Containing (Prev) /= Statements (Stmt) then
5812 Placement_Error (Prev);
5815 -- Stop the traversal because we reached the innermost loop
5816 -- regardless of whether we encountered an error or not.
5820 -- Ignore a handled statement sequence. Note that this node may
5821 -- be related to a subprogram body in which case we will emit an
5822 -- error on the next iteration of the search.
5824 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5825 Stmt := Parent (Stmt);
5827 -- Any other statement breaks the chain from the pragma to the
5831 Placement_Error (Prev);
5836 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5837 -- grouped together with other such pragmas.
5839 if Is_Loop_Pragma (N) then
5841 -- The previous check should have located the related loop
5843 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5844 Check_Loop_Pragma_Grouping (Stmt);
5846 end Check_Loop_Pragma_Placement;
5848 -------------------------------------------
5849 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5850 -------------------------------------------
5852 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5861 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5864 elsif Nkind_In (P, N_Package_Specification,
5869 -- Note: the following tests seem a little peculiar, because
5870 -- they test for bodies, but if we were in the statement part
5871 -- of the body, we would already have hit the handled statement
5872 -- sequence, so the only way we get here is by being in the
5873 -- declarative part of the body.
5875 elsif Nkind_In (P, N_Subprogram_Body,
5886 Error_Pragma ("pragma% is not in declarative part or package spec");
5887 end Check_Is_In_Decl_Part_Or_Package_Spec;
5889 -------------------------
5890 -- Check_No_Identifier --
5891 -------------------------
5893 procedure Check_No_Identifier (Arg : Node_Id) is
5895 if Nkind (Arg) = N_Pragma_Argument_Association
5896 and then Chars (Arg) /= No_Name
5898 Error_Pragma_Arg_Ident
5899 ("pragma% does not permit identifier& here", Arg);
5901 end Check_No_Identifier;
5903 --------------------------
5904 -- Check_No_Identifiers --
5905 --------------------------
5907 procedure Check_No_Identifiers is
5911 for J in 1 .. Arg_Count loop
5912 Check_No_Identifier (Arg_Node);
5915 end Check_No_Identifiers;
5917 ------------------------
5918 -- Check_No_Link_Name --
5919 ------------------------
5921 procedure Check_No_Link_Name is
5923 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5927 if Present (Arg4) then
5929 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5931 end Check_No_Link_Name;
5933 -------------------------------
5934 -- Check_Optional_Identifier --
5935 -------------------------------
5937 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5940 and then Nkind (Arg) = N_Pragma_Argument_Association
5941 and then Chars (Arg) /= No_Name
5943 if Chars (Arg) /= Id then
5944 Error_Msg_Name_1 := Pname;
5945 Error_Msg_Name_2 := Id;
5946 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5950 end Check_Optional_Identifier;
5952 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5954 Name_Buffer (1 .. Id'Length) := Id;
5955 Name_Len := Id'Length;
5956 Check_Optional_Identifier (Arg, Name_Find);
5957 end Check_Optional_Identifier;
5959 -------------------------------------
5960 -- Check_Static_Boolean_Expression --
5961 -------------------------------------
5963 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5965 if Present (Expr) then
5966 Analyze_And_Resolve (Expr, Standard_Boolean);
5968 if not Is_OK_Static_Expression (Expr) then
5970 ("expression of pragma % must be static", Expr);
5973 end Check_Static_Boolean_Expression;
5975 -----------------------------
5976 -- Check_Static_Constraint --
5977 -----------------------------
5979 -- Note: for convenience in writing this procedure, in addition to
5980 -- the officially (i.e. by spec) allowed argument which is always a
5981 -- constraint, it also allows ranges and discriminant associations.
5982 -- Above is not clear ???
5984 procedure Check_Static_Constraint (Constr : Node_Id) is
5986 procedure Require_Static (E : Node_Id);
5987 -- Require given expression to be static expression
5989 --------------------
5990 -- Require_Static --
5991 --------------------
5993 procedure Require_Static (E : Node_Id) is
5995 if not Is_OK_Static_Expression (E) then
5996 Flag_Non_Static_Expr
5997 ("non-static constraint not allowed in Unchecked_Union!", E);
6002 -- Start of processing for Check_Static_Constraint
6005 case Nkind (Constr) is
6006 when N_Discriminant_Association =>
6007 Require_Static (Expression (Constr));
6010 Require_Static (Low_Bound (Constr));
6011 Require_Static (High_Bound (Constr));
6013 when N_Attribute_Reference =>
6014 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
6015 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6017 when N_Range_Constraint =>
6018 Check_Static_Constraint (Range_Expression (Constr));
6020 when N_Index_Or_Discriminant_Constraint =>
6024 IDC := First (Constraints (Constr));
6025 while Present (IDC) loop
6026 Check_Static_Constraint (IDC);
6034 end Check_Static_Constraint;
6036 --------------------------------------
6037 -- Check_Valid_Configuration_Pragma --
6038 --------------------------------------
6040 -- A configuration pragma must appear in the context clause of a
6041 -- compilation unit, and only other pragmas may precede it. Note that
6042 -- the test also allows use in a configuration pragma file.
6044 procedure Check_Valid_Configuration_Pragma is
6046 if not Is_Configuration_Pragma then
6047 Error_Pragma ("incorrect placement for configuration pragma%");
6049 end Check_Valid_Configuration_Pragma;
6051 -------------------------------------
6052 -- Check_Valid_Library_Unit_Pragma --
6053 -------------------------------------
6055 procedure Check_Valid_Library_Unit_Pragma is
6057 Parent_Node : Node_Id;
6058 Unit_Name : Entity_Id;
6059 Unit_Kind : Node_Kind;
6060 Unit_Node : Node_Id;
6061 Sindex : Source_File_Index;
6064 if not Is_List_Member (N) then
6068 Plist := List_Containing (N);
6069 Parent_Node := Parent (Plist);
6071 if Parent_Node = Empty then
6074 -- Case of pragma appearing after a compilation unit. In this case
6075 -- it must have an argument with the corresponding name and must
6076 -- be part of the following pragmas of its parent.
6078 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6079 if Plist /= Pragmas_After (Parent_Node) then
6082 elsif Arg_Count = 0 then
6084 ("argument required if outside compilation unit");
6087 Check_No_Identifiers;
6088 Check_Arg_Count (1);
6089 Unit_Node := Unit (Parent (Parent_Node));
6090 Unit_Kind := Nkind (Unit_Node);
6092 Analyze (Get_Pragma_Arg (Arg1));
6094 if Unit_Kind = N_Generic_Subprogram_Declaration
6095 or else Unit_Kind = N_Subprogram_Declaration
6097 Unit_Name := Defining_Entity (Unit_Node);
6099 elsif Unit_Kind in N_Generic_Instantiation then
6100 Unit_Name := Defining_Entity (Unit_Node);
6103 Unit_Name := Cunit_Entity (Current_Sem_Unit);
6106 if Chars (Unit_Name) /=
6107 Chars (Entity (Get_Pragma_Arg (Arg1)))
6110 ("pragma% argument is not current unit name", Arg1);
6113 if Ekind (Unit_Name) = E_Package
6114 and then Present (Renamed_Entity (Unit_Name))
6116 Error_Pragma ("pragma% not allowed for renamed package");
6120 -- Pragma appears other than after a compilation unit
6123 -- Here we check for the generic instantiation case and also
6124 -- for the case of processing a generic formal package. We
6125 -- detect these cases by noting that the Sloc on the node
6126 -- does not belong to the current compilation unit.
6128 Sindex := Source_Index (Current_Sem_Unit);
6130 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6131 Rewrite (N, Make_Null_Statement (Loc));
6134 -- If before first declaration, the pragma applies to the
6135 -- enclosing unit, and the name if present must be this name.
6137 elsif Is_Before_First_Decl (N, Plist) then
6138 Unit_Node := Unit_Declaration_Node (Current_Scope);
6139 Unit_Kind := Nkind (Unit_Node);
6141 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6144 elsif Unit_Kind = N_Subprogram_Body
6145 and then not Acts_As_Spec (Unit_Node)
6149 elsif Nkind (Parent_Node) = N_Package_Body then
6152 elsif Nkind (Parent_Node) = N_Package_Specification
6153 and then Plist = Private_Declarations (Parent_Node)
6157 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6158 or else Nkind (Parent_Node) =
6159 N_Generic_Subprogram_Declaration)
6160 and then Plist = Generic_Formal_Declarations (Parent_Node)
6164 elsif Arg_Count > 0 then
6165 Analyze (Get_Pragma_Arg (Arg1));
6167 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6169 ("name in pragma% must be enclosing unit", Arg1);
6172 -- It is legal to have no argument in this context
6178 -- Error if not before first declaration. This is because a
6179 -- library unit pragma argument must be the name of a library
6180 -- unit (RM 10.1.5(7)), but the only names permitted in this
6181 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6182 -- generic subprogram declarations or generic instantiations.
6186 ("pragma% misplaced, must be before first declaration");
6190 end Check_Valid_Library_Unit_Pragma;
6196 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6197 Clist : constant Node_Id := Component_List (Variant);
6201 Comp := First (Component_Items (Clist));
6202 while Present (Comp) loop
6203 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6208 ---------------------------
6209 -- Ensure_Aggregate_Form --
6210 ---------------------------
6212 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6213 CFSD : constant Boolean := Get_Comes_From_Source_Default;
6214 Expr : constant Node_Id := Expression (Arg);
6215 Loc : constant Source_Ptr := Sloc (Expr);
6216 Comps : List_Id := No_List;
6217 Exprs : List_Id := No_List;
6218 Nam : Name_Id := No_Name;
6219 Nam_Loc : Source_Ptr;
6222 -- The pragma argument is in positional form:
6224 -- pragma Depends (Nam => ...)
6228 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6229 -- argument association.
6231 if Nkind (Arg) = N_Pragma_Argument_Association then
6233 Nam_Loc := Sloc (Arg);
6235 -- Remove the pragma argument name as this will be captured in the
6238 Set_Chars (Arg, No_Name);
6241 -- The argument is already in aggregate form, but the presence of a
6242 -- name causes this to be interpreted as named association which in
6243 -- turn must be converted into an aggregate.
6245 -- pragma Global (In_Out => (A, B, C))
6249 -- pragma Global ((In_Out => (A, B, C)))
6251 -- aggregate aggregate
6253 if Nkind (Expr) = N_Aggregate then
6254 if Nam = No_Name then
6258 -- Do not transform a null argument into an aggregate as N_Null has
6259 -- special meaning in formal verification pragmas.
6261 elsif Nkind (Expr) = N_Null then
6265 -- Everything comes from source if the original comes from source
6267 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6269 -- Positional argument is transformed into an aggregate with an
6270 -- Expressions list.
6272 if Nam = No_Name then
6273 Exprs := New_List (Relocate_Node (Expr));
6275 -- An associative argument is transformed into an aggregate with
6276 -- Component_Associations.
6280 Make_Component_Association (Loc,
6281 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
6282 Expression => Relocate_Node (Expr)));
6285 Set_Expression (Arg,
6286 Make_Aggregate (Loc,
6287 Component_Associations => Comps,
6288 Expressions => Exprs));
6290 -- Restore Comes_From_Source default
6292 Set_Comes_From_Source_Default (CFSD);
6293 end Ensure_Aggregate_Form;
6299 procedure Error_Pragma (Msg : String) is
6301 Error_Msg_Name_1 := Pname;
6302 Error_Msg_N (Fix_Error (Msg), N);
6306 ----------------------
6307 -- Error_Pragma_Arg --
6308 ----------------------
6310 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6312 Error_Msg_Name_1 := Pname;
6313 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6315 end Error_Pragma_Arg;
6317 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6319 Error_Msg_Name_1 := Pname;
6320 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6321 Error_Pragma_Arg (Msg2, Arg);
6322 end Error_Pragma_Arg;
6324 ----------------------------
6325 -- Error_Pragma_Arg_Ident --
6326 ----------------------------
6328 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6330 Error_Msg_Name_1 := Pname;
6331 Error_Msg_N (Fix_Error (Msg), Arg);
6333 end Error_Pragma_Arg_Ident;
6335 ----------------------
6336 -- Error_Pragma_Ref --
6337 ----------------------
6339 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6341 Error_Msg_Name_1 := Pname;
6342 Error_Msg_Sloc := Sloc (Ref);
6343 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6345 end Error_Pragma_Ref;
6347 ------------------------
6348 -- Find_Lib_Unit_Name --
6349 ------------------------
6351 function Find_Lib_Unit_Name return Entity_Id is
6353 -- Return inner compilation unit entity, for case of nested
6354 -- categorization pragmas. This happens in generic unit.
6356 if Nkind (Parent (N)) = N_Package_Specification
6357 and then Defining_Entity (Parent (N)) /= Current_Scope
6359 return Defining_Entity (Parent (N));
6361 return Current_Scope;
6363 end Find_Lib_Unit_Name;
6365 ----------------------------
6366 -- Find_Program_Unit_Name --
6367 ----------------------------
6369 procedure Find_Program_Unit_Name (Id : Node_Id) is
6370 Unit_Name : Entity_Id;
6371 Unit_Kind : Node_Kind;
6372 P : constant Node_Id := Parent (N);
6375 if Nkind (P) = N_Compilation_Unit then
6376 Unit_Kind := Nkind (Unit (P));
6378 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6379 N_Package_Declaration)
6380 or else Unit_Kind in N_Generic_Declaration
6382 Unit_Name := Defining_Entity (Unit (P));
6384 if Chars (Id) = Chars (Unit_Name) then
6385 Set_Entity (Id, Unit_Name);
6386 Set_Etype (Id, Etype (Unit_Name));
6388 Set_Etype (Id, Any_Type);
6390 ("cannot find program unit referenced by pragma%");
6394 Set_Etype (Id, Any_Type);
6395 Error_Pragma ("pragma% inapplicable to this unit");
6401 end Find_Program_Unit_Name;
6403 -----------------------------------------
6404 -- Find_Unique_Parameterless_Procedure --
6405 -----------------------------------------
6407 function Find_Unique_Parameterless_Procedure
6409 Arg : Node_Id) return Entity_Id
6411 Proc : Entity_Id := Empty;
6414 -- The body of this procedure needs some comments ???
6416 if not Is_Entity_Name (Name) then
6418 ("argument of pragma% must be entity name", Arg);
6420 elsif not Is_Overloaded (Name) then
6421 Proc := Entity (Name);
6423 if Ekind (Proc) /= E_Procedure
6424 or else Present (First_Formal (Proc))
6427 ("argument of pragma% must be parameterless procedure", Arg);
6432 Found : Boolean := False;
6434 Index : Interp_Index;
6437 Get_First_Interp (Name, Index, It);
6438 while Present (It.Nam) loop
6441 if Ekind (Proc) = E_Procedure
6442 and then No (First_Formal (Proc))
6446 Set_Entity (Name, Proc);
6447 Set_Is_Overloaded (Name, False);
6450 ("ambiguous handler name for pragma% ", Arg);
6454 Get_Next_Interp (Index, It);
6459 ("argument of pragma% must be parameterless procedure",
6462 Proc := Entity (Name);
6468 end Find_Unique_Parameterless_Procedure;
6474 function Fix_Error (Msg : String) return String is
6475 Res : String (Msg'Range) := Msg;
6476 Res_Last : Natural := Msg'Last;
6480 -- If we have a rewriting of another pragma, go to that pragma
6482 if Is_Rewrite_Substitution (N)
6483 and then Nkind (Original_Node (N)) = N_Pragma
6485 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6488 -- Case where pragma comes from an aspect specification
6490 if From_Aspect_Specification (N) then
6492 -- Change appearence of "pragma" in message to "aspect"
6495 while J <= Res_Last - 5 loop
6496 if Res (J .. J + 5) = "pragma" then
6497 Res (J .. J + 5) := "aspect";
6505 -- Change "argument of" at start of message to "entity for"
6508 and then Res (Res'First .. Res'First + 10) = "argument of"
6510 Res (Res'First .. Res'First + 9) := "entity for";
6511 Res (Res'First + 10 .. Res_Last - 1) :=
6512 Res (Res'First + 11 .. Res_Last);
6513 Res_Last := Res_Last - 1;
6516 -- Change "argument" at start of message to "entity"
6519 and then Res (Res'First .. Res'First + 7) = "argument"
6521 Res (Res'First .. Res'First + 5) := "entity";
6522 Res (Res'First + 6 .. Res_Last - 2) :=
6523 Res (Res'First + 8 .. Res_Last);
6524 Res_Last := Res_Last - 2;
6527 -- Get name from corresponding aspect
6529 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6532 -- Return possibly modified message
6534 return Res (Res'First .. Res_Last);
6537 -------------------------
6538 -- Gather_Associations --
6539 -------------------------
6541 procedure Gather_Associations
6543 Args : out Args_List)
6548 -- Initialize all parameters to Empty
6550 for J in Args'Range loop
6554 -- That's all we have to do if there are no argument associations
6556 if No (Pragma_Argument_Associations (N)) then
6560 -- Otherwise first deal with any positional parameters present
6562 Arg := First (Pragma_Argument_Associations (N));
6563 for Index in Args'Range loop
6564 exit when No (Arg) or else Chars (Arg) /= No_Name;
6565 Args (Index) := Get_Pragma_Arg (Arg);
6569 -- Positional parameters all processed, if any left, then we
6570 -- have too many positional parameters.
6572 if Present (Arg) and then Chars (Arg) = No_Name then
6574 ("too many positional associations for pragma%", Arg);
6577 -- Process named parameters if any are present
6579 while Present (Arg) loop
6580 if Chars (Arg) = No_Name then
6582 ("positional association cannot follow named association",
6586 for Index in Names'Range loop
6587 if Names (Index) = Chars (Arg) then
6588 if Present (Args (Index)) then
6590 ("duplicate argument association for pragma%", Arg);
6592 Args (Index) := Get_Pragma_Arg (Arg);
6597 if Index = Names'Last then
6598 Error_Msg_Name_1 := Pname;
6599 Error_Msg_N ("pragma% does not allow & argument", Arg);
6601 -- Check for possible misspelling
6603 for Index1 in Names'Range loop
6604 if Is_Bad_Spelling_Of
6605 (Chars (Arg), Names (Index1))
6607 Error_Msg_Name_1 := Names (Index1);
6608 Error_Msg_N -- CODEFIX
6609 ("\possible misspelling of%", Arg);
6621 end Gather_Associations;
6627 procedure GNAT_Pragma is
6629 -- We need to check the No_Implementation_Pragmas restriction for
6630 -- the case of a pragma from source. Note that the case of aspects
6631 -- generating corresponding pragmas marks these pragmas as not being
6632 -- from source, so this test also catches that case.
6634 if Comes_From_Source (N) then
6635 Check_Restriction (No_Implementation_Pragmas, N);
6639 --------------------------
6640 -- Is_Before_First_Decl --
6641 --------------------------
6643 function Is_Before_First_Decl
6644 (Pragma_Node : Node_Id;
6645 Decls : List_Id) return Boolean
6647 Item : Node_Id := First (Decls);
6650 -- Only other pragmas can come before this pragma
6653 if No (Item) or else Nkind (Item) /= N_Pragma then
6656 elsif Item = Pragma_Node then
6662 end Is_Before_First_Decl;
6664 -----------------------------
6665 -- Is_Configuration_Pragma --
6666 -----------------------------
6668 -- A configuration pragma must appear in the context clause of a
6669 -- compilation unit, and only other pragmas may precede it. Note that
6670 -- the test below also permits use in a configuration pragma file.
6672 function Is_Configuration_Pragma return Boolean is
6673 Lis : constant List_Id := List_Containing (N);
6674 Par : constant Node_Id := Parent (N);
6678 -- If no parent, then we are in the configuration pragma file,
6679 -- so the placement is definitely appropriate.
6684 -- Otherwise we must be in the context clause of a compilation unit
6685 -- and the only thing allowed before us in the context list is more
6686 -- configuration pragmas.
6688 elsif Nkind (Par) = N_Compilation_Unit
6689 and then Context_Items (Par) = Lis
6696 elsif Nkind (Prg) /= N_Pragma then
6706 end Is_Configuration_Pragma;
6708 --------------------------
6709 -- Is_In_Context_Clause --
6710 --------------------------
6712 function Is_In_Context_Clause return Boolean is
6714 Parent_Node : Node_Id;
6717 if not Is_List_Member (N) then
6721 Plist := List_Containing (N);
6722 Parent_Node := Parent (Plist);
6724 if Parent_Node = Empty
6725 or else Nkind (Parent_Node) /= N_Compilation_Unit
6726 or else Context_Items (Parent_Node) /= Plist
6733 end Is_In_Context_Clause;
6735 ---------------------------------
6736 -- Is_Static_String_Expression --
6737 ---------------------------------
6739 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6740 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6741 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6744 Analyze_And_Resolve (Argx);
6746 -- Special case Ada 83, where the expression will never be static,
6747 -- but we will return true if we had a string literal to start with.
6749 if Ada_Version = Ada_83 then
6752 -- Normal case, true only if we end up with a string literal that
6753 -- is marked as being the result of evaluating a static expression.
6756 return Is_OK_Static_Expression (Argx)
6757 and then Nkind (Argx) = N_String_Literal;
6760 end Is_Static_String_Expression;
6762 ----------------------
6763 -- Pragma_Misplaced --
6764 ----------------------
6766 procedure Pragma_Misplaced is
6768 Error_Pragma ("incorrect placement of pragma%");
6769 end Pragma_Misplaced;
6771 ------------------------------------------------
6772 -- Process_Atomic_Independent_Shared_Volatile --
6773 ------------------------------------------------
6775 procedure Process_Atomic_Independent_Shared_Volatile is
6776 procedure Set_Atomic_VFA (E : Entity_Id);
6777 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6778 -- no explicit alignment was given, set alignment to unknown, since
6779 -- back end knows what the alignment requirements are for atomic and
6780 -- full access arrays. Note: this is necessary for derived types.
6782 --------------------
6783 -- Set_Atomic_VFA --
6784 --------------------
6786 procedure Set_Atomic_VFA (E : Entity_Id) is
6788 if Prag_Id = Pragma_Volatile_Full_Access then
6789 Set_Is_Volatile_Full_Access (E);
6794 if not Has_Alignment_Clause (E) then
6795 Set_Alignment (E, Uint_0);
6805 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6808 Check_Ada_83_Warning;
6809 Check_No_Identifiers;
6810 Check_Arg_Count (1);
6811 Check_Arg_Is_Local_Name (Arg1);
6812 E_Arg := Get_Pragma_Arg (Arg1);
6814 if Etype (E_Arg) = Any_Type then
6818 E := Entity (E_Arg);
6819 Decl := Declaration_Node (E);
6821 -- A pragma that applies to a Ghost entity becomes Ghost for the
6822 -- purposes of legality checks and removal of ignored Ghost code.
6824 Mark_Pragma_As_Ghost (N, E);
6826 -- Check duplicate before we chain ourselves
6828 Check_Duplicate_Pragma (E);
6830 -- Check Atomic and VFA used together
6832 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6833 or else (Is_Volatile_Full_Access (E)
6834 and then (Prag_Id = Pragma_Atomic
6836 Prag_Id = Pragma_Shared))
6839 ("cannot have Volatile_Full_Access and Atomic for same entity");
6842 -- Check for applying VFA to an entity which has aliased component
6844 if Prag_Id = Pragma_Volatile_Full_Access then
6847 Aliased_Comp : Boolean := False;
6848 -- Set True if aliased component present
6851 if Is_Array_Type (Etype (E)) then
6852 Aliased_Comp := Has_Aliased_Components (Etype (E));
6854 -- Record case, too bad Has_Aliased_Components is not also
6855 -- set for records, should it be ???
6857 elsif Is_Record_Type (Etype (E)) then
6858 Comp := First_Component_Or_Discriminant (Etype (E));
6859 while Present (Comp) loop
6860 if Is_Aliased (Comp)
6861 or else Is_Aliased (Etype (Comp))
6863 Aliased_Comp := True;
6867 Next_Component_Or_Discriminant (Comp);
6871 if Aliased_Comp then
6873 ("cannot apply Volatile_Full_Access (aliased component "
6879 -- Now check appropriateness of the entity
6882 if Rep_Item_Too_Early (E, N)
6884 Rep_Item_Too_Late (E, N)
6888 Check_First_Subtype (Arg1);
6891 -- Attribute belongs on the base type. If the view of the type is
6892 -- currently private, it also belongs on the underlying type.
6894 if Prag_Id = Pragma_Atomic
6896 Prag_Id = Pragma_Shared
6898 Prag_Id = Pragma_Volatile_Full_Access
6901 Set_Atomic_VFA (Base_Type (E));
6902 Set_Atomic_VFA (Underlying_Type (E));
6905 -- Atomic/Shared/Volatile_Full_Access imply Independent
6907 if Prag_Id /= Pragma_Volatile then
6908 Set_Is_Independent (E);
6909 Set_Is_Independent (Base_Type (E));
6910 Set_Is_Independent (Underlying_Type (E));
6912 if Prag_Id = Pragma_Independent then
6913 Record_Independence_Check (N, Base_Type (E));
6917 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6919 if Prag_Id /= Pragma_Independent then
6920 Set_Is_Volatile (E);
6921 Set_Is_Volatile (Base_Type (E));
6922 Set_Is_Volatile (Underlying_Type (E));
6924 Set_Treat_As_Volatile (E);
6925 Set_Treat_As_Volatile (Underlying_Type (E));
6928 elsif Nkind (Decl) = N_Object_Declaration
6929 or else (Nkind (Decl) = N_Component_Declaration
6930 and then Original_Record_Component (E) = E)
6932 if Rep_Item_Too_Late (E, N) then
6936 if Prag_Id = Pragma_Atomic
6938 Prag_Id = Pragma_Shared
6940 Prag_Id = Pragma_Volatile_Full_Access
6942 if Prag_Id = Pragma_Volatile_Full_Access then
6943 Set_Is_Volatile_Full_Access (E);
6948 -- If the object declaration has an explicit initialization, a
6949 -- temporary may have to be created to hold the expression, to
6950 -- ensure that access to the object remain atomic.
6952 if Nkind (Parent (E)) = N_Object_Declaration
6953 and then Present (Expression (Parent (E)))
6955 Set_Has_Delayed_Freeze (E);
6959 -- Atomic/Shared/Volatile_Full_Access imply Independent
6961 if Prag_Id /= Pragma_Volatile then
6962 Set_Is_Independent (E);
6964 if Prag_Id = Pragma_Independent then
6965 Record_Independence_Check (N, E);
6969 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6971 if Prag_Id /= Pragma_Independent then
6972 Set_Is_Volatile (E);
6973 Set_Treat_As_Volatile (E);
6977 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6980 -- The following check is only relevant when SPARK_Mode is on as
6981 -- this is not a standard Ada legality rule. Pragma Volatile can
6982 -- only apply to a full type declaration or an object declaration
6983 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6984 -- untagged derived types that are rewritten as subtypes of their
6985 -- respective root types.
6988 and then Prag_Id = Pragma_Volatile
6990 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
6991 N_Object_Declaration)
6994 ("argument of pragma % must denote a full type or object "
6995 & "declaration", Arg1);
6997 end Process_Atomic_Independent_Shared_Volatile;
6999 -------------------------------------------
7000 -- Process_Compile_Time_Warning_Or_Error --
7001 -------------------------------------------
7003 procedure Process_Compile_Time_Warning_Or_Error is
7004 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7007 Check_Arg_Count (2);
7008 Check_No_Identifiers;
7009 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7010 Analyze_And_Resolve (Arg1x, Standard_Boolean);
7012 if Compile_Time_Known_Value (Arg1x) then
7013 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
7015 Str : constant String_Id :=
7016 Strval (Get_Pragma_Arg (Arg2));
7017 Len : constant Nat := String_Length (Str);
7022 Cent : constant Entity_Id :=
7023 Cunit_Entity (Current_Sem_Unit);
7025 Force : constant Boolean :=
7026 Prag_Id = Pragma_Compile_Time_Warning
7028 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
7029 and then (Ekind (Cent) /= E_Package
7030 or else not In_Private_Part (Cent));
7031 -- Set True if this is the warning case, and we are in the
7032 -- visible part of a package spec, or in a subprogram spec,
7033 -- in which case we want to force the client to see the
7034 -- warning, even though it is not in the main unit.
7037 -- Loop through segments of message separated by line feeds.
7038 -- We output these segments as separate messages with
7039 -- continuation marks for all but the first.
7044 Error_Msg_Strlen := 0;
7046 -- Loop to copy characters from argument to error message
7050 exit when Ptr > Len;
7051 CC := Get_String_Char (Str, Ptr);
7054 -- Ignore wide chars ??? else store character
7056 if In_Character_Range (CC) then
7057 C := Get_Character (CC);
7058 exit when C = ASCII.LF;
7059 Error_Msg_Strlen := Error_Msg_Strlen + 1;
7060 Error_Msg_String (Error_Msg_Strlen) := C;
7064 -- Here with one line ready to go
7066 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
7068 -- If this is a warning in a spec, then we want clients
7069 -- to see the warning, so mark the message with the
7070 -- special sequence !! to force the warning. In the case
7071 -- of a package spec, we do not force this if we are in
7072 -- the private part of the spec.
7075 if Cont = False then
7076 Error_Msg_N ("<<~!!", Arg1);
7079 Error_Msg_N ("\<<~!!", Arg1);
7082 -- Error, rather than warning, or in a body, so we do not
7083 -- need to force visibility for client (error will be
7084 -- output in any case, and this is the situation in which
7085 -- we do not want a client to get a warning, since the
7086 -- warning is in the body or the spec private part).
7089 if Cont = False then
7090 Error_Msg_N ("<<~", Arg1);
7093 Error_Msg_N ("\<<~", Arg1);
7097 exit when Ptr > Len;
7102 end Process_Compile_Time_Warning_Or_Error;
7104 ------------------------
7105 -- Process_Convention --
7106 ------------------------
7108 procedure Process_Convention
7109 (C : out Convention_Id;
7110 Ent : out Entity_Id)
7114 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7115 -- Called if we have more than one Export/Import/Convention pragma.
7116 -- This is generally illegal, but we have a special case of allowing
7117 -- Import and Interface to coexist if they specify the convention in
7118 -- a consistent manner. We are allowed to do this, since Interface is
7119 -- an implementation defined pragma, and we choose to do it since we
7120 -- know Rational allows this combination. S is the entity id of the
7121 -- subprogram in question. This procedure also sets the special flag
7122 -- Import_Interface_Present in both pragmas in the case where we do
7123 -- have matching Import and Interface pragmas.
7125 procedure Set_Convention_From_Pragma (E : Entity_Id);
7126 -- Set convention in entity E, and also flag that the entity has a
7127 -- convention pragma. If entity is for a private or incomplete type,
7128 -- also set convention and flag on underlying type. This procedure
7129 -- also deals with the special case of C_Pass_By_Copy convention,
7130 -- and error checks for inappropriate convention specification.
7132 -------------------------------
7133 -- Diagnose_Multiple_Pragmas --
7134 -------------------------------
7136 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7137 Pdec : constant Node_Id := Declaration_Node (S);
7141 function Same_Convention (Decl : Node_Id) return Boolean;
7142 -- Decl is a pragma node. This function returns True if this
7143 -- pragma has a first argument that is an identifier with a
7144 -- Chars field corresponding to the Convention_Id C.
7146 function Same_Name (Decl : Node_Id) return Boolean;
7147 -- Decl is a pragma node. This function returns True if this
7148 -- pragma has a second argument that is an identifier with a
7149 -- Chars field that matches the Chars of the current subprogram.
7151 ---------------------
7152 -- Same_Convention --
7153 ---------------------
7155 function Same_Convention (Decl : Node_Id) return Boolean is
7156 Arg1 : constant Node_Id :=
7157 First (Pragma_Argument_Associations (Decl));
7160 if Present (Arg1) then
7162 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7164 if Nkind (Arg) = N_Identifier
7165 and then Is_Convention_Name (Chars (Arg))
7166 and then Get_Convention_Id (Chars (Arg)) = C
7174 end Same_Convention;
7180 function Same_Name (Decl : Node_Id) return Boolean is
7181 Arg1 : constant Node_Id :=
7182 First (Pragma_Argument_Associations (Decl));
7190 Arg2 := Next (Arg1);
7197 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7199 if Nkind (Arg) = N_Identifier
7200 and then Chars (Arg) = Chars (S)
7209 -- Start of processing for Diagnose_Multiple_Pragmas
7214 -- Definitely give message if we have Convention/Export here
7216 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7219 -- If we have an Import or Export, scan back from pragma to
7220 -- find any previous pragma applying to the same procedure.
7221 -- The scan will be terminated by the start of the list, or
7222 -- hitting the subprogram declaration. This won't allow one
7223 -- pragma to appear in the public part and one in the private
7224 -- part, but that seems very unlikely in practice.
7228 while Present (Decl) and then Decl /= Pdec loop
7230 -- Look for pragma with same name as us
7232 if Nkind (Decl) = N_Pragma
7233 and then Same_Name (Decl)
7235 -- Give error if same as our pragma or Export/Convention
7237 if Nam_In (Pragma_Name (Decl), Name_Export,
7243 -- Case of Import/Interface or the other way round
7245 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
7248 -- Here we know that we have Import and Interface. It
7249 -- doesn't matter which way round they are. See if
7250 -- they specify the same convention. If so, all OK,
7251 -- and set special flags to stop other messages
7253 if Same_Convention (Decl) then
7254 Set_Import_Interface_Present (N);
7255 Set_Import_Interface_Present (Decl);
7258 -- If different conventions, special message
7261 Error_Msg_Sloc := Sloc (Decl);
7263 ("convention differs from that given#", Arg1);
7273 -- Give message if needed if we fall through those tests
7274 -- except on Relaxed_RM_Semantics where we let go: either this
7275 -- is a case accepted/ignored by other Ada compilers (e.g.
7276 -- a mix of Convention and Import), or another error will be
7277 -- generated later (e.g. using both Import and Export).
7279 if Err and not Relaxed_RM_Semantics then
7281 ("at most one Convention/Export/Import pragma is allowed",
7284 end Diagnose_Multiple_Pragmas;
7286 --------------------------------
7287 -- Set_Convention_From_Pragma --
7288 --------------------------------
7290 procedure Set_Convention_From_Pragma (E : Entity_Id) is
7292 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7293 -- for an overridden dispatching operation. Technically this is
7294 -- an amendment and should only be done in Ada 2005 mode. However,
7295 -- this is clearly a mistake, since the problem that is addressed
7296 -- by this AI is that there is a clear gap in the RM.
7298 if Is_Dispatching_Operation (E)
7299 and then Present (Overridden_Operation (E))
7300 and then C /= Convention (Overridden_Operation (E))
7303 ("cannot change convention for overridden dispatching "
7304 & "operation", Arg1);
7307 -- Special checks for Convention_Stdcall
7309 if C = Convention_Stdcall then
7311 -- A dispatching call is not allowed. A dispatching subprogram
7312 -- cannot be used to interface to the Win32 API, so in fact
7313 -- this check does not impose any effective restriction.
7315 if Is_Dispatching_Operation (E) then
7316 Error_Msg_Sloc := Sloc (E);
7318 -- Note: make this unconditional so that if there is more
7319 -- than one call to which the pragma applies, we get a
7320 -- message for each call. Also don't use Error_Pragma,
7321 -- so that we get multiple messages.
7324 ("dispatching subprogram# cannot use Stdcall convention!",
7327 -- Subprograms are not allowed
7329 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
7333 and then Ekind (E) /= E_Variable
7335 -- An access to subprogram is also allowed
7339 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7341 -- Allow internal call to set convention of subprogram type
7343 and then not (Ekind (E) = E_Subprogram_Type)
7346 ("second argument of pragma% must be subprogram (type)",
7351 -- Set the convention
7353 Set_Convention (E, C);
7354 Set_Has_Convention_Pragma (E);
7356 -- For the case of a record base type, also set the convention of
7357 -- any anonymous access types declared in the record which do not
7358 -- currently have a specified convention.
7360 if Is_Record_Type (E) and then Is_Base_Type (E) then
7365 Comp := First_Component (E);
7366 while Present (Comp) loop
7367 if Present (Etype (Comp))
7368 and then Ekind_In (Etype (Comp),
7369 E_Anonymous_Access_Type,
7370 E_Anonymous_Access_Subprogram_Type)
7371 and then not Has_Convention_Pragma (Comp)
7373 Set_Convention (Comp, C);
7376 Next_Component (Comp);
7381 -- Deal with incomplete/private type case, where underlying type
7382 -- is available, so set convention of that underlying type.
7384 if Is_Incomplete_Or_Private_Type (E)
7385 and then Present (Underlying_Type (E))
7387 Set_Convention (Underlying_Type (E), C);
7388 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7391 -- A class-wide type should inherit the convention of the specific
7392 -- root type (although this isn't specified clearly by the RM).
7394 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7395 Set_Convention (Class_Wide_Type (E), C);
7398 -- If the entity is a record type, then check for special case of
7399 -- C_Pass_By_Copy, which is treated the same as C except that the
7400 -- special record flag is set. This convention is only permitted
7401 -- on record types (see AI95-00131).
7403 if Cname = Name_C_Pass_By_Copy then
7404 if Is_Record_Type (E) then
7405 Set_C_Pass_By_Copy (Base_Type (E));
7406 elsif Is_Incomplete_Or_Private_Type (E)
7407 and then Is_Record_Type (Underlying_Type (E))
7409 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7412 ("C_Pass_By_Copy convention allowed only for record type",
7417 -- If the entity is a derived boolean type, check for the special
7418 -- case of convention C, C++, or Fortran, where we consider any
7419 -- nonzero value to represent true.
7421 if Is_Discrete_Type (E)
7422 and then Root_Type (Etype (E)) = Standard_Boolean
7428 C = Convention_Fortran)
7430 Set_Nonzero_Is_True (Base_Type (E));
7432 end Set_Convention_From_Pragma;
7436 Comp_Unit : Unit_Number_Type;
7441 -- Start of processing for Process_Convention
7444 Check_At_Least_N_Arguments (2);
7445 Check_Optional_Identifier (Arg1, Name_Convention);
7446 Check_Arg_Is_Identifier (Arg1);
7447 Cname := Chars (Get_Pragma_Arg (Arg1));
7449 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7450 -- tested again below to set the critical flag).
7452 if Cname = Name_C_Pass_By_Copy then
7455 -- Otherwise we must have something in the standard convention list
7457 elsif Is_Convention_Name (Cname) then
7458 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7460 -- Otherwise warn on unrecognized convention
7463 if Warn_On_Export_Import then
7465 ("??unrecognized convention name, C assumed",
7466 Get_Pragma_Arg (Arg1));
7472 Check_Optional_Identifier (Arg2, Name_Entity);
7473 Check_Arg_Is_Local_Name (Arg2);
7475 Id := Get_Pragma_Arg (Arg2);
7478 if not Is_Entity_Name (Id) then
7479 Error_Pragma_Arg ("entity name required", Arg2);
7484 -- Set entity to return
7488 -- Ada_Pass_By_Copy special checking
7490 if C = Convention_Ada_Pass_By_Copy then
7491 if not Is_First_Subtype (E) then
7493 ("convention `Ada_Pass_By_Copy` only allowed for types",
7497 if Is_By_Reference_Type (E) then
7499 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7503 -- Ada_Pass_By_Reference special checking
7505 elsif C = Convention_Ada_Pass_By_Reference then
7506 if not Is_First_Subtype (E) then
7508 ("convention `Ada_Pass_By_Reference` only allowed for types",
7512 if Is_By_Copy_Type (E) then
7514 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7519 -- Go to renamed subprogram if present, since convention applies to
7520 -- the actual renamed entity, not to the renaming entity. If the
7521 -- subprogram is inherited, go to parent subprogram.
7523 if Is_Subprogram (E)
7524 and then Present (Alias (E))
7526 if Nkind (Parent (Declaration_Node (E))) =
7527 N_Subprogram_Renaming_Declaration
7529 if Scope (E) /= Scope (Alias (E)) then
7531 ("cannot apply pragma% to non-local entity&#", E);
7536 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7537 N_Private_Extension_Declaration)
7538 and then Scope (E) = Scope (Alias (E))
7542 -- Return the parent subprogram the entity was inherited from
7548 -- Check that we are not applying this to a specless body. Relax this
7549 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7551 if Is_Subprogram (E)
7552 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7553 and then not Relaxed_RM_Semantics
7556 ("pragma% requires separate spec and must come before body");
7559 -- Check that we are not applying this to a named constant
7561 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7562 Error_Msg_Name_1 := Pname;
7564 ("cannot apply pragma% to named constant!",
7565 Get_Pragma_Arg (Arg2));
7567 ("\supply appropriate type for&!", Arg2);
7570 if Ekind (E) = E_Enumeration_Literal then
7571 Error_Pragma ("enumeration literal not allowed for pragma%");
7574 -- Check for rep item appearing too early or too late
7576 if Etype (E) = Any_Type
7577 or else Rep_Item_Too_Early (E, N)
7581 elsif Present (Underlying_Type (E)) then
7582 E := Underlying_Type (E);
7585 if Rep_Item_Too_Late (E, N) then
7589 if Has_Convention_Pragma (E) then
7590 Diagnose_Multiple_Pragmas (E);
7592 elsif Convention (E) = Convention_Protected
7593 or else Ekind (Scope (E)) = E_Protected_Type
7596 ("a protected operation cannot be given a different convention",
7600 -- For Intrinsic, a subprogram is required
7602 if C = Convention_Intrinsic
7603 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7605 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7607 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7609 ("second argument of pragma% must be a subprogram", Arg2);
7613 -- Deal with non-subprogram cases
7615 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7616 Set_Convention_From_Pragma (E);
7620 -- The pragma must apply to a first subtype, but it can also
7621 -- apply to a generic type in a generic formal part, in which
7622 -- case it will also appear in the corresponding instance.
7624 if Is_Generic_Type (E) or else In_Instance then
7627 Check_First_Subtype (Arg2);
7630 Set_Convention_From_Pragma (Base_Type (E));
7632 -- For access subprograms, we must set the convention on the
7633 -- internally generated directly designated type as well.
7635 if Ekind (E) = E_Access_Subprogram_Type then
7636 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7640 -- For the subprogram case, set proper convention for all homonyms
7641 -- in same scope and the same declarative part, i.e. the same
7642 -- compilation unit.
7645 Comp_Unit := Get_Source_Unit (E);
7646 Set_Convention_From_Pragma (E);
7648 -- Treat a pragma Import as an implicit body, and pragma import
7649 -- as implicit reference (for navigation in GPS).
7651 if Prag_Id = Pragma_Import then
7652 Generate_Reference (E, Id, 'b');
7654 -- For exported entities we restrict the generation of references
7655 -- to entities exported to foreign languages since entities
7656 -- exported to Ada do not provide further information to GPS and
7657 -- add undesired references to the output of the gnatxref tool.
7659 elsif Prag_Id = Pragma_Export
7660 and then Convention (E) /= Convention_Ada
7662 Generate_Reference (E, Id, 'i');
7665 -- If the pragma comes from an aspect, it only applies to the
7666 -- given entity, not its homonyms.
7668 if From_Aspect_Specification (N) then
7672 -- Otherwise Loop through the homonyms of the pragma argument's
7673 -- entity, an apply convention to those in the current scope.
7679 exit when No (E1) or else Scope (E1) /= Current_Scope;
7681 -- Ignore entry for which convention is already set
7683 if Has_Convention_Pragma (E1) then
7687 -- Do not set the pragma on inherited operations or on formal
7690 if Comes_From_Source (E1)
7691 and then Comp_Unit = Get_Source_Unit (E1)
7692 and then not Is_Formal_Subprogram (E1)
7693 and then Nkind (Original_Node (Parent (E1))) /=
7694 N_Full_Type_Declaration
7696 if Present (Alias (E1))
7697 and then Scope (E1) /= Scope (Alias (E1))
7700 ("cannot apply pragma% to non-local entity& declared#",
7704 Set_Convention_From_Pragma (E1);
7706 if Prag_Id = Pragma_Import then
7707 Generate_Reference (E1, Id, 'b');
7715 end Process_Convention;
7717 ----------------------------------------
7718 -- Process_Disable_Enable_Atomic_Sync --
7719 ----------------------------------------
7721 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7723 Check_No_Identifiers;
7724 Check_At_Most_N_Arguments (1);
7726 -- Modeled internally as
7727 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7731 Pragma_Identifier =>
7732 Make_Identifier (Loc, Nam),
7733 Pragma_Argument_Associations => New_List (
7734 Make_Pragma_Argument_Association (Loc,
7736 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7738 if Present (Arg1) then
7739 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7743 end Process_Disable_Enable_Atomic_Sync;
7745 -------------------------------------------------
7746 -- Process_Extended_Import_Export_Internal_Arg --
7747 -------------------------------------------------
7749 procedure Process_Extended_Import_Export_Internal_Arg
7750 (Arg_Internal : Node_Id := Empty)
7753 if No (Arg_Internal) then
7754 Error_Pragma ("Internal parameter required for pragma%");
7757 if Nkind (Arg_Internal) = N_Identifier then
7760 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7761 and then (Prag_Id = Pragma_Import_Function
7763 Prag_Id = Pragma_Export_Function)
7769 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7772 Check_Arg_Is_Local_Name (Arg_Internal);
7773 end Process_Extended_Import_Export_Internal_Arg;
7775 --------------------------------------------------
7776 -- Process_Extended_Import_Export_Object_Pragma --
7777 --------------------------------------------------
7779 procedure Process_Extended_Import_Export_Object_Pragma
7780 (Arg_Internal : Node_Id;
7781 Arg_External : Node_Id;
7787 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7788 Def_Id := Entity (Arg_Internal);
7790 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7792 ("pragma% must designate an object", Arg_Internal);
7795 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7797 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7800 ("previous Common/Psect_Object applies, pragma % not permitted",
7804 if Rep_Item_Too_Late (Def_Id, N) then
7808 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7810 if Present (Arg_Size) then
7811 Check_Arg_Is_External_Name (Arg_Size);
7814 -- Export_Object case
7816 if Prag_Id = Pragma_Export_Object then
7817 if not Is_Library_Level_Entity (Def_Id) then
7819 ("argument for pragma% must be library level entity",
7823 if Ekind (Current_Scope) = E_Generic_Package then
7824 Error_Pragma ("pragma& cannot appear in a generic unit");
7827 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7829 ("exported object must have compile time known size",
7833 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7834 Error_Msg_N ("??duplicate Export_Object pragma", N);
7836 Set_Exported (Def_Id, Arg_Internal);
7839 -- Import_Object case
7842 if Is_Concurrent_Type (Etype (Def_Id)) then
7844 ("cannot use pragma% for task/protected object",
7848 if Ekind (Def_Id) = E_Constant then
7850 ("cannot import a constant", Arg_Internal);
7853 if Warn_On_Export_Import
7854 and then Has_Discriminants (Etype (Def_Id))
7857 ("imported value must be initialized??", Arg_Internal);
7860 if Warn_On_Export_Import
7861 and then Is_Access_Type (Etype (Def_Id))
7864 ("cannot import object of an access type??", Arg_Internal);
7867 if Warn_On_Export_Import
7868 and then Is_Imported (Def_Id)
7870 Error_Msg_N ("??duplicate Import_Object pragma", N);
7872 -- Check for explicit initialization present. Note that an
7873 -- initialization generated by the code generator, e.g. for an
7874 -- access type, does not count here.
7876 elsif Present (Expression (Parent (Def_Id)))
7879 (Original_Node (Expression (Parent (Def_Id))))
7881 Error_Msg_Sloc := Sloc (Def_Id);
7883 ("imported entities cannot be initialized (RM B.1(24))",
7884 "\no initialization allowed for & declared#", Arg1);
7886 Set_Imported (Def_Id);
7887 Note_Possible_Modification (Arg_Internal, Sure => False);
7890 end Process_Extended_Import_Export_Object_Pragma;
7892 ------------------------------------------------------
7893 -- Process_Extended_Import_Export_Subprogram_Pragma --
7894 ------------------------------------------------------
7896 procedure Process_Extended_Import_Export_Subprogram_Pragma
7897 (Arg_Internal : Node_Id;
7898 Arg_External : Node_Id;
7899 Arg_Parameter_Types : Node_Id;
7900 Arg_Result_Type : Node_Id := Empty;
7901 Arg_Mechanism : Node_Id;
7902 Arg_Result_Mechanism : Node_Id := Empty)
7908 Ambiguous : Boolean;
7911 function Same_Base_Type
7913 Formal : Entity_Id) return Boolean;
7914 -- Determines if Ptype references the type of Formal. Note that only
7915 -- the base types need to match according to the spec. Ptype here is
7916 -- the argument from the pragma, which is either a type name, or an
7917 -- access attribute.
7919 --------------------
7920 -- Same_Base_Type --
7921 --------------------
7923 function Same_Base_Type
7925 Formal : Entity_Id) return Boolean
7927 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7931 -- Case where pragma argument is typ'Access
7933 if Nkind (Ptype) = N_Attribute_Reference
7934 and then Attribute_Name (Ptype) = Name_Access
7936 Pref := Prefix (Ptype);
7939 if not Is_Entity_Name (Pref)
7940 or else Entity (Pref) = Any_Type
7945 -- We have a match if the corresponding argument is of an
7946 -- anonymous access type, and its designated type matches the
7947 -- type of the prefix of the access attribute
7949 return Ekind (Ftyp) = E_Anonymous_Access_Type
7950 and then Base_Type (Entity (Pref)) =
7951 Base_Type (Etype (Designated_Type (Ftyp)));
7953 -- Case where pragma argument is a type name
7958 if not Is_Entity_Name (Ptype)
7959 or else Entity (Ptype) = Any_Type
7964 -- We have a match if the corresponding argument is of the type
7965 -- given in the pragma (comparing base types)
7967 return Base_Type (Entity (Ptype)) = Ftyp;
7971 -- Start of processing for
7972 -- Process_Extended_Import_Export_Subprogram_Pragma
7975 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7979 -- Loop through homonyms (overloadings) of the entity
7981 Hom_Id := Entity (Arg_Internal);
7982 while Present (Hom_Id) loop
7983 Def_Id := Get_Base_Subprogram (Hom_Id);
7985 -- We need a subprogram in the current scope
7987 if not Is_Subprogram (Def_Id)
7988 or else Scope (Def_Id) /= Current_Scope
7995 -- Pragma cannot apply to subprogram body
7997 if Is_Subprogram (Def_Id)
7998 and then Nkind (Parent (Declaration_Node (Def_Id))) =
8002 ("pragma% requires separate spec"
8003 & " and must come before body");
8006 -- Test result type if given, note that the result type
8007 -- parameter can only be present for the function cases.
8009 if Present (Arg_Result_Type)
8010 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8014 elsif Etype (Def_Id) /= Standard_Void_Type
8016 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
8020 -- Test parameter types if given. Note that this parameter
8021 -- has not been analyzed (and must not be, since it is
8022 -- semantic nonsense), so we get it as the parser left it.
8024 elsif Present (Arg_Parameter_Types) then
8025 Check_Matching_Types : declare
8030 Formal := First_Formal (Def_Id);
8032 if Nkind (Arg_Parameter_Types) = N_Null then
8033 if Present (Formal) then
8037 -- A list of one type, e.g. (List) is parsed as
8038 -- a parenthesized expression.
8040 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8041 and then Paren_Count (Arg_Parameter_Types) = 1
8044 or else Present (Next_Formal (Formal))
8049 Same_Base_Type (Arg_Parameter_Types, Formal);
8052 -- A list of more than one type is parsed as a aggregate
8054 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8055 and then Paren_Count (Arg_Parameter_Types) = 0
8057 Ptype := First (Expressions (Arg_Parameter_Types));
8058 while Present (Ptype) or else Present (Formal) loop
8061 or else not Same_Base_Type (Ptype, Formal)
8066 Next_Formal (Formal);
8071 -- Anything else is of the wrong form
8075 ("wrong form for Parameter_Types parameter",
8076 Arg_Parameter_Types);
8078 end Check_Matching_Types;
8081 -- Match is now False if the entry we found did not match
8082 -- either a supplied Parameter_Types or Result_Types argument
8088 -- Ambiguous case, the flag Ambiguous shows if we already
8089 -- detected this and output the initial messages.
8092 if not Ambiguous then
8094 Error_Msg_Name_1 := Pname;
8096 ("pragma% does not uniquely identify subprogram!",
8098 Error_Msg_Sloc := Sloc (Ent);
8099 Error_Msg_N ("matching subprogram #!", N);
8103 Error_Msg_Sloc := Sloc (Def_Id);
8104 Error_Msg_N ("matching subprogram #!", N);
8109 Hom_Id := Homonym (Hom_Id);
8112 -- See if we found an entry
8115 if not Ambiguous then
8116 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8118 ("pragma% cannot be given for generic subprogram");
8121 ("pragma% does not identify local subprogram");
8128 -- Import pragmas must be for imported entities
8130 if Prag_Id = Pragma_Import_Function
8132 Prag_Id = Pragma_Import_Procedure
8134 Prag_Id = Pragma_Import_Valued_Procedure
8136 if not Is_Imported (Ent) then
8138 ("pragma Import or Interface must precede pragma%");
8141 -- Here we have the Export case which can set the entity as exported
8143 -- But does not do so if the specified external name is null, since
8144 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8145 -- compatible) to request no external name.
8147 elsif Nkind (Arg_External) = N_String_Literal
8148 and then String_Length (Strval (Arg_External)) = 0
8152 -- In all other cases, set entity as exported
8155 Set_Exported (Ent, Arg_Internal);
8158 -- Special processing for Valued_Procedure cases
8160 if Prag_Id = Pragma_Import_Valued_Procedure
8162 Prag_Id = Pragma_Export_Valued_Procedure
8164 Formal := First_Formal (Ent);
8167 Error_Pragma ("at least one parameter required for pragma%");
8169 elsif Ekind (Formal) /= E_Out_Parameter then
8170 Error_Pragma ("first parameter must have mode out for pragma%");
8173 Set_Is_Valued_Procedure (Ent);
8177 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8179 -- Process Result_Mechanism argument if present. We have already
8180 -- checked that this is only allowed for the function case.
8182 if Present (Arg_Result_Mechanism) then
8183 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8186 -- Process Mechanism parameter if present. Note that this parameter
8187 -- is not analyzed, and must not be analyzed since it is semantic
8188 -- nonsense, so we get it in exactly as the parser left it.
8190 if Present (Arg_Mechanism) then
8198 -- A single mechanism association without a formal parameter
8199 -- name is parsed as a parenthesized expression. All other
8200 -- cases are parsed as aggregates, so we rewrite the single
8201 -- parameter case as an aggregate for consistency.
8203 if Nkind (Arg_Mechanism) /= N_Aggregate
8204 and then Paren_Count (Arg_Mechanism) = 1
8206 Rewrite (Arg_Mechanism,
8207 Make_Aggregate (Sloc (Arg_Mechanism),
8208 Expressions => New_List (
8209 Relocate_Node (Arg_Mechanism))));
8212 -- Case of only mechanism name given, applies to all formals
8214 if Nkind (Arg_Mechanism) /= N_Aggregate then
8215 Formal := First_Formal (Ent);
8216 while Present (Formal) loop
8217 Set_Mechanism_Value (Formal, Arg_Mechanism);
8218 Next_Formal (Formal);
8221 -- Case of list of mechanism associations given
8224 if Null_Record_Present (Arg_Mechanism) then
8226 ("inappropriate form for Mechanism parameter",
8230 -- Deal with positional ones first
8232 Formal := First_Formal (Ent);
8234 if Present (Expressions (Arg_Mechanism)) then
8235 Mname := First (Expressions (Arg_Mechanism));
8236 while Present (Mname) loop
8239 ("too many mechanism associations", Mname);
8242 Set_Mechanism_Value (Formal, Mname);
8243 Next_Formal (Formal);
8248 -- Deal with named entries
8250 if Present (Component_Associations (Arg_Mechanism)) then
8251 Massoc := First (Component_Associations (Arg_Mechanism));
8252 while Present (Massoc) loop
8253 Choice := First (Choices (Massoc));
8255 if Nkind (Choice) /= N_Identifier
8256 or else Present (Next (Choice))
8259 ("incorrect form for mechanism association",
8263 Formal := First_Formal (Ent);
8267 ("parameter name & not present", Choice);
8270 if Chars (Choice) = Chars (Formal) then
8272 (Formal, Expression (Massoc));
8274 -- Set entity on identifier (needed by ASIS)
8276 Set_Entity (Choice, Formal);
8281 Next_Formal (Formal);
8290 end Process_Extended_Import_Export_Subprogram_Pragma;
8292 --------------------------
8293 -- Process_Generic_List --
8294 --------------------------
8296 procedure Process_Generic_List is
8301 Check_No_Identifiers;
8302 Check_At_Least_N_Arguments (1);
8304 -- Check all arguments are names of generic units or instances
8307 while Present (Arg) loop
8308 Exp := Get_Pragma_Arg (Arg);
8311 if not Is_Entity_Name (Exp)
8313 (not Is_Generic_Instance (Entity (Exp))
8315 not Is_Generic_Unit (Entity (Exp)))
8318 ("pragma% argument must be name of generic unit/instance",
8324 end Process_Generic_List;
8326 ------------------------------------
8327 -- Process_Import_Predefined_Type --
8328 ------------------------------------
8330 procedure Process_Import_Predefined_Type is
8331 Loc : constant Source_Ptr := Sloc (N);
8333 Ftyp : Node_Id := Empty;
8339 String_To_Name_Buffer (Strval (Expression (Arg3)));
8342 Elmt := First_Elmt (Predefined_Float_Types);
8343 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8347 Ftyp := Node (Elmt);
8349 if Present (Ftyp) then
8351 -- Don't build a derived type declaration, because predefined C
8352 -- types have no declaration anywhere, so cannot really be named.
8353 -- Instead build a full type declaration, starting with an
8354 -- appropriate type definition is built
8356 if Is_Floating_Point_Type (Ftyp) then
8357 Def := Make_Floating_Point_Definition (Loc,
8358 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8359 Make_Real_Range_Specification (Loc,
8360 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8361 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8363 -- Should never have a predefined type we cannot handle
8366 raise Program_Error;
8369 -- Build and insert a Full_Type_Declaration, which will be
8370 -- analyzed as soon as this list entry has been analyzed.
8372 Decl := Make_Full_Type_Declaration (Loc,
8373 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8374 Type_Definition => Def);
8376 Insert_After (N, Decl);
8377 Mark_Rewrite_Insertion (Decl);
8380 Error_Pragma_Arg ("no matching type found for pragma%",
8383 end Process_Import_Predefined_Type;
8385 ---------------------------------
8386 -- Process_Import_Or_Interface --
8387 ---------------------------------
8389 procedure Process_Import_Or_Interface is
8395 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8396 -- pragma Import (Entity, "external name");
8398 if Relaxed_RM_Semantics
8399 and then Arg_Count = 2
8400 and then Prag_Id = Pragma_Import
8401 and then Nkind (Expression (Arg2)) = N_String_Literal
8404 Def_Id := Get_Pragma_Arg (Arg1);
8407 if not Is_Entity_Name (Def_Id) then
8408 Error_Pragma_Arg ("entity name required", Arg1);
8411 Def_Id := Entity (Def_Id);
8412 Kill_Size_Check_Code (Def_Id);
8413 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8416 Process_Convention (C, Def_Id);
8418 -- A pragma that applies to a Ghost entity becomes Ghost for the
8419 -- purposes of legality checks and removal of ignored Ghost code.
8421 Mark_Pragma_As_Ghost (N, Def_Id);
8422 Kill_Size_Check_Code (Def_Id);
8423 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8426 -- Various error checks
8428 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8430 -- We do not permit Import to apply to a renaming declaration
8432 if Present (Renamed_Object (Def_Id)) then
8434 ("pragma% not allowed for object renaming", Arg2);
8436 -- User initialization is not allowed for imported object, but
8437 -- the object declaration may contain a default initialization,
8438 -- that will be discarded. Note that an explicit initialization
8439 -- only counts if it comes from source, otherwise it is simply
8440 -- the code generator making an implicit initialization explicit.
8442 elsif Present (Expression (Parent (Def_Id)))
8443 and then Comes_From_Source
8444 (Original_Node (Expression (Parent (Def_Id))))
8446 -- Set imported flag to prevent cascaded errors
8448 Set_Is_Imported (Def_Id);
8450 Error_Msg_Sloc := Sloc (Def_Id);
8452 ("no initialization allowed for declaration of& #",
8453 "\imported entities cannot be initialized (RM B.1(24))",
8457 -- If the pragma comes from an aspect specification the
8458 -- Is_Imported flag has already been set.
8460 if not From_Aspect_Specification (N) then
8461 Set_Imported (Def_Id);
8464 Process_Interface_Name (Def_Id, Arg3, Arg4);
8466 -- Note that we do not set Is_Public here. That's because we
8467 -- only want to set it if there is no address clause, and we
8468 -- don't know that yet, so we delay that processing till
8471 -- pragma Import completes deferred constants
8473 if Ekind (Def_Id) = E_Constant then
8474 Set_Has_Completion (Def_Id);
8477 -- It is not possible to import a constant of an unconstrained
8478 -- array type (e.g. string) because there is no simple way to
8479 -- write a meaningful subtype for it.
8481 if Is_Array_Type (Etype (Def_Id))
8482 and then not Is_Constrained (Etype (Def_Id))
8485 ("imported constant& must have a constrained subtype",
8490 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8492 -- If the name is overloaded, pragma applies to all of the denoted
8493 -- entities in the same declarative part, unless the pragma comes
8494 -- from an aspect specification or was generated by the compiler
8495 -- (such as for pragma Provide_Shift_Operators).
8498 while Present (Hom_Id) loop
8500 Def_Id := Get_Base_Subprogram (Hom_Id);
8502 -- Ignore inherited subprograms because the pragma will apply
8503 -- to the parent operation, which is the one called.
8505 if Is_Overloadable (Def_Id)
8506 and then Present (Alias (Def_Id))
8510 -- If it is not a subprogram, it must be in an outer scope and
8511 -- pragma does not apply.
8513 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8516 -- The pragma does not apply to primitives of interfaces
8518 elsif Is_Dispatching_Operation (Def_Id)
8519 and then Present (Find_Dispatching_Type (Def_Id))
8520 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8524 -- Verify that the homonym is in the same declarative part (not
8525 -- just the same scope). If the pragma comes from an aspect
8526 -- specification we know that it is part of the declaration.
8528 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8529 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8530 and then not From_Aspect_Specification (N)
8535 -- If the pragma comes from an aspect specification the
8536 -- Is_Imported flag has already been set.
8538 if not From_Aspect_Specification (N) then
8539 Set_Imported (Def_Id);
8542 -- Reject an Import applied to an abstract subprogram
8544 if Is_Subprogram (Def_Id)
8545 and then Is_Abstract_Subprogram (Def_Id)
8547 Error_Msg_Sloc := Sloc (Def_Id);
8549 ("cannot import abstract subprogram& declared#",
8553 -- Special processing for Convention_Intrinsic
8555 if C = Convention_Intrinsic then
8557 -- Link_Name argument not allowed for intrinsic
8561 Set_Is_Intrinsic_Subprogram (Def_Id);
8563 -- If no external name is present, then check that this
8564 -- is a valid intrinsic subprogram. If an external name
8565 -- is present, then this is handled by the back end.
8568 Check_Intrinsic_Subprogram
8569 (Def_Id, Get_Pragma_Arg (Arg2));
8573 -- Verify that the subprogram does not have a completion
8574 -- through a renaming declaration. For other completions the
8575 -- pragma appears as a too late representation.
8578 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8582 and then Nkind (Decl) = N_Subprogram_Declaration
8583 and then Present (Corresponding_Body (Decl))
8584 and then Nkind (Unit_Declaration_Node
8585 (Corresponding_Body (Decl))) =
8586 N_Subprogram_Renaming_Declaration
8588 Error_Msg_Sloc := Sloc (Def_Id);
8590 ("cannot import&, renaming already provided for "
8591 & "declaration #", N, Def_Id);
8595 -- If the pragma comes from an aspect specification, there
8596 -- must be an Import aspect specified as well. In the rare
8597 -- case where Import is set to False, the suprogram needs to
8598 -- have a local completion.
8601 Imp_Aspect : constant Node_Id :=
8602 Find_Aspect (Def_Id, Aspect_Import);
8606 if Present (Imp_Aspect)
8607 and then Present (Expression (Imp_Aspect))
8609 Expr := Expression (Imp_Aspect);
8610 Analyze_And_Resolve (Expr, Standard_Boolean);
8612 if Is_Entity_Name (Expr)
8613 and then Entity (Expr) = Standard_True
8615 Set_Has_Completion (Def_Id);
8618 -- If there is no expression, the default is True, as for
8619 -- all boolean aspects. Same for the older pragma.
8622 Set_Has_Completion (Def_Id);
8626 Process_Interface_Name (Def_Id, Arg3, Arg4);
8629 if Is_Compilation_Unit (Hom_Id) then
8631 -- Its possible homonyms are not affected by the pragma.
8632 -- Such homonyms might be present in the context of other
8633 -- units being compiled.
8637 elsif From_Aspect_Specification (N) then
8640 -- If the pragma was created by the compiler, then we don't
8641 -- want it to apply to other homonyms. This kind of case can
8642 -- occur when using pragma Provide_Shift_Operators, which
8643 -- generates implicit shift and rotate operators with Import
8644 -- pragmas that might apply to earlier explicit or implicit
8645 -- declarations marked with Import (for example, coming from
8646 -- an earlier pragma Provide_Shift_Operators for another type),
8647 -- and we don't generally want other homonyms being treated
8648 -- as imported or the pragma flagged as an illegal duplicate.
8650 elsif not Comes_From_Source (N) then
8654 Hom_Id := Homonym (Hom_Id);
8658 -- Import a CPP class
8660 elsif C = Convention_CPP
8661 and then (Is_Record_Type (Def_Id)
8662 or else Ekind (Def_Id) = E_Incomplete_Type)
8664 if Ekind (Def_Id) = E_Incomplete_Type then
8665 if Present (Full_View (Def_Id)) then
8666 Def_Id := Full_View (Def_Id);
8670 ("cannot import 'C'P'P type before full declaration seen",
8671 Get_Pragma_Arg (Arg2));
8673 -- Although we have reported the error we decorate it as
8674 -- CPP_Class to avoid reporting spurious errors
8676 Set_Is_CPP_Class (Def_Id);
8681 -- Types treated as CPP classes must be declared limited (note:
8682 -- this used to be a warning but there is no real benefit to it
8683 -- since we did effectively intend to treat the type as limited
8686 if not Is_Limited_Type (Def_Id) then
8688 ("imported 'C'P'P type must be limited",
8689 Get_Pragma_Arg (Arg2));
8692 if Etype (Def_Id) /= Def_Id
8693 and then not Is_CPP_Class (Root_Type (Def_Id))
8695 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8698 Set_Is_CPP_Class (Def_Id);
8700 -- Imported CPP types must not have discriminants (because C++
8701 -- classes do not have discriminants).
8703 if Has_Discriminants (Def_Id) then
8705 ("imported 'C'P'P type cannot have discriminants",
8706 First (Discriminant_Specifications
8707 (Declaration_Node (Def_Id))));
8710 -- Check that components of imported CPP types do not have default
8711 -- expressions. For private types this check is performed when the
8712 -- full view is analyzed (see Process_Full_View).
8714 if not Is_Private_Type (Def_Id) then
8715 Check_CPP_Type_Has_No_Defaults (Def_Id);
8718 -- Import a CPP exception
8720 elsif C = Convention_CPP
8721 and then Ekind (Def_Id) = E_Exception
8725 ("'External_'Name arguments is required for 'Cpp exception",
8728 -- As only a string is allowed, Check_Arg_Is_External_Name
8731 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8734 if Present (Arg4) then
8736 ("Link_Name argument not allowed for imported Cpp exception",
8740 -- Do not call Set_Interface_Name as the name of the exception
8741 -- shouldn't be modified (and in particular it shouldn't be
8742 -- the External_Name). For exceptions, the External_Name is the
8743 -- name of the RTTI structure.
8745 -- ??? Emit an error if pragma Import/Export_Exception is present
8747 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8749 Check_Arg_Count (3);
8750 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8752 Process_Import_Predefined_Type;
8756 ("second argument of pragma% must be object, subprogram "
8757 & "or incomplete type",
8761 -- If this pragma applies to a compilation unit, then the unit, which
8762 -- is a subprogram, does not require (or allow) a body. We also do
8763 -- not need to elaborate imported procedures.
8765 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8767 Cunit : constant Node_Id := Parent (Parent (N));
8769 Set_Body_Required (Cunit, False);
8772 end Process_Import_Or_Interface;
8774 --------------------
8775 -- Process_Inline --
8776 --------------------
8778 procedure Process_Inline (Status : Inline_Status) is
8785 Ghost_Error_Posted : Boolean := False;
8786 -- Flag set when an error concerning the illegal mix of Ghost and
8787 -- non-Ghost subprograms is emitted.
8789 Ghost_Id : Entity_Id := Empty;
8790 -- The entity of the first Ghost subprogram encountered while
8791 -- processing the arguments of the pragma.
8793 procedure Make_Inline (Subp : Entity_Id);
8794 -- Subp is the defining unit name of the subprogram declaration. If
8795 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8796 -- the corresponding body, if there is one present.
8798 procedure Set_Inline_Flags (Subp : Entity_Id);
8799 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8800 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8802 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8803 -- Returns True if it can be determined at this stage that inlining
8804 -- is not possible, for example if the body is available and contains
8805 -- exception handlers, we prevent inlining, since otherwise we can
8806 -- get undefined symbols at link time. This function also emits a
8807 -- warning if the pragma appears too late.
8809 -- ??? is business with link symbols still valid, or does it relate
8810 -- to front end ZCX which is being phased out ???
8812 ---------------------------
8813 -- Inlining_Not_Possible --
8814 ---------------------------
8816 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8817 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8821 if Nkind (Decl) = N_Subprogram_Body then
8822 Stats := Handled_Statement_Sequence (Decl);
8823 return Present (Exception_Handlers (Stats))
8824 or else Present (At_End_Proc (Stats));
8826 elsif Nkind (Decl) = N_Subprogram_Declaration
8827 and then Present (Corresponding_Body (Decl))
8829 if Analyzed (Corresponding_Body (Decl)) then
8830 Error_Msg_N ("pragma appears too late, ignored??", N);
8833 -- If the subprogram is a renaming as body, the body is just a
8834 -- call to the renamed subprogram, and inlining is trivially
8838 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8839 N_Subprogram_Renaming_Declaration
8845 Handled_Statement_Sequence
8846 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8849 Present (Exception_Handlers (Stats))
8850 or else Present (At_End_Proc (Stats));
8854 -- If body is not available, assume the best, the check is
8855 -- performed again when compiling enclosing package bodies.
8859 end Inlining_Not_Possible;
8865 procedure Make_Inline (Subp : Entity_Id) is
8866 Kind : constant Entity_Kind := Ekind (Subp);
8867 Inner_Subp : Entity_Id := Subp;
8870 -- Ignore if bad type, avoid cascaded error
8872 if Etype (Subp) = Any_Type then
8876 -- If inlining is not possible, for now do not treat as an error
8878 elsif Status /= Suppressed
8879 and then Front_End_Inlining
8880 and then Inlining_Not_Possible (Subp)
8885 -- Here we have a candidate for inlining, but we must exclude
8886 -- derived operations. Otherwise we would end up trying to inline
8887 -- a phantom declaration, and the result would be to drag in a
8888 -- body which has no direct inlining associated with it. That
8889 -- would not only be inefficient but would also result in the
8890 -- backend doing cross-unit inlining in cases where it was
8891 -- definitely inappropriate to do so.
8893 -- However, a simple Comes_From_Source test is insufficient, since
8894 -- we do want to allow inlining of generic instances which also do
8895 -- not come from source. We also need to recognize specs generated
8896 -- by the front-end for bodies that carry the pragma. Finally,
8897 -- predefined operators do not come from source but are not
8898 -- inlineable either.
8900 elsif Is_Generic_Instance (Subp)
8901 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8905 elsif not Comes_From_Source (Subp)
8906 and then Scope (Subp) /= Standard_Standard
8912 -- The referenced entity must either be the enclosing entity, or
8913 -- an entity declared within the current open scope.
8915 if Present (Scope (Subp))
8916 and then Scope (Subp) /= Current_Scope
8917 and then Subp /= Current_Scope
8920 ("argument of% must be entity in current scope", Assoc);
8924 -- Processing for procedure, operator or function. If subprogram
8925 -- is aliased (as for an instance) indicate that the renamed
8926 -- entity (if declared in the same unit) is inlined.
8927 -- If this is the anonymous subprogram created for a subprogram
8928 -- instance, the inlining applies to it directly. Otherwise we
8929 -- retrieve it as the alias of the visible subprogram instance.
8931 if Is_Subprogram (Subp) then
8932 if Is_Wrapper_Package (Scope (Subp)) then
8935 Inner_Subp := Ultimate_Alias (Inner_Subp);
8938 if In_Same_Source_Unit (Subp, Inner_Subp) then
8939 Set_Inline_Flags (Inner_Subp);
8941 Decl := Parent (Parent (Inner_Subp));
8943 if Nkind (Decl) = N_Subprogram_Declaration
8944 and then Present (Corresponding_Body (Decl))
8946 Set_Inline_Flags (Corresponding_Body (Decl));
8948 elsif Is_Generic_Instance (Subp)
8949 and then Comes_From_Source (Subp)
8951 -- Indicate that the body needs to be created for
8952 -- inlining subsequent calls. The instantiation node
8953 -- follows the declaration of the wrapper package
8954 -- created for it. The subprogram that requires the
8955 -- body is the anonymous one in the wrapper package.
8957 if Scope (Subp) /= Standard_Standard
8959 Need_Subprogram_Instance_Body
8960 (Next (Unit_Declaration_Node
8961 (Scope (Alias (Subp)))), Subp)
8966 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8967 -- appear in a formal part to apply to a formal subprogram.
8968 -- Do not apply check within an instance or a formal package
8969 -- the test will have been applied to the original generic.
8971 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8972 and then List_Containing (Decl) = List_Containing (N)
8973 and then not In_Instance
8976 ("Inline cannot apply to a formal subprogram", N);
8978 -- If Subp is a renaming, it is the renamed entity that
8979 -- will appear in any call, and be inlined. However, for
8980 -- ASIS uses it is convenient to indicate that the renaming
8981 -- itself is an inlined subprogram, so that some gnatcheck
8982 -- rules can be applied in the absence of expansion.
8984 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8985 Set_Inline_Flags (Subp);
8991 -- For a generic subprogram set flag as well, for use at the point
8992 -- of instantiation, to determine whether the body should be
8995 elsif Is_Generic_Subprogram (Subp) then
8996 Set_Inline_Flags (Subp);
8999 -- Literals are by definition inlined
9001 elsif Kind = E_Enumeration_Literal then
9004 -- Anything else is an error
9008 ("expect subprogram name for pragma%", Assoc);
9012 ----------------------
9013 -- Set_Inline_Flags --
9014 ----------------------
9016 procedure Set_Inline_Flags (Subp : Entity_Id) is
9018 -- First set the Has_Pragma_XXX flags and issue the appropriate
9019 -- errors and warnings for suspicious combinations.
9021 if Prag_Id = Pragma_No_Inline then
9022 if Has_Pragma_Inline_Always (Subp) then
9024 ("Inline_Always and No_Inline are mutually exclusive", N);
9025 elsif Has_Pragma_Inline (Subp) then
9027 ("Inline and No_Inline both specified for& ??",
9028 N, Entity (Subp_Id));
9031 Set_Has_Pragma_No_Inline (Subp);
9033 if Prag_Id = Pragma_Inline_Always then
9034 if Has_Pragma_No_Inline (Subp) then
9036 ("Inline_Always and No_Inline are mutually exclusive",
9040 Set_Has_Pragma_Inline_Always (Subp);
9042 if Has_Pragma_No_Inline (Subp) then
9044 ("Inline and No_Inline both specified for& ??",
9045 N, Entity (Subp_Id));
9049 Set_Has_Pragma_Inline (Subp);
9052 -- Then adjust the Is_Inlined flag. It can never be set if the
9053 -- subprogram is subject to pragma No_Inline.
9057 Set_Is_Inlined (Subp, False);
9061 if not Has_Pragma_No_Inline (Subp) then
9062 Set_Is_Inlined (Subp, True);
9066 -- A pragma that applies to a Ghost entity becomes Ghost for the
9067 -- purposes of legality checks and removal of ignored Ghost code.
9069 Mark_Pragma_As_Ghost (N, Subp);
9071 -- Capture the entity of the first Ghost subprogram being
9072 -- processed for error detection purposes.
9074 if Is_Ghost_Entity (Subp) then
9075 if No (Ghost_Id) then
9079 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9080 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9082 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9083 Ghost_Error_Posted := True;
9085 Error_Msg_Name_1 := Pname;
9087 ("pragma % cannot mention ghost and non-ghost subprograms",
9090 Error_Msg_Sloc := Sloc (Ghost_Id);
9091 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9093 Error_Msg_Sloc := Sloc (Subp);
9094 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9096 end Set_Inline_Flags;
9098 -- Start of processing for Process_Inline
9101 Check_No_Identifiers;
9102 Check_At_Least_N_Arguments (1);
9104 if Status = Enabled then
9105 Inline_Processing_Required := True;
9109 while Present (Assoc) loop
9110 Subp_Id := Get_Pragma_Arg (Assoc);
9114 if Is_Entity_Name (Subp_Id) then
9115 Subp := Entity (Subp_Id);
9117 if Subp = Any_Id then
9119 -- If previous error, avoid cascaded errors
9121 Check_Error_Detected;
9127 -- For the pragma case, climb homonym chain. This is
9128 -- what implements allowing the pragma in the renaming
9129 -- case, with the result applying to the ancestors, and
9130 -- also allows Inline to apply to all previous homonyms.
9132 if not From_Aspect_Specification (N) then
9133 while Present (Homonym (Subp))
9134 and then Scope (Homonym (Subp)) = Current_Scope
9136 Make_Inline (Homonym (Subp));
9137 Subp := Homonym (Subp);
9144 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9151 ----------------------------
9152 -- Process_Interface_Name --
9153 ----------------------------
9155 procedure Process_Interface_Name
9156 (Subprogram_Def : Entity_Id;
9162 String_Val : String_Id;
9164 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9165 -- SN is a string literal node for an interface name. This routine
9166 -- performs some minimal checks that the name is reasonable. In
9167 -- particular that no spaces or other obviously incorrect characters
9168 -- appear. This is only a warning, since any characters are allowed.
9170 ----------------------------------
9171 -- Check_Form_Of_Interface_Name --
9172 ----------------------------------
9174 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9175 S : constant String_Id := Strval (Expr_Value_S (SN));
9176 SL : constant Nat := String_Length (S);
9181 Error_Msg_N ("interface name cannot be null string", SN);
9184 for J in 1 .. SL loop
9185 C := Get_String_Char (S, J);
9187 -- Look for dubious character and issue unconditional warning.
9188 -- Definitely dubious if not in character range.
9190 if not In_Character_Range (C)
9192 -- Commas, spaces and (back)slashes are dubious
9194 or else Get_Character (C) = ','
9195 or else Get_Character (C) = '\'
9196 or else Get_Character (C) = ' '
9197 or else Get_Character (C) = '/'
9200 ("??interface name contains illegal character",
9201 Sloc (SN) + Source_Ptr (J));
9204 end Check_Form_Of_Interface_Name;
9206 -- Start of processing for Process_Interface_Name
9209 if No (Link_Arg) then
9210 if No (Ext_Arg) then
9213 elsif Chars (Ext_Arg) = Name_Link_Name then
9215 Link_Nam := Expression (Ext_Arg);
9218 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9219 Ext_Nam := Expression (Ext_Arg);
9224 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9225 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
9226 Ext_Nam := Expression (Ext_Arg);
9227 Link_Nam := Expression (Link_Arg);
9230 -- Check expressions for external name and link name are static
9232 if Present (Ext_Nam) then
9233 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
9234 Check_Form_Of_Interface_Name (Ext_Nam);
9236 -- Verify that external name is not the name of a local entity,
9237 -- which would hide the imported one and could lead to run-time
9238 -- surprises. The problem can only arise for entities declared in
9239 -- a package body (otherwise the external name is fully qualified
9240 -- and will not conflict).
9248 if Prag_Id = Pragma_Import then
9249 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
9251 E := Entity_Id (Get_Name_Table_Int (Nam));
9253 if Nam /= Chars (Subprogram_Def)
9254 and then Present (E)
9255 and then not Is_Overloadable (E)
9256 and then Is_Immediately_Visible (E)
9257 and then not Is_Imported (E)
9258 and then Ekind (Scope (E)) = E_Package
9261 while Present (Par) loop
9262 if Nkind (Par) = N_Package_Body then
9263 Error_Msg_Sloc := Sloc (E);
9265 ("imported entity is hidden by & declared#",
9270 Par := Parent (Par);
9277 if Present (Link_Nam) then
9278 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
9279 Check_Form_Of_Interface_Name (Link_Nam);
9282 -- If there is no link name, just set the external name
9284 if No (Link_Nam) then
9285 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
9287 -- For the Link_Name case, the given literal is preceded by an
9288 -- asterisk, which indicates to GCC that the given name should be
9289 -- taken literally, and in particular that no prepending of
9290 -- underlines should occur, even in systems where this is the
9295 Store_String_Char (Get_Char_Code ('*'));
9296 String_Val := Strval (Expr_Value_S (Link_Nam));
9297 Store_String_Chars (String_Val);
9299 Make_String_Literal (Sloc (Link_Nam),
9300 Strval => End_String);
9303 -- Set the interface name. If the entity is a generic instance, use
9304 -- its alias, which is the callable entity.
9306 if Is_Generic_Instance (Subprogram_Def) then
9307 Set_Encoded_Interface_Name
9308 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
9310 Set_Encoded_Interface_Name
9311 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9314 Check_Duplicated_Export_Name (Link_Nam);
9315 end Process_Interface_Name;
9317 -----------------------------------------
9318 -- Process_Interrupt_Or_Attach_Handler --
9319 -----------------------------------------
9321 procedure Process_Interrupt_Or_Attach_Handler is
9322 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9323 Prot_Typ : constant Entity_Id := Scope (Handler);
9326 -- A pragma that applies to a Ghost entity becomes Ghost for the
9327 -- purposes of legality checks and removal of ignored Ghost code.
9329 Mark_Pragma_As_Ghost (N, Handler);
9330 Set_Is_Interrupt_Handler (Handler);
9332 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9334 Record_Rep_Item (Prot_Typ, N);
9336 -- Chain the pragma on the contract for completeness
9338 Add_Contract_Item (N, Handler);
9339 end Process_Interrupt_Or_Attach_Handler;
9341 --------------------------------------------------
9342 -- Process_Restrictions_Or_Restriction_Warnings --
9343 --------------------------------------------------
9345 -- Note: some of the simple identifier cases were handled in par-prag,
9346 -- but it is harmless (and more straightforward) to simply handle all
9347 -- cases here, even if it means we repeat a bit of work in some cases.
9349 procedure Process_Restrictions_Or_Restriction_Warnings
9353 R_Id : Restriction_Id;
9359 -- Ignore all Restrictions pragmas in CodePeer mode
9361 if CodePeer_Mode then
9365 Check_Ada_83_Warning;
9366 Check_At_Least_N_Arguments (1);
9367 Check_Valid_Configuration_Pragma;
9370 while Present (Arg) loop
9372 Expr := Get_Pragma_Arg (Arg);
9374 -- Case of no restriction identifier present
9376 if Id = No_Name then
9377 if Nkind (Expr) /= N_Identifier then
9379 ("invalid form for restriction", Arg);
9384 (Process_Restriction_Synonyms (Expr));
9386 if R_Id not in All_Boolean_Restrictions then
9387 Error_Msg_Name_1 := Pname;
9389 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9391 -- Check for possible misspelling
9393 for J in Restriction_Id loop
9395 Rnm : constant String := Restriction_Id'Image (J);
9398 Name_Buffer (1 .. Rnm'Length) := Rnm;
9399 Name_Len := Rnm'Length;
9400 Set_Casing (All_Lower_Case);
9402 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9404 (Identifier_Casing (Current_Source_File));
9405 Error_Msg_String (1 .. Rnm'Length) :=
9406 Name_Buffer (1 .. Name_Len);
9407 Error_Msg_Strlen := Rnm'Length;
9408 Error_Msg_N -- CODEFIX
9409 ("\possible misspelling of ""~""",
9410 Get_Pragma_Arg (Arg));
9419 if Implementation_Restriction (R_Id) then
9420 Check_Restriction (No_Implementation_Restrictions, Arg);
9423 -- Special processing for No_Elaboration_Code restriction
9425 if R_Id = No_Elaboration_Code then
9427 -- Restriction is only recognized within a configuration
9428 -- pragma file, or within a unit of the main extended
9429 -- program. Note: the test for Main_Unit is needed to
9430 -- properly include the case of configuration pragma files.
9432 if not (Current_Sem_Unit = Main_Unit
9433 or else In_Extended_Main_Source_Unit (N))
9437 -- Don't allow in a subunit unless already specified in
9440 elsif Nkind (Parent (N)) = N_Compilation_Unit
9441 and then Nkind (Unit (Parent (N))) = N_Subunit
9442 and then not Restriction_Active (No_Elaboration_Code)
9445 ("invalid specification of ""No_Elaboration_Code""",
9448 ("\restriction cannot be specified in a subunit", N);
9450 ("\unless also specified in body or spec", N);
9453 -- If we accept a No_Elaboration_Code restriction, then it
9454 -- needs to be added to the configuration restriction set so
9455 -- that we get proper application to other units in the main
9456 -- extended source as required.
9459 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9463 -- If this is a warning, then set the warning unless we already
9464 -- have a real restriction active (we never want a warning to
9465 -- override a real restriction).
9468 if not Restriction_Active (R_Id) then
9469 Set_Restriction (R_Id, N);
9470 Restriction_Warnings (R_Id) := True;
9473 -- If real restriction case, then set it and make sure that the
9474 -- restriction warning flag is off, since a real restriction
9475 -- always overrides a warning.
9478 Set_Restriction (R_Id, N);
9479 Restriction_Warnings (R_Id) := False;
9482 -- Check for obsolescent restrictions in Ada 2005 mode
9485 and then Ada_Version >= Ada_2005
9486 and then (R_Id = No_Asynchronous_Control
9488 R_Id = No_Unchecked_Deallocation
9490 R_Id = No_Unchecked_Conversion)
9492 Check_Restriction (No_Obsolescent_Features, N);
9495 -- A very special case that must be processed here: pragma
9496 -- Restrictions (No_Exceptions) turns off all run-time
9497 -- checking. This is a bit dubious in terms of the formal
9498 -- language definition, but it is what is intended by RM
9499 -- H.4(12). Restriction_Warnings never affects generated code
9500 -- so this is done only in the real restriction case.
9502 -- Atomic_Synchronization is not a real check, so it is not
9503 -- affected by this processing).
9505 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9506 -- run-time checks in CodePeer and GNATprove modes: we want to
9507 -- generate checks for analysis purposes, as set respectively
9508 -- by -gnatC and -gnatd.F
9511 and then not (CodePeer_Mode or GNATprove_Mode)
9512 and then R_Id = No_Exceptions
9514 for J in Scope_Suppress.Suppress'Range loop
9515 if J /= Atomic_Synchronization then
9516 Scope_Suppress.Suppress (J) := True;
9521 -- Case of No_Dependence => unit-name. Note that the parser
9522 -- already made the necessary entry in the No_Dependence table.
9524 elsif Id = Name_No_Dependence then
9525 if not OK_No_Dependence_Unit_Name (Expr) then
9529 -- Case of No_Specification_Of_Aspect => aspect-identifier
9531 elsif Id = Name_No_Specification_Of_Aspect then
9536 if Nkind (Expr) /= N_Identifier then
9539 A_Id := Get_Aspect_Id (Chars (Expr));
9542 if A_Id = No_Aspect then
9543 Error_Pragma_Arg ("invalid restriction name", Arg);
9545 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9549 -- Case of No_Use_Of_Attribute => attribute-identifier
9551 elsif Id = Name_No_Use_Of_Attribute then
9552 if Nkind (Expr) /= N_Identifier
9553 or else not Is_Attribute_Name (Chars (Expr))
9555 Error_Msg_N ("unknown attribute name??", Expr);
9558 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9561 -- Case of No_Use_Of_Entity => fully-qualified-name
9563 elsif Id = Name_No_Use_Of_Entity then
9565 -- Restriction is only recognized within a configuration
9566 -- pragma file, or within a unit of the main extended
9567 -- program. Note: the test for Main_Unit is needed to
9568 -- properly include the case of configuration pragma files.
9570 if Current_Sem_Unit = Main_Unit
9571 or else In_Extended_Main_Source_Unit (N)
9573 if not OK_No_Dependence_Unit_Name (Expr) then
9574 Error_Msg_N ("wrong form for entity name", Expr);
9576 Set_Restriction_No_Use_Of_Entity
9577 (Expr, Warn, No_Profile);
9581 -- Case of No_Use_Of_Pragma => pragma-identifier
9583 elsif Id = Name_No_Use_Of_Pragma then
9584 if Nkind (Expr) /= N_Identifier
9585 or else not Is_Pragma_Name (Chars (Expr))
9587 Error_Msg_N ("unknown pragma name??", Expr);
9589 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9592 -- All other cases of restriction identifier present
9595 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9596 Analyze_And_Resolve (Expr, Any_Integer);
9598 if R_Id not in All_Parameter_Restrictions then
9600 ("invalid restriction parameter identifier", Arg);
9602 elsif not Is_OK_Static_Expression (Expr) then
9603 Flag_Non_Static_Expr
9604 ("value must be static expression!", Expr);
9607 elsif not Is_Integer_Type (Etype (Expr))
9608 or else Expr_Value (Expr) < 0
9611 ("value must be non-negative integer", Arg);
9614 -- Restriction pragma is active
9616 Val := Expr_Value (Expr);
9618 if not UI_Is_In_Int_Range (Val) then
9620 ("pragma ignored, value too large??", Arg);
9623 -- Warning case. If the real restriction is active, then we
9624 -- ignore the request, since warning never overrides a real
9625 -- restriction. Otherwise we set the proper warning. Note that
9626 -- this circuit sets the warning again if it is already set,
9627 -- which is what we want, since the constant may have changed.
9630 if not Restriction_Active (R_Id) then
9632 (R_Id, N, Integer (UI_To_Int (Val)));
9633 Restriction_Warnings (R_Id) := True;
9636 -- Real restriction case, set restriction and make sure warning
9637 -- flag is off since real restriction always overrides warning.
9640 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9641 Restriction_Warnings (R_Id) := False;
9647 end Process_Restrictions_Or_Restriction_Warnings;
9649 ---------------------------------
9650 -- Process_Suppress_Unsuppress --
9651 ---------------------------------
9653 -- Note: this procedure makes entries in the check suppress data
9654 -- structures managed by Sem. See spec of package Sem for full
9655 -- details on how we handle recording of check suppression.
9657 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9662 In_Package_Spec : constant Boolean :=
9663 Is_Package_Or_Generic_Package (Current_Scope)
9664 and then not In_Package_Body (Current_Scope);
9666 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9667 -- Used to suppress a single check on the given entity
9669 --------------------------------
9670 -- Suppress_Unsuppress_Echeck --
9671 --------------------------------
9673 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9675 -- Check for error of trying to set atomic synchronization for
9676 -- a non-atomic variable.
9678 if C = Atomic_Synchronization
9679 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9682 ("pragma & requires atomic type or variable",
9683 Pragma_Identifier (Original_Node (N)));
9686 Set_Checks_May_Be_Suppressed (E);
9688 if In_Package_Spec then
9689 Push_Global_Suppress_Stack_Entry
9692 Suppress => Suppress_Case);
9694 Push_Local_Suppress_Stack_Entry
9697 Suppress => Suppress_Case);
9700 -- If this is a first subtype, and the base type is distinct,
9701 -- then also set the suppress flags on the base type.
9703 if Is_First_Subtype (E) and then Etype (E) /= E then
9704 Suppress_Unsuppress_Echeck (Etype (E), C);
9706 end Suppress_Unsuppress_Echeck;
9708 -- Start of processing for Process_Suppress_Unsuppress
9711 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9712 -- on user code: we want to generate checks for analysis purposes, as
9713 -- set respectively by -gnatC and -gnatd.F
9715 if Comes_From_Source (N)
9716 and then (CodePeer_Mode or GNATprove_Mode)
9721 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9722 -- declarative part or a package spec (RM 11.5(5)).
9724 if not Is_Configuration_Pragma then
9725 Check_Is_In_Decl_Part_Or_Package_Spec;
9728 Check_At_Least_N_Arguments (1);
9729 Check_At_Most_N_Arguments (2);
9730 Check_No_Identifier (Arg1);
9731 Check_Arg_Is_Identifier (Arg1);
9733 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9735 if C = No_Check_Id then
9737 ("argument of pragma% is not valid check name", Arg1);
9740 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9742 if C = Elaboration_Check and then SPARK_Mode = On then
9744 ("Suppress of Elaboration_Check ignored in SPARK??",
9745 "\elaboration checking rules are statically enforced "
9746 & "(SPARK RM 7.7)", Arg1);
9749 -- One-argument case
9751 if Arg_Count = 1 then
9753 -- Make an entry in the local scope suppress table. This is the
9754 -- table that directly shows the current value of the scope
9755 -- suppress check for any check id value.
9757 if C = All_Checks then
9759 -- For All_Checks, we set all specific predefined checks with
9760 -- the exception of Elaboration_Check, which is handled
9761 -- specially because of not wanting All_Checks to have the
9762 -- effect of deactivating static elaboration order processing.
9763 -- Atomic_Synchronization is also not affected, since this is
9764 -- not a real check.
9766 for J in Scope_Suppress.Suppress'Range loop
9767 if J /= Elaboration_Check
9769 J /= Atomic_Synchronization
9771 Scope_Suppress.Suppress (J) := Suppress_Case;
9775 -- If not All_Checks, and predefined check, then set appropriate
9776 -- scope entry. Note that we will set Elaboration_Check if this
9777 -- is explicitly specified. Atomic_Synchronization is allowed
9778 -- only if internally generated and entity is atomic.
9780 elsif C in Predefined_Check_Id
9781 and then (not Comes_From_Source (N)
9782 or else C /= Atomic_Synchronization)
9784 Scope_Suppress.Suppress (C) := Suppress_Case;
9787 -- Also make an entry in the Local_Entity_Suppress table
9789 Push_Local_Suppress_Stack_Entry
9792 Suppress => Suppress_Case);
9794 -- Case of two arguments present, where the check is suppressed for
9795 -- a specified entity (given as the second argument of the pragma)
9798 -- This is obsolescent in Ada 2005 mode
9800 if Ada_Version >= Ada_2005 then
9801 Check_Restriction (No_Obsolescent_Features, Arg2);
9804 Check_Optional_Identifier (Arg2, Name_On);
9805 E_Id := Get_Pragma_Arg (Arg2);
9808 if not Is_Entity_Name (E_Id) then
9810 ("second argument of pragma% must be entity name", Arg2);
9819 -- A pragma that applies to a Ghost entity becomes Ghost for the
9820 -- purposes of legality checks and removal of ignored Ghost code.
9822 Mark_Pragma_As_Ghost (N, E);
9824 -- Enforce RM 11.5(7) which requires that for a pragma that
9825 -- appears within a package spec, the named entity must be
9826 -- within the package spec. We allow the package name itself
9827 -- to be mentioned since that makes sense, although it is not
9828 -- strictly allowed by 11.5(7).
9831 and then E /= Current_Scope
9832 and then Scope (E) /= Current_Scope
9835 ("entity in pragma% is not in package spec (RM 11.5(7))",
9839 -- Loop through homonyms. As noted below, in the case of a package
9840 -- spec, only homonyms within the package spec are considered.
9843 Suppress_Unsuppress_Echeck (E, C);
9845 if Is_Generic_Instance (E)
9846 and then Is_Subprogram (E)
9847 and then Present (Alias (E))
9849 Suppress_Unsuppress_Echeck (Alias (E), C);
9852 -- Move to next homonym if not aspect spec case
9854 exit when From_Aspect_Specification (N);
9858 -- If we are within a package specification, the pragma only
9859 -- applies to homonyms in the same scope.
9861 exit when In_Package_Spec
9862 and then Scope (E) /= Current_Scope;
9865 end Process_Suppress_Unsuppress;
9867 -------------------------------
9868 -- Record_Independence_Check --
9869 -------------------------------
9871 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9873 -- For GCC back ends the validation is done a priori
9875 if not AAMP_On_Target then
9879 Independence_Checks.Append ((N, E));
9880 end Record_Independence_Check;
9886 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9888 if Is_Imported (E) then
9890 ("cannot export entity& that was previously imported", Arg);
9892 elsif Present (Address_Clause (E))
9893 and then not Relaxed_RM_Semantics
9896 ("cannot export entity& that has an address clause", Arg);
9899 Set_Is_Exported (E);
9901 -- Generate a reference for entity explicitly, because the
9902 -- identifier may be overloaded and name resolution will not
9905 Generate_Reference (E, Arg);
9907 -- Deal with exporting non-library level entity
9909 if not Is_Library_Level_Entity (E) then
9911 -- Not allowed at all for subprograms
9913 if Is_Subprogram (E) then
9914 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9916 -- Otherwise set public and statically allocated
9920 Set_Is_Statically_Allocated (E);
9922 -- Warn if the corresponding W flag is set
9924 if Warn_On_Export_Import
9926 -- Only do this for something that was in the source. Not
9927 -- clear if this can be False now (there used for sure to be
9928 -- cases on some systems where it was False), but anyway the
9929 -- test is harmless if not needed, so it is retained.
9931 and then Comes_From_Source (Arg)
9934 ("?x?& has been made static as a result of Export",
9937 ("\?x?this usage is non-standard and non-portable",
9943 if Warn_On_Export_Import and then Is_Type (E) then
9944 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9947 if Warn_On_Export_Import and Inside_A_Generic then
9949 ("all instances of& will have the same external name?x?",
9954 ----------------------------------------------
9955 -- Set_Extended_Import_Export_External_Name --
9956 ----------------------------------------------
9958 procedure Set_Extended_Import_Export_External_Name
9959 (Internal_Ent : Entity_Id;
9960 Arg_External : Node_Id)
9962 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9966 if No (Arg_External) then
9970 Check_Arg_Is_External_Name (Arg_External);
9972 if Nkind (Arg_External) = N_String_Literal then
9973 if String_Length (Strval (Arg_External)) = 0 then
9976 New_Name := Adjust_External_Name_Case (Arg_External);
9979 elsif Nkind (Arg_External) = N_Identifier then
9980 New_Name := Get_Default_External_Name (Arg_External);
9982 -- Check_Arg_Is_External_Name should let through only identifiers and
9983 -- string literals or static string expressions (which are folded to
9984 -- string literals).
9987 raise Program_Error;
9990 -- If we already have an external name set (by a prior normal Import
9991 -- or Export pragma), then the external names must match
9993 if Present (Interface_Name (Internal_Ent)) then
9995 -- Ignore mismatching names in CodePeer mode, to support some
9996 -- old compilers which would export the same procedure under
9997 -- different names, e.g:
9999 -- pragma Export_Procedure (P, "a");
10000 -- pragma Export_Procedure (P, "b");
10002 if CodePeer_Mode then
10006 Check_Matching_Internal_Names : declare
10007 S1 : constant String_Id := Strval (Old_Name);
10008 S2 : constant String_Id := Strval (New_Name);
10010 procedure Mismatch;
10011 pragma No_Return (Mismatch);
10012 -- Called if names do not match
10018 procedure Mismatch is
10020 Error_Msg_Sloc := Sloc (Old_Name);
10022 ("external name does not match that given #",
10026 -- Start of processing for Check_Matching_Internal_Names
10029 if String_Length (S1) /= String_Length (S2) then
10033 for J in 1 .. String_Length (S1) loop
10034 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10039 end Check_Matching_Internal_Names;
10041 -- Otherwise set the given name
10044 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10045 Check_Duplicated_Export_Name (New_Name);
10047 end Set_Extended_Import_Export_External_Name;
10053 procedure Set_Imported (E : Entity_Id) is
10055 -- Error message if already imported or exported
10057 if Is_Exported (E) or else Is_Imported (E) then
10059 -- Error if being set Exported twice
10061 if Is_Exported (E) then
10062 Error_Msg_NE ("entity& was previously exported", N, E);
10064 -- Ignore error in CodePeer mode where we treat all imported
10065 -- subprograms as unknown.
10067 elsif CodePeer_Mode then
10070 -- OK if Import/Interface case
10072 elsif Import_Interface_Present (N) then
10075 -- Error if being set Imported twice
10078 Error_Msg_NE ("entity& was previously imported", N, E);
10081 Error_Msg_Name_1 := Pname;
10083 ("\(pragma% applies to all previous entities)", N);
10085 Error_Msg_Sloc := Sloc (E);
10086 Error_Msg_NE ("\import not allowed for& declared#", N, E);
10088 -- Here if not previously imported or exported, OK to import
10091 Set_Is_Imported (E);
10093 -- For subprogram, set Import_Pragma field
10095 if Is_Subprogram (E) then
10096 Set_Import_Pragma (E, N);
10099 -- If the entity is an object that is not at the library level,
10100 -- then it is statically allocated. We do not worry about objects
10101 -- with address clauses in this context since they are not really
10102 -- imported in the linker sense.
10105 and then not Is_Library_Level_Entity (E)
10106 and then No (Address_Clause (E))
10108 Set_Is_Statically_Allocated (E);
10115 -------------------------
10116 -- Set_Mechanism_Value --
10117 -------------------------
10119 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10120 -- analyzed, since it is semantic nonsense), so we get it in the exact
10121 -- form created by the parser.
10123 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10124 procedure Bad_Mechanism;
10125 pragma No_Return (Bad_Mechanism);
10126 -- Signal bad mechanism name
10128 -------------------------
10129 -- Bad_Mechanism_Value --
10130 -------------------------
10132 procedure Bad_Mechanism is
10134 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10137 -- Start of processing for Set_Mechanism_Value
10140 if Mechanism (Ent) /= Default_Mechanism then
10142 ("mechanism for & has already been set", Mech_Name, Ent);
10145 -- MECHANISM_NAME ::= value | reference
10147 if Nkind (Mech_Name) = N_Identifier then
10148 if Chars (Mech_Name) = Name_Value then
10149 Set_Mechanism (Ent, By_Copy);
10152 elsif Chars (Mech_Name) = Name_Reference then
10153 Set_Mechanism (Ent, By_Reference);
10156 elsif Chars (Mech_Name) = Name_Copy then
10158 ("bad mechanism name, Value assumed", Mech_Name);
10167 end Set_Mechanism_Value;
10169 --------------------------
10170 -- Set_Rational_Profile --
10171 --------------------------
10173 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10174 -- extension to the semantics of renaming declarations.
10176 procedure Set_Rational_Profile is
10178 Implicit_Packing := True;
10179 Overriding_Renamings := True;
10180 Use_VADS_Size := True;
10181 end Set_Rational_Profile;
10183 ---------------------------
10184 -- Set_Ravenscar_Profile --
10185 ---------------------------
10187 -- The tasks to be done here are
10189 -- Set required policies
10191 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10192 -- pragma Locking_Policy (Ceiling_Locking)
10194 -- Set Detect_Blocking mode
10196 -- Set required restrictions (see System.Rident for detailed list)
10198 -- Set the No_Dependence rules
10199 -- No_Dependence => Ada.Asynchronous_Task_Control
10200 -- No_Dependence => Ada.Calendar
10201 -- No_Dependence => Ada.Execution_Time.Group_Budget
10202 -- No_Dependence => Ada.Execution_Time.Timers
10203 -- No_Dependence => Ada.Task_Attributes
10204 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10206 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
10207 procedure Set_Error_Msg_To_Profile_Name;
10208 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10211 -----------------------------------
10212 -- Set_Error_Msg_To_Profile_Name --
10213 -----------------------------------
10215 procedure Set_Error_Msg_To_Profile_Name is
10216 Prof_Nam : constant Node_Id :=
10218 (First (Pragma_Argument_Associations (N)));
10221 Get_Name_String (Chars (Prof_Nam));
10222 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
10223 Error_Msg_Strlen := Name_Len;
10224 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
10225 end Set_Error_Msg_To_Profile_Name;
10234 -- Start of processing for Set_Ravenscar_Profile
10237 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10239 if Task_Dispatching_Policy /= ' '
10240 and then Task_Dispatching_Policy /= 'F'
10242 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10243 Set_Error_Msg_To_Profile_Name;
10244 Error_Pragma ("Profile (~) incompatible with policy#");
10246 -- Set the FIFO_Within_Priorities policy, but always preserve
10247 -- System_Location since we like the error message with the run time
10251 Task_Dispatching_Policy := 'F';
10253 if Task_Dispatching_Policy_Sloc /= System_Location then
10254 Task_Dispatching_Policy_Sloc := Loc;
10258 -- pragma Locking_Policy (Ceiling_Locking)
10260 if Locking_Policy /= ' '
10261 and then Locking_Policy /= 'C'
10263 Error_Msg_Sloc := Locking_Policy_Sloc;
10264 Set_Error_Msg_To_Profile_Name;
10265 Error_Pragma ("Profile (~) incompatible with policy#");
10267 -- Set the Ceiling_Locking policy, but preserve System_Location since
10268 -- we like the error message with the run time name.
10271 Locking_Policy := 'C';
10273 if Locking_Policy_Sloc /= System_Location then
10274 Locking_Policy_Sloc := Loc;
10278 -- pragma Detect_Blocking
10280 Detect_Blocking := True;
10282 -- Set the corresponding restrictions
10284 Set_Profile_Restrictions
10285 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
10287 -- Set the No_Dependence restrictions
10289 -- The following No_Dependence restrictions:
10290 -- No_Dependence => Ada.Asynchronous_Task_Control
10291 -- No_Dependence => Ada.Calendar
10292 -- No_Dependence => Ada.Task_Attributes
10293 -- are already set by previous call to Set_Profile_Restrictions.
10295 -- Set the following restrictions which were added to Ada 2005:
10296 -- No_Dependence => Ada.Execution_Time.Group_Budget
10297 -- No_Dependence => Ada.Execution_Time.Timers
10299 -- ??? The use of Name_Buffer here is suspicious. The names should
10300 -- be registered in snames.ads-tmpl and used to build the qualified
10303 if Ada_Version >= Ada_2005 then
10304 Name_Buffer (1 .. 3) := "ada";
10307 Pref_Id := Make_Identifier (Loc, Name_Find);
10309 Name_Buffer (1 .. 14) := "execution_time";
10312 Sel_Id := Make_Identifier (Loc, Name_Find);
10315 Make_Selected_Component
10318 Selector_Name => Sel_Id);
10320 Name_Buffer (1 .. 13) := "group_budgets";
10323 Sel_Id := Make_Identifier (Loc, Name_Find);
10326 Make_Selected_Component
10329 Selector_Name => Sel_Id);
10331 Set_Restriction_No_Dependence
10333 Warn => Treat_Restrictions_As_Warnings,
10334 Profile => Ravenscar);
10336 Name_Buffer (1 .. 6) := "timers";
10339 Sel_Id := Make_Identifier (Loc, Name_Find);
10342 Make_Selected_Component
10345 Selector_Name => Sel_Id);
10347 Set_Restriction_No_Dependence
10349 Warn => Treat_Restrictions_As_Warnings,
10350 Profile => Ravenscar);
10353 -- Set the following restriction which was added to Ada 2012 (see
10355 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10357 if Ada_Version >= Ada_2012 then
10358 Name_Buffer (1 .. 6) := "system";
10361 Pref_Id := Make_Identifier (Loc, Name_Find);
10363 Name_Buffer (1 .. 15) := "multiprocessors";
10366 Sel_Id := Make_Identifier (Loc, Name_Find);
10369 Make_Selected_Component
10372 Selector_Name => Sel_Id);
10374 Name_Buffer (1 .. 19) := "dispatching_domains";
10377 Sel_Id := Make_Identifier (Loc, Name_Find);
10380 Make_Selected_Component
10383 Selector_Name => Sel_Id);
10385 Set_Restriction_No_Dependence
10387 Warn => Treat_Restrictions_As_Warnings,
10388 Profile => Ravenscar);
10390 end Set_Ravenscar_Profile;
10392 -- Start of processing for Analyze_Pragma
10395 -- The following code is a defense against recursion. Not clear that
10396 -- this can happen legitimately, but perhaps some error situations can
10397 -- cause it, and we did see this recursion during testing.
10399 if Analyzed (N) then
10405 Check_Restriction_No_Use_Of_Pragma (N);
10407 -- Deal with unrecognized pragma
10409 Pname := Pragma_Name (N);
10411 if not Is_Pragma_Name (Pname) then
10412 if Warn_On_Unrecognized_Pragma then
10413 Error_Msg_Name_1 := Pname;
10414 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10416 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10417 if Is_Bad_Spelling_Of (Pname, PN) then
10418 Error_Msg_Name_1 := PN;
10419 Error_Msg_N -- CODEFIX
10420 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10429 -- Ignore pragma if Ignore_Pragma applies
10431 if Get_Name_Table_Boolean3 (Pname) then
10435 -- Here to start processing for recognized pragma
10437 Prag_Id := Get_Pragma_Id (Pname);
10438 Pname := Original_Aspect_Pragma_Name (N);
10440 -- Capture setting of Opt.Uneval_Old
10442 case Opt.Uneval_Old is
10444 Set_Uneval_Old_Accept (N);
10448 Set_Uneval_Old_Warn (N);
10450 raise Program_Error;
10453 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10454 -- is already set, indicating that we have already checked the policy
10455 -- at the right point. This happens for example in the case of a pragma
10456 -- that is derived from an Aspect.
10458 if Is_Ignored (N) or else Is_Checked (N) then
10461 -- For a pragma that is a rewriting of another pragma, copy the
10462 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10464 elsif Is_Rewrite_Substitution (N)
10465 and then Nkind (Original_Node (N)) = N_Pragma
10466 and then Original_Node (N) /= N
10468 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10469 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10471 -- Otherwise query the applicable policy at this point
10474 Check_Applicable_Policy (N);
10476 -- If pragma is disabled, rewrite as NULL and skip analysis
10478 if Is_Disabled (N) then
10479 Rewrite (N, Make_Null_Statement (Loc));
10485 -- Preset arguments
10493 if Present (Pragma_Argument_Associations (N)) then
10494 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10495 Arg1 := First (Pragma_Argument_Associations (N));
10497 if Present (Arg1) then
10498 Arg2 := Next (Arg1);
10500 if Present (Arg2) then
10501 Arg3 := Next (Arg2);
10503 if Present (Arg3) then
10504 Arg4 := Next (Arg3);
10510 -- An enumeration type defines the pragmas that are supported by the
10511 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10512 -- into the corresponding enumeration value for the following case.
10520 -- pragma Abort_Defer;
10522 when Pragma_Abort_Defer =>
10524 Check_Arg_Count (0);
10526 -- The only required semantic processing is to check the
10527 -- placement. This pragma must appear at the start of the
10528 -- statement sequence of a handled sequence of statements.
10530 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10531 or else N /= First (Statements (Parent (N)))
10536 --------------------
10537 -- Abstract_State --
10538 --------------------
10540 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10542 -- ABSTRACT_STATE_LIST ::=
10544 -- | STATE_NAME_WITH_OPTIONS
10545 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10547 -- STATE_NAME_WITH_OPTIONS ::=
10549 -- | (STATE_NAME with OPTION_LIST)
10551 -- OPTION_LIST ::= OPTION {, OPTION}
10555 -- | NAME_VALUE_OPTION
10557 -- SIMPLE_OPTION ::= Ghost | Synchronous
10559 -- NAME_VALUE_OPTION ::=
10560 -- Part_Of => ABSTRACT_STATE
10561 -- | External [=> EXTERNAL_PROPERTY_LIST]
10563 -- EXTERNAL_PROPERTY_LIST ::=
10564 -- EXTERNAL_PROPERTY
10565 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10567 -- EXTERNAL_PROPERTY ::=
10568 -- Async_Readers [=> boolean_EXPRESSION]
10569 -- | Async_Writers [=> boolean_EXPRESSION]
10570 -- | Effective_Reads [=> boolean_EXPRESSION]
10571 -- | Effective_Writes [=> boolean_EXPRESSION]
10572 -- others => boolean_EXPRESSION
10574 -- STATE_NAME ::= defining_identifier
10576 -- ABSTRACT_STATE ::= name
10578 -- Characteristics:
10580 -- * Analysis - The annotation is fully analyzed immediately upon
10581 -- elaboration as it cannot forward reference entities.
10583 -- * Expansion - None.
10585 -- * Template - The annotation utilizes the generic template of the
10586 -- related package declaration.
10588 -- * Globals - The annotation cannot reference global entities.
10590 -- * Instance - The annotation is instantiated automatically when
10591 -- the related generic package is instantiated.
10593 when Pragma_Abstract_State => Abstract_State : declare
10594 Missing_Parentheses : Boolean := False;
10595 -- Flag set when a state declaration with options is not properly
10598 -- Flags used to verify the consistency of states
10600 Non_Null_Seen : Boolean := False;
10601 Null_Seen : Boolean := False;
10603 procedure Analyze_Abstract_State
10605 Pack_Id : Entity_Id);
10606 -- Verify the legality of a single state declaration. Create and
10607 -- decorate a state abstraction entity and introduce it into the
10608 -- visibility chain. Pack_Id denotes the entity or the related
10609 -- package where pragma Abstract_State appears.
10611 procedure Malformed_State_Error (State : Node_Id);
10612 -- Emit an error concerning the illegal declaration of abstract
10613 -- state State. This routine diagnoses syntax errors that lead to
10614 -- a different parse tree. The error is issued regardless of the
10615 -- SPARK mode in effect.
10617 ----------------------------
10618 -- Analyze_Abstract_State --
10619 ----------------------------
10621 procedure Analyze_Abstract_State
10623 Pack_Id : Entity_Id)
10625 -- Flags used to verify the consistency of options
10627 AR_Seen : Boolean := False;
10628 AW_Seen : Boolean := False;
10629 ER_Seen : Boolean := False;
10630 EW_Seen : Boolean := False;
10631 External_Seen : Boolean := False;
10632 Ghost_Seen : Boolean := False;
10633 Others_Seen : Boolean := False;
10634 Part_Of_Seen : Boolean := False;
10635 Synchronous_Seen : Boolean := False;
10637 -- Flags used to store the static value of all external states'
10640 AR_Val : Boolean := False;
10641 AW_Val : Boolean := False;
10642 ER_Val : Boolean := False;
10643 EW_Val : Boolean := False;
10645 State_Id : Entity_Id := Empty;
10646 -- The entity to be generated for the current state declaration
10648 procedure Analyze_External_Option (Opt : Node_Id);
10649 -- Verify the legality of option External
10651 procedure Analyze_External_Property
10653 Expr : Node_Id := Empty);
10654 -- Verify the legailty of a single external property. Prop
10655 -- denotes the external property. Expr is the expression used
10656 -- to set the property.
10658 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10659 -- Verify the legality of option Part_Of
10661 procedure Check_Duplicate_Option
10663 Status : in out Boolean);
10664 -- Flag Status denotes whether a particular option has been
10665 -- seen while processing a state. This routine verifies that
10666 -- Opt is not a duplicate option and sets the flag Status
10667 -- (SPARK RM 7.1.4(1)).
10669 procedure Check_Duplicate_Property
10671 Status : in out Boolean);
10672 -- Flag Status denotes whether a particular property has been
10673 -- seen while processing option External. This routine verifies
10674 -- that Prop is not a duplicate property and sets flag Status.
10675 -- Opt is not a duplicate property and sets the flag Status.
10676 -- (SPARK RM 7.1.4(2))
10678 procedure Check_Ghost_Synchronous;
10679 -- Ensure that the abstract state is not subject to both Ghost
10680 -- and Synchronous simple options. Emit an error if this is the
10683 procedure Create_Abstract_State
10687 Is_Null : Boolean);
10688 -- Generate an abstract state entity with name Nam and enter it
10689 -- into visibility. Decl is the "declaration" of the state as
10690 -- it appears in pragma Abstract_State. Loc is the location of
10691 -- the related state "declaration". Flag Is_Null should be set
10692 -- when the associated Abstract_State pragma defines a null
10695 -----------------------------
10696 -- Analyze_External_Option --
10697 -----------------------------
10699 procedure Analyze_External_Option (Opt : Node_Id) is
10700 Errors : constant Nat := Serious_Errors_Detected;
10702 Props : Node_Id := Empty;
10705 if Nkind (Opt) = N_Component_Association then
10706 Props := Expression (Opt);
10709 -- External state with properties
10711 if Present (Props) then
10713 -- Multiple properties appear as an aggregate
10715 if Nkind (Props) = N_Aggregate then
10717 -- Simple property form
10719 Prop := First (Expressions (Props));
10720 while Present (Prop) loop
10721 Analyze_External_Property (Prop);
10725 -- Property with expression form
10727 Prop := First (Component_Associations (Props));
10728 while Present (Prop) loop
10729 Analyze_External_Property
10730 (Prop => First (Choices (Prop)),
10731 Expr => Expression (Prop));
10739 Analyze_External_Property (Props);
10742 -- An external state defined without any properties defaults
10743 -- all properties to True.
10752 -- Once all external properties have been processed, verify
10753 -- their mutual interaction. Do not perform the check when
10754 -- at least one of the properties is illegal as this will
10755 -- produce a bogus error.
10757 if Errors = Serious_Errors_Detected then
10758 Check_External_Properties
10759 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10761 end Analyze_External_Option;
10763 -------------------------------
10764 -- Analyze_External_Property --
10765 -------------------------------
10767 procedure Analyze_External_Property
10769 Expr : Node_Id := Empty)
10771 Expr_Val : Boolean;
10774 -- Check the placement of "others" (if available)
10776 if Nkind (Prop) = N_Others_Choice then
10777 if Others_Seen then
10779 ("only one others choice allowed in option External",
10782 Others_Seen := True;
10785 elsif Others_Seen then
10787 ("others must be the last property in option External",
10790 -- The only remaining legal options are the four predefined
10791 -- external properties.
10793 elsif Nkind (Prop) = N_Identifier
10794 and then Nam_In (Chars (Prop), Name_Async_Readers,
10795 Name_Async_Writers,
10796 Name_Effective_Reads,
10797 Name_Effective_Writes)
10801 -- Otherwise the construct is not a valid property
10804 SPARK_Msg_N ("invalid external state property", Prop);
10808 -- Ensure that the expression of the external state property
10809 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10811 if Present (Expr) then
10812 Analyze_And_Resolve (Expr, Standard_Boolean);
10814 if Is_OK_Static_Expression (Expr) then
10815 Expr_Val := Is_True (Expr_Value (Expr));
10818 ("expression of external state property must be "
10822 -- The lack of expression defaults the property to True
10828 -- Named properties
10830 if Nkind (Prop) = N_Identifier then
10831 if Chars (Prop) = Name_Async_Readers then
10832 Check_Duplicate_Property (Prop, AR_Seen);
10833 AR_Val := Expr_Val;
10835 elsif Chars (Prop) = Name_Async_Writers then
10836 Check_Duplicate_Property (Prop, AW_Seen);
10837 AW_Val := Expr_Val;
10839 elsif Chars (Prop) = Name_Effective_Reads then
10840 Check_Duplicate_Property (Prop, ER_Seen);
10841 ER_Val := Expr_Val;
10844 Check_Duplicate_Property (Prop, EW_Seen);
10845 EW_Val := Expr_Val;
10848 -- The handling of property "others" must take into account
10849 -- all other named properties that have been encountered so
10850 -- far. Only those that have not been seen are affected by
10854 if not AR_Seen then
10855 AR_Val := Expr_Val;
10858 if not AW_Seen then
10859 AW_Val := Expr_Val;
10862 if not ER_Seen then
10863 ER_Val := Expr_Val;
10866 if not EW_Seen then
10867 EW_Val := Expr_Val;
10870 end Analyze_External_Property;
10872 ----------------------------
10873 -- Analyze_Part_Of_Option --
10874 ----------------------------
10876 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10877 Encap : constant Node_Id := Expression (Opt);
10878 Constits : Elist_Id;
10879 Encap_Id : Entity_Id;
10883 Check_Duplicate_Option (Opt, Part_Of_Seen);
10886 (Indic => First (Choices (Opt)),
10887 Item_Id => State_Id,
10889 Encap_Id => Encap_Id,
10892 -- The Part_Of indicator transforms the abstract state into
10893 -- a constituent of the encapsulating state or single
10894 -- concurrent type.
10897 pragma Assert (Present (Encap_Id));
10898 Constits := Part_Of_Constituents (Encap_Id);
10900 if No (Constits) then
10901 Constits := New_Elmt_List;
10902 Set_Part_Of_Constituents (Encap_Id, Constits);
10905 Append_Elmt (State_Id, Constits);
10906 Set_Encapsulating_State (State_Id, Encap_Id);
10908 end Analyze_Part_Of_Option;
10910 ----------------------------
10911 -- Check_Duplicate_Option --
10912 ----------------------------
10914 procedure Check_Duplicate_Option
10916 Status : in out Boolean)
10920 SPARK_Msg_N ("duplicate state option", Opt);
10924 end Check_Duplicate_Option;
10926 ------------------------------
10927 -- Check_Duplicate_Property --
10928 ------------------------------
10930 procedure Check_Duplicate_Property
10932 Status : in out Boolean)
10936 SPARK_Msg_N ("duplicate external property", Prop);
10940 end Check_Duplicate_Property;
10942 -----------------------------
10943 -- Check_Ghost_Synchronous --
10944 -----------------------------
10946 procedure Check_Ghost_Synchronous is
10948 -- A synchronized abstract state cannot be Ghost and vice
10949 -- versa (SPARK RM 6.9(19)).
10951 if Ghost_Seen and Synchronous_Seen then
10952 SPARK_Msg_N ("synchronized state cannot be ghost", State);
10954 end Check_Ghost_Synchronous;
10956 ---------------------------
10957 -- Create_Abstract_State --
10958 ---------------------------
10960 procedure Create_Abstract_State
10967 -- The abstract state may be semi-declared when the related
10968 -- package was withed through a limited with clause. In that
10969 -- case reuse the entity to fully declare the state.
10971 if Present (Decl) and then Present (Entity (Decl)) then
10972 State_Id := Entity (Decl);
10974 -- Otherwise the elaboration of pragma Abstract_State
10975 -- declares the state.
10978 State_Id := Make_Defining_Identifier (Loc, Nam);
10980 if Present (Decl) then
10981 Set_Entity (Decl, State_Id);
10985 -- Null states never come from source
10987 Set_Comes_From_Source (State_Id, not Is_Null);
10988 Set_Parent (State_Id, State);
10989 Set_Ekind (State_Id, E_Abstract_State);
10990 Set_Etype (State_Id, Standard_Void_Type);
10991 Set_Encapsulating_State (State_Id, Empty);
10993 -- An abstract state declared within a Ghost region becomes
10994 -- Ghost (SPARK RM 6.9(2)).
10996 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
10997 Set_Is_Ghost_Entity (State_Id);
11000 -- Establish a link between the state declaration and the
11001 -- abstract state entity. Note that a null state remains as
11002 -- N_Null and does not carry any linkages.
11004 if not Is_Null then
11005 if Present (Decl) then
11006 Set_Entity (Decl, State_Id);
11007 Set_Etype (Decl, Standard_Void_Type);
11010 -- Every non-null state must be defined, nameable and
11013 Push_Scope (Pack_Id);
11014 Generate_Definition (State_Id);
11015 Enter_Name (State_Id);
11018 end Create_Abstract_State;
11025 -- Start of processing for Analyze_Abstract_State
11028 -- A package with a null abstract state is not allowed to
11029 -- declare additional states.
11033 ("package & has null abstract state", State, Pack_Id);
11035 -- Null states appear as internally generated entities
11037 elsif Nkind (State) = N_Null then
11038 Create_Abstract_State
11039 (Nam => New_Internal_Name ('S'),
11041 Loc => Sloc (State),
11045 -- Catch a case where a null state appears in a list of
11046 -- non-null states.
11048 if Non_Null_Seen then
11050 ("package & has non-null abstract state",
11054 -- Simple state declaration
11056 elsif Nkind (State) = N_Identifier then
11057 Create_Abstract_State
11058 (Nam => Chars (State),
11060 Loc => Sloc (State),
11062 Non_Null_Seen := True;
11064 -- State declaration with various options. This construct
11065 -- appears as an extension aggregate in the tree.
11067 elsif Nkind (State) = N_Extension_Aggregate then
11068 if Nkind (Ancestor_Part (State)) = N_Identifier then
11069 Create_Abstract_State
11070 (Nam => Chars (Ancestor_Part (State)),
11071 Decl => Ancestor_Part (State),
11072 Loc => Sloc (Ancestor_Part (State)),
11074 Non_Null_Seen := True;
11077 ("state name must be an identifier",
11078 Ancestor_Part (State));
11081 -- Options External, Ghost and Synchronous appear as
11084 Opt := First (Expressions (State));
11085 while Present (Opt) loop
11086 if Nkind (Opt) = N_Identifier then
11090 if Chars (Opt) = Name_External then
11091 Check_Duplicate_Option (Opt, External_Seen);
11092 Analyze_External_Option (Opt);
11096 elsif Chars (Opt) = Name_Ghost then
11097 Check_Duplicate_Option (Opt, Ghost_Seen);
11098 Check_Ghost_Synchronous;
11100 if Present (State_Id) then
11101 Set_Is_Ghost_Entity (State_Id);
11106 elsif Chars (Opt) = Name_Synchronous then
11107 Check_Duplicate_Option (Opt, Synchronous_Seen);
11108 Check_Ghost_Synchronous;
11110 -- Option Part_Of without an encapsulating state is
11111 -- illegal (SPARK RM 7.1.4(9)).
11113 elsif Chars (Opt) = Name_Part_Of then
11115 ("indicator Part_Of must denote abstract state, "
11116 & "single protected type or single task type",
11119 -- Do not emit an error message when a previous state
11120 -- declaration with options was not parenthesized as
11121 -- the option is actually another state declaration.
11123 -- with Abstract_State
11124 -- (State_1 with ..., -- missing parentheses
11125 -- (State_2 with ...),
11126 -- State_3) -- ok state declaration
11128 elsif Missing_Parentheses then
11131 -- Otherwise the option is not allowed. Note that it
11132 -- is not possible to distinguish between an option
11133 -- and a state declaration when a previous state with
11134 -- options not properly parentheses.
11136 -- with Abstract_State
11137 -- (State_1 with ..., -- missing parentheses
11138 -- State_2); -- could be an option
11142 ("simple option not allowed in state declaration",
11146 -- Catch a case where missing parentheses around a state
11147 -- declaration with options cause a subsequent state
11148 -- declaration with options to be treated as an option.
11150 -- with Abstract_State
11151 -- (State_1 with ..., -- missing parentheses
11152 -- (State_2 with ...))
11154 elsif Nkind (Opt) = N_Extension_Aggregate then
11155 Missing_Parentheses := True;
11157 ("state declaration must be parenthesized",
11158 Ancestor_Part (State));
11160 -- Otherwise the option is malformed
11163 SPARK_Msg_N ("malformed option", Opt);
11169 -- Options External and Part_Of appear as component
11172 Opt := First (Component_Associations (State));
11173 while Present (Opt) loop
11174 Opt_Nam := First (Choices (Opt));
11176 if Nkind (Opt_Nam) = N_Identifier then
11177 if Chars (Opt_Nam) = Name_External then
11178 Analyze_External_Option (Opt);
11180 elsif Chars (Opt_Nam) = Name_Part_Of then
11181 Analyze_Part_Of_Option (Opt);
11184 SPARK_Msg_N ("invalid state option", Opt);
11187 SPARK_Msg_N ("invalid state option", Opt);
11193 -- Any other attempt to declare a state is illegal
11196 Malformed_State_Error (State);
11200 -- Guard against a junk state. In such cases no entity is
11201 -- generated and the subsequent checks cannot be applied.
11203 if Present (State_Id) then
11205 -- Verify whether the state does not introduce an illegal
11206 -- hidden state within a package subject to a null abstract
11209 Check_No_Hidden_State (State_Id);
11211 -- Check whether the lack of option Part_Of agrees with the
11212 -- placement of the abstract state with respect to the state
11215 if not Part_Of_Seen then
11216 Check_Missing_Part_Of (State_Id);
11219 -- Associate the state with its related package
11221 if No (Abstract_States (Pack_Id)) then
11222 Set_Abstract_States (Pack_Id, New_Elmt_List);
11225 Append_Elmt (State_Id, Abstract_States (Pack_Id));
11227 end Analyze_Abstract_State;
11229 ---------------------------
11230 -- Malformed_State_Error --
11231 ---------------------------
11233 procedure Malformed_State_Error (State : Node_Id) is
11235 Error_Msg_N ("malformed abstract state declaration", State);
11237 -- An abstract state with a simple option is being declared
11238 -- with "=>" rather than the legal "with". The state appears
11239 -- as a component association.
11241 if Nkind (State) = N_Component_Association then
11242 Error_Msg_N ("\use WITH to specify simple option", State);
11244 end Malformed_State_Error;
11248 Pack_Decl : Node_Id;
11249 Pack_Id : Entity_Id;
11253 -- Start of processing for Abstract_State
11257 Check_No_Identifiers;
11258 Check_Arg_Count (1);
11260 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
11262 -- Ensure the proper placement of the pragma. Abstract states must
11263 -- be associated with a package declaration.
11265 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
11266 N_Package_Declaration)
11270 -- Otherwise the pragma is associated with an illegal construct
11277 Pack_Id := Defining_Entity (Pack_Decl);
11279 -- Chain the pragma on the contract for completeness
11281 Add_Contract_Item (N, Pack_Id);
11283 -- The legality checks of pragmas Abstract_State, Initializes, and
11284 -- Initial_Condition are affected by the SPARK mode in effect. In
11285 -- addition, these three pragmas are subject to an inherent order:
11287 -- 1) Abstract_State
11289 -- 3) Initial_Condition
11291 -- Analyze all these pragmas in the order outlined above
11293 Analyze_If_Present (Pragma_SPARK_Mode);
11295 -- A pragma that applies to a Ghost entity becomes Ghost for the
11296 -- purposes of legality checks and removal of ignored Ghost code.
11298 Mark_Pragma_As_Ghost (N, Pack_Id);
11299 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
11301 States := Expression (Get_Argument (N, Pack_Id));
11303 -- Multiple non-null abstract states appear as an aggregate
11305 if Nkind (States) = N_Aggregate then
11306 State := First (Expressions (States));
11307 while Present (State) loop
11308 Analyze_Abstract_State (State, Pack_Id);
11312 -- An abstract state with a simple option is being illegaly
11313 -- declared with "=>" rather than "with". In this case the
11314 -- state declaration appears as a component association.
11316 if Present (Component_Associations (States)) then
11317 State := First (Component_Associations (States));
11318 while Present (State) loop
11319 Malformed_State_Error (State);
11324 -- Various forms of a single abstract state. Note that these may
11325 -- include malformed state declarations.
11328 Analyze_Abstract_State (States, Pack_Id);
11331 Analyze_If_Present (Pragma_Initializes);
11332 Analyze_If_Present (Pragma_Initial_Condition);
11333 end Abstract_State;
11341 -- Note: this pragma also has some specific processing in Par.Prag
11342 -- because we want to set the Ada version mode during parsing.
11344 when Pragma_Ada_83 =>
11346 Check_Arg_Count (0);
11348 -- We really should check unconditionally for proper configuration
11349 -- pragma placement, since we really don't want mixed Ada modes
11350 -- within a single unit, and the GNAT reference manual has always
11351 -- said this was a configuration pragma, but we did not check and
11352 -- are hesitant to add the check now.
11354 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11355 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11356 -- or Ada 2012 mode.
11358 if Ada_Version >= Ada_2005 then
11359 Check_Valid_Configuration_Pragma;
11362 -- Now set Ada 83 mode
11364 if not Latest_Ada_Only then
11365 Ada_Version := Ada_83;
11366 Ada_Version_Explicit := Ada_83;
11367 Ada_Version_Pragma := N;
11376 -- Note: this pragma also has some specific processing in Par.Prag
11377 -- because we want to set the Ada 83 version mode during parsing.
11379 when Pragma_Ada_95 =>
11381 Check_Arg_Count (0);
11383 -- We really should check unconditionally for proper configuration
11384 -- pragma placement, since we really don't want mixed Ada modes
11385 -- within a single unit, and the GNAT reference manual has always
11386 -- said this was a configuration pragma, but we did not check and
11387 -- are hesitant to add the check now.
11389 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11390 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11392 if Ada_Version >= Ada_2005 then
11393 Check_Valid_Configuration_Pragma;
11396 -- Now set Ada 95 mode
11398 if not Latest_Ada_Only then
11399 Ada_Version := Ada_95;
11400 Ada_Version_Explicit := Ada_95;
11401 Ada_Version_Pragma := N;
11404 ---------------------
11405 -- Ada_05/Ada_2005 --
11406 ---------------------
11409 -- pragma Ada_05 (LOCAL_NAME);
11411 -- pragma Ada_2005;
11412 -- pragma Ada_2005 (LOCAL_NAME):
11414 -- Note: these pragmas also have some specific processing in Par.Prag
11415 -- because we want to set the Ada 2005 version mode during parsing.
11417 -- The one argument form is used for managing the transition from
11418 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11419 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11420 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11421 -- mode, a preference rule is established which does not choose
11422 -- such an entity unless it is unambiguously specified. This avoids
11423 -- extra subprograms marked this way from generating ambiguities in
11424 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11425 -- intended for exclusive use in the GNAT run-time library.
11427 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
11433 if Arg_Count = 1 then
11434 Check_Arg_Is_Local_Name (Arg1);
11435 E_Id := Get_Pragma_Arg (Arg1);
11437 if Etype (E_Id) = Any_Type then
11441 Set_Is_Ada_2005_Only (Entity (E_Id));
11442 Record_Rep_Item (Entity (E_Id), N);
11445 Check_Arg_Count (0);
11447 -- For Ada_2005 we unconditionally enforce the documented
11448 -- configuration pragma placement, since we do not want to
11449 -- tolerate mixed modes in a unit involving Ada 2005. That
11450 -- would cause real difficulties for those cases where there
11451 -- are incompatibilities between Ada 95 and Ada 2005.
11453 Check_Valid_Configuration_Pragma;
11455 -- Now set appropriate Ada mode
11457 if not Latest_Ada_Only then
11458 Ada_Version := Ada_2005;
11459 Ada_Version_Explicit := Ada_2005;
11460 Ada_Version_Pragma := N;
11465 ---------------------
11466 -- Ada_12/Ada_2012 --
11467 ---------------------
11470 -- pragma Ada_12 (LOCAL_NAME);
11472 -- pragma Ada_2012;
11473 -- pragma Ada_2012 (LOCAL_NAME):
11475 -- Note: these pragmas also have some specific processing in Par.Prag
11476 -- because we want to set the Ada 2012 version mode during parsing.
11478 -- The one argument form is used for managing the transition from Ada
11479 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11480 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11481 -- mode will generate a warning. In addition, in any pre-Ada_2012
11482 -- mode, a preference rule is established which does not choose
11483 -- such an entity unless it is unambiguously specified. This avoids
11484 -- extra subprograms marked this way from generating ambiguities in
11485 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11486 -- intended for exclusive use in the GNAT run-time library.
11488 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11494 if Arg_Count = 1 then
11495 Check_Arg_Is_Local_Name (Arg1);
11496 E_Id := Get_Pragma_Arg (Arg1);
11498 if Etype (E_Id) = Any_Type then
11502 Set_Is_Ada_2012_Only (Entity (E_Id));
11503 Record_Rep_Item (Entity (E_Id), N);
11506 Check_Arg_Count (0);
11508 -- For Ada_2012 we unconditionally enforce the documented
11509 -- configuration pragma placement, since we do not want to
11510 -- tolerate mixed modes in a unit involving Ada 2012. That
11511 -- would cause real difficulties for those cases where there
11512 -- are incompatibilities between Ada 95 and Ada 2012. We could
11513 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11515 Check_Valid_Configuration_Pragma;
11517 -- Now set appropriate Ada mode
11519 Ada_Version := Ada_2012;
11520 Ada_Version_Explicit := Ada_2012;
11521 Ada_Version_Pragma := N;
11525 ----------------------
11526 -- All_Calls_Remote --
11527 ----------------------
11529 -- pragma All_Calls_Remote [(library_package_NAME)];
11531 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11532 Lib_Entity : Entity_Id;
11535 Check_Ada_83_Warning;
11536 Check_Valid_Library_Unit_Pragma;
11538 if Nkind (N) = N_Null_Statement then
11542 Lib_Entity := Find_Lib_Unit_Name;
11544 -- A pragma that applies to a Ghost entity becomes Ghost for the
11545 -- purposes of legality checks and removal of ignored Ghost code.
11547 Mark_Pragma_As_Ghost (N, Lib_Entity);
11549 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11551 if Present (Lib_Entity) and then not Debug_Flag_U then
11552 if not Is_Remote_Call_Interface (Lib_Entity) then
11553 Error_Pragma ("pragma% only apply to rci unit");
11555 -- Set flag for entity of the library unit
11558 Set_Has_All_Calls_Remote (Lib_Entity);
11561 end All_Calls_Remote;
11563 ---------------------------
11564 -- Allow_Integer_Address --
11565 ---------------------------
11567 -- pragma Allow_Integer_Address;
11569 when Pragma_Allow_Integer_Address =>
11571 Check_Valid_Configuration_Pragma;
11572 Check_Arg_Count (0);
11574 -- If Address is a private type, then set the flag to allow
11575 -- integer address values. If Address is not private, then this
11576 -- pragma has no purpose, so it is simply ignored. Not clear if
11577 -- there are any such targets now.
11579 if Opt.Address_Is_Private then
11580 Opt.Allow_Integer_Address := True;
11588 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11589 -- ARG ::= NAME | EXPRESSION
11591 -- The first two arguments are by convention intended to refer to an
11592 -- external tool and a tool-specific function. These arguments are
11595 when Pragma_Annotate => Annotate : declare
11602 Check_At_Least_N_Arguments (1);
11604 Nam_Arg := Last (Pragma_Argument_Associations (N));
11606 -- Determine whether the last argument is "Entity => local_NAME"
11607 -- and if it is, perform the required semantic checks. Remove the
11608 -- argument from further processing.
11610 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11611 and then Chars (Nam_Arg) = Name_Entity
11613 Check_Arg_Is_Local_Name (Nam_Arg);
11614 Arg_Count := Arg_Count - 1;
11616 -- A pragma that applies to a Ghost entity becomes Ghost for
11617 -- the purposes of legality checks and removal of ignored Ghost
11620 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11621 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11623 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11626 -- Not allowed in compiler units (bootstrap issues)
11628 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11631 -- Continue the processing with last argument removed for now
11633 Check_Arg_Is_Identifier (Arg1);
11634 Check_No_Identifiers;
11637 -- The second parameter is optional, it is never analyzed
11642 -- Otherwise there is a second parameter
11645 -- The second parameter must be an identifier
11647 Check_Arg_Is_Identifier (Arg2);
11649 -- Process the remaining parameters (if any)
11651 Arg := Next (Arg2);
11652 while Present (Arg) loop
11653 Expr := Get_Pragma_Arg (Arg);
11656 if Is_Entity_Name (Expr) then
11659 -- For string literals, we assume Standard_String as the
11660 -- type, unless the string contains wide or wide_wide
11663 elsif Nkind (Expr) = N_String_Literal then
11664 if Has_Wide_Wide_Character (Expr) then
11665 Resolve (Expr, Standard_Wide_Wide_String);
11666 elsif Has_Wide_Character (Expr) then
11667 Resolve (Expr, Standard_Wide_String);
11669 Resolve (Expr, Standard_String);
11672 elsif Is_Overloaded (Expr) then
11673 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11684 -------------------------------------------------
11685 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11686 -------------------------------------------------
11689 -- ( [Check => ] Boolean_EXPRESSION
11690 -- [, [Message =>] Static_String_EXPRESSION]);
11692 -- pragma Assert_And_Cut
11693 -- ( [Check => ] Boolean_EXPRESSION
11694 -- [, [Message =>] Static_String_EXPRESSION]);
11697 -- ( [Check => ] Boolean_EXPRESSION
11698 -- [, [Message =>] Static_String_EXPRESSION]);
11700 -- pragma Loop_Invariant
11701 -- ( [Check => ] Boolean_EXPRESSION
11702 -- [, [Message =>] Static_String_EXPRESSION]);
11704 when Pragma_Assert |
11705 Pragma_Assert_And_Cut |
11707 Pragma_Loop_Invariant =>
11709 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11710 -- Determine whether expression Expr contains a Loop_Entry
11711 -- attribute reference.
11713 -------------------------
11714 -- Contains_Loop_Entry --
11715 -------------------------
11717 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11718 Has_Loop_Entry : Boolean := False;
11720 function Process (N : Node_Id) return Traverse_Result;
11721 -- Process function for traversal to look for Loop_Entry
11727 function Process (N : Node_Id) return Traverse_Result is
11729 if Nkind (N) = N_Attribute_Reference
11730 and then Attribute_Name (N) = Name_Loop_Entry
11732 Has_Loop_Entry := True;
11739 procedure Traverse is new Traverse_Proc (Process);
11741 -- Start of processing for Contains_Loop_Entry
11745 return Has_Loop_Entry;
11746 end Contains_Loop_Entry;
11751 New_Args : List_Id;
11753 -- Start of processing for Assert
11756 -- Assert is an Ada 2005 RM-defined pragma
11758 if Prag_Id = Pragma_Assert then
11761 -- The remaining ones are GNAT pragmas
11767 Check_At_Least_N_Arguments (1);
11768 Check_At_Most_N_Arguments (2);
11769 Check_Arg_Order ((Name_Check, Name_Message));
11770 Check_Optional_Identifier (Arg1, Name_Check);
11771 Expr := Get_Pragma_Arg (Arg1);
11773 -- Special processing for Loop_Invariant, Loop_Variant or for
11774 -- other cases where a Loop_Entry attribute is present. If the
11775 -- assertion pragma contains attribute Loop_Entry, ensure that
11776 -- the related pragma is within a loop.
11778 if Prag_Id = Pragma_Loop_Invariant
11779 or else Prag_Id = Pragma_Loop_Variant
11780 or else Contains_Loop_Entry (Expr)
11782 Check_Loop_Pragma_Placement;
11784 -- Perform preanalysis to deal with embedded Loop_Entry
11787 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11790 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11791 -- a corresponding Check pragma:
11793 -- pragma Check (name, condition [, msg]);
11795 -- Where name is the identifier matching the pragma name. So
11796 -- rewrite pragma in this manner, transfer the message argument
11797 -- if present, and analyze the result
11799 -- Note: When dealing with a semantically analyzed tree, the
11800 -- information that a Check node N corresponds to a source Assert,
11801 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11802 -- pragma kind of Original_Node(N).
11804 New_Args := New_List (
11805 Make_Pragma_Argument_Association (Loc,
11806 Expression => Make_Identifier (Loc, Pname)),
11807 Make_Pragma_Argument_Association (Sloc (Expr),
11808 Expression => Expr));
11810 if Arg_Count > 1 then
11811 Check_Optional_Identifier (Arg2, Name_Message);
11813 -- Provide semantic annnotations for optional argument, for
11814 -- ASIS use, before rewriting.
11816 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11817 Append_To (New_Args, New_Copy_Tree (Arg2));
11820 -- Rewrite as Check pragma
11824 Chars => Name_Check,
11825 Pragma_Argument_Associations => New_Args));
11830 ----------------------
11831 -- Assertion_Policy --
11832 ----------------------
11834 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11836 -- The following form is Ada 2012 only, but we allow it in all modes
11838 -- Pragma Assertion_Policy (
11839 -- ASSERTION_KIND => POLICY_IDENTIFIER
11840 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11842 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11844 -- RM_ASSERTION_KIND ::= Assert |
11845 -- Static_Predicate |
11846 -- Dynamic_Predicate |
11851 -- Type_Invariant |
11852 -- Type_Invariant'Class
11854 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11856 -- Contract_Cases |
11858 -- Default_Initial_Condition |
11860 -- Initial_Condition |
11861 -- Loop_Invariant |
11867 -- Statement_Assertions
11869 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11870 -- ID_ASSERTION_KIND list contains implementation-defined additions
11871 -- recognized by GNAT. The effect is to control the behavior of
11872 -- identically named aspects and pragmas, depending on the specified
11873 -- policy identifier:
11875 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11877 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11878 -- implementation-defined addition that results in totally ignoring
11879 -- the corresponding assertion. If Disable is specified, then the
11880 -- argument of the assertion is not even analyzed. This is useful
11881 -- when the aspect/pragma argument references entities in a with'ed
11882 -- package that is replaced by a dummy package in the final build.
11884 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11885 -- and Type_Invariant'Class were recognized by the parser and
11886 -- transformed into references to the special internal identifiers
11887 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11888 -- processing is required here.
11890 when Pragma_Assertion_Policy => Assertion_Policy : declare
11899 -- This can always appear as a configuration pragma
11901 if Is_Configuration_Pragma then
11904 -- It can also appear in a declarative part or package spec in Ada
11905 -- 2012 mode. We allow this in other modes, but in that case we
11906 -- consider that we have an Ada 2012 pragma on our hands.
11909 Check_Is_In_Decl_Part_Or_Package_Spec;
11913 -- One argument case with no identifier (first form above)
11916 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11917 or else Chars (Arg1) = No_Name)
11919 Check_Arg_Is_One_Of
11920 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11922 -- Treat one argument Assertion_Policy as equivalent to:
11924 -- pragma Check_Policy (Assertion, policy)
11926 -- So rewrite pragma in that manner and link on to the chain
11927 -- of Check_Policy pragmas, marking the pragma as analyzed.
11929 Policy := Get_Pragma_Arg (Arg1);
11933 Chars => Name_Check_Policy,
11934 Pragma_Argument_Associations => New_List (
11935 Make_Pragma_Argument_Association (Loc,
11936 Expression => Make_Identifier (Loc, Name_Assertion)),
11938 Make_Pragma_Argument_Association (Loc,
11940 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11943 -- Here if we have two or more arguments
11946 Check_At_Least_N_Arguments (1);
11949 -- Loop through arguments
11952 while Present (Arg) loop
11953 LocP := Sloc (Arg);
11955 -- Kind must be specified
11957 if Nkind (Arg) /= N_Pragma_Argument_Association
11958 or else Chars (Arg) = No_Name
11961 ("missing assertion kind for pragma%", Arg);
11964 -- Check Kind and Policy have allowed forms
11966 Kind := Chars (Arg);
11967 Policy := Get_Pragma_Arg (Arg);
11969 if not Is_Valid_Assertion_Kind (Kind) then
11971 ("invalid assertion kind for pragma%", Arg);
11974 Check_Arg_Is_One_Of
11975 (Arg, Name_Check, Name_Disable, Name_Ignore);
11977 if Kind = Name_Ghost then
11979 -- The Ghost policy must be either Check or Ignore
11980 -- (SPARK RM 6.9(6)).
11982 if not Nam_In (Chars (Policy), Name_Check,
11986 ("argument of pragma % Ghost must be Check or "
11987 & "Ignore", Policy);
11990 -- Pragma Assertion_Policy specifying a Ghost policy
11991 -- cannot occur within a Ghost subprogram or package
11992 -- (SPARK RM 6.9(14)).
11994 if Ghost_Mode > None then
11996 ("pragma % cannot appear within ghost subprogram or "
12001 -- Rewrite the Assertion_Policy pragma as a series of
12002 -- Check_Policy pragmas of the form:
12004 -- Check_Policy (Kind, Policy);
12006 -- Note: the insertion of the pragmas cannot be done with
12007 -- Insert_Action because in the configuration case, there
12008 -- are no scopes on the scope stack and the mechanism will
12011 Insert_Before_And_Analyze (N,
12013 Chars => Name_Check_Policy,
12014 Pragma_Argument_Associations => New_List (
12015 Make_Pragma_Argument_Association (LocP,
12016 Expression => Make_Identifier (LocP, Kind)),
12017 Make_Pragma_Argument_Association (LocP,
12018 Expression => Policy))));
12023 -- Rewrite the Assertion_Policy pragma as null since we have
12024 -- now inserted all the equivalent Check pragmas.
12026 Rewrite (N, Make_Null_Statement (Loc));
12029 end Assertion_Policy;
12031 ------------------------------
12032 -- Assume_No_Invalid_Values --
12033 ------------------------------
12035 -- pragma Assume_No_Invalid_Values (On | Off);
12037 when Pragma_Assume_No_Invalid_Values =>
12039 Check_Valid_Configuration_Pragma;
12040 Check_Arg_Count (1);
12041 Check_No_Identifiers;
12042 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12044 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12045 Assume_No_Invalid_Values := True;
12047 Assume_No_Invalid_Values := False;
12050 --------------------------
12051 -- Attribute_Definition --
12052 --------------------------
12054 -- pragma Attribute_Definition
12055 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12056 -- [Entity =>] LOCAL_NAME,
12057 -- [Expression =>] EXPRESSION | NAME);
12059 when Pragma_Attribute_Definition => Attribute_Definition : declare
12060 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
12065 Check_Arg_Count (3);
12066 Check_Optional_Identifier (Arg1, "attribute");
12067 Check_Optional_Identifier (Arg2, "entity");
12068 Check_Optional_Identifier (Arg3, "expression");
12070 if Nkind (Attribute_Designator) /= N_Identifier then
12071 Error_Msg_N ("attribute name expected", Attribute_Designator);
12075 Check_Arg_Is_Local_Name (Arg2);
12077 -- If the attribute is not recognized, then issue a warning (not
12078 -- an error), and ignore the pragma.
12080 Aname := Chars (Attribute_Designator);
12082 if not Is_Attribute_Name (Aname) then
12083 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
12087 -- Otherwise, rewrite the pragma as an attribute definition clause
12090 Make_Attribute_Definition_Clause (Loc,
12091 Name => Get_Pragma_Arg (Arg2),
12093 Expression => Get_Pragma_Arg (Arg3)));
12095 end Attribute_Definition;
12097 ------------------------------------------------------------------
12098 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12099 ------------------------------------------------------------------
12101 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12102 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12103 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12104 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12106 when Pragma_Async_Readers |
12107 Pragma_Async_Writers |
12108 Pragma_Effective_Reads |
12109 Pragma_Effective_Writes =>
12110 Async_Effective : declare
12111 Obj_Decl : Node_Id;
12112 Obj_Id : Entity_Id;
12116 Check_No_Identifiers;
12117 Check_At_Most_N_Arguments (1);
12119 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12121 -- Object declaration
12123 if Nkind (Obj_Decl) = N_Object_Declaration then
12126 -- Otherwise the pragma is associated with an illegal construact
12133 Obj_Id := Defining_Entity (Obj_Decl);
12135 -- Perform minimal verification to ensure that the argument is at
12136 -- least a variable. Subsequent finer grained checks will be done
12137 -- at the end of the declarative region the contains the pragma.
12139 if Ekind (Obj_Id) = E_Variable then
12141 -- Chain the pragma on the contract for further processing by
12142 -- Analyze_External_Property_In_Decl_Part.
12144 Add_Contract_Item (N, Obj_Id);
12146 -- A pragma that applies to a Ghost entity becomes Ghost for
12147 -- the purposes of legality checks and removal of ignored Ghost
12150 Mark_Pragma_As_Ghost (N, Obj_Id);
12152 -- Analyze the Boolean expression (if any)
12154 if Present (Arg1) then
12155 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12158 -- Otherwise the external property applies to a constant
12161 Error_Pragma ("pragma % must apply to a volatile object");
12163 end Async_Effective;
12169 -- pragma Asynchronous (LOCAL_NAME);
12171 when Pragma_Asynchronous => Asynchronous : declare
12174 Formal : Entity_Id;
12179 procedure Process_Async_Pragma;
12180 -- Common processing for procedure and access-to-procedure case
12182 --------------------------
12183 -- Process_Async_Pragma --
12184 --------------------------
12186 procedure Process_Async_Pragma is
12189 Set_Is_Asynchronous (Nm);
12193 -- The formals should be of mode IN (RM E.4.1(6))
12196 while Present (S) loop
12197 Formal := Defining_Identifier (S);
12199 if Nkind (Formal) = N_Defining_Identifier
12200 and then Ekind (Formal) /= E_In_Parameter
12203 ("pragma% procedure can only have IN parameter",
12210 Set_Is_Asynchronous (Nm);
12211 end Process_Async_Pragma;
12213 -- Start of processing for pragma Asynchronous
12216 Check_Ada_83_Warning;
12217 Check_No_Identifiers;
12218 Check_Arg_Count (1);
12219 Check_Arg_Is_Local_Name (Arg1);
12221 if Debug_Flag_U then
12225 C_Ent := Cunit_Entity (Current_Sem_Unit);
12226 Analyze (Get_Pragma_Arg (Arg1));
12227 Nm := Entity (Get_Pragma_Arg (Arg1));
12229 -- A pragma that applies to a Ghost entity becomes Ghost for the
12230 -- purposes of legality checks and removal of ignored Ghost code.
12232 Mark_Pragma_As_Ghost (N, Nm);
12234 if not Is_Remote_Call_Interface (C_Ent)
12235 and then not Is_Remote_Types (C_Ent)
12237 -- This pragma should only appear in an RCI or Remote Types
12238 -- unit (RM E.4.1(4)).
12241 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12244 if Ekind (Nm) = E_Procedure
12245 and then Nkind (Parent (Nm)) = N_Procedure_Specification
12247 if not Is_Remote_Call_Interface (Nm) then
12249 ("pragma% cannot be applied on non-remote procedure",
12253 L := Parameter_Specifications (Parent (Nm));
12254 Process_Async_Pragma;
12257 elsif Ekind (Nm) = E_Function then
12259 ("pragma% cannot be applied to function", Arg1);
12261 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
12262 if Is_Record_Type (Nm) then
12264 -- A record type that is the Equivalent_Type for a remote
12265 -- access-to-subprogram type.
12267 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
12270 -- A non-expanded RAS type (distribution is not enabled)
12272 Decl := Declaration_Node (Nm);
12275 if Nkind (Decl) = N_Full_Type_Declaration
12276 and then Nkind (Type_Definition (Decl)) =
12277 N_Access_Procedure_Definition
12279 L := Parameter_Specifications (Type_Definition (Decl));
12280 Process_Async_Pragma;
12282 if Is_Asynchronous (Nm)
12283 and then Expander_Active
12284 and then Get_PCS_Name /= Name_No_DSA
12286 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
12291 ("pragma% cannot reference access-to-function type",
12295 -- Only other possibility is Access-to-class-wide type
12297 elsif Is_Access_Type (Nm)
12298 and then Is_Class_Wide_Type (Designated_Type (Nm))
12300 Check_First_Subtype (Arg1);
12301 Set_Is_Asynchronous (Nm);
12302 if Expander_Active then
12303 RACW_Type_Is_Asynchronous (Nm);
12307 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12315 -- pragma Atomic (LOCAL_NAME);
12317 when Pragma_Atomic =>
12318 Process_Atomic_Independent_Shared_Volatile;
12320 -----------------------
12321 -- Atomic_Components --
12322 -----------------------
12324 -- pragma Atomic_Components (array_LOCAL_NAME);
12326 -- This processing is shared by Volatile_Components
12328 when Pragma_Atomic_Components |
12329 Pragma_Volatile_Components =>
12330 Atomic_Components : declare
12337 Check_Ada_83_Warning;
12338 Check_No_Identifiers;
12339 Check_Arg_Count (1);
12340 Check_Arg_Is_Local_Name (Arg1);
12341 E_Id := Get_Pragma_Arg (Arg1);
12343 if Etype (E_Id) = Any_Type then
12347 E := Entity (E_Id);
12349 -- A pragma that applies to a Ghost entity becomes Ghost for the
12350 -- purposes of legality checks and removal of ignored Ghost code.
12352 Mark_Pragma_As_Ghost (N, E);
12353 Check_Duplicate_Pragma (E);
12355 if Rep_Item_Too_Early (E, N)
12357 Rep_Item_Too_Late (E, N)
12362 D := Declaration_Node (E);
12365 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12367 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12368 and then Nkind (D) = N_Object_Declaration
12369 and then Nkind (Object_Definition (D)) =
12370 N_Constrained_Array_Definition)
12372 -- The flag is set on the object, or on the base type
12374 if Nkind (D) /= N_Object_Declaration then
12375 E := Base_Type (E);
12378 -- Atomic implies both Independent and Volatile
12380 if Prag_Id = Pragma_Atomic_Components then
12381 Set_Has_Atomic_Components (E);
12382 Set_Has_Independent_Components (E);
12385 Set_Has_Volatile_Components (E);
12388 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12390 end Atomic_Components;
12392 --------------------
12393 -- Attach_Handler --
12394 --------------------
12396 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12398 when Pragma_Attach_Handler =>
12399 Check_Ada_83_Warning;
12400 Check_No_Identifiers;
12401 Check_Arg_Count (2);
12403 if No_Run_Time_Mode then
12404 Error_Msg_CRT ("Attach_Handler pragma", N);
12406 Check_Interrupt_Or_Attach_Handler;
12408 -- The expression that designates the attribute may depend on a
12409 -- discriminant, and is therefore a per-object expression, to
12410 -- be expanded in the init proc. If expansion is enabled, then
12411 -- perform semantic checks on a copy only.
12416 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12419 -- In Relaxed_RM_Semantics mode, we allow any static
12420 -- integer value, for compatibility with other compilers.
12422 if Relaxed_RM_Semantics
12423 and then Nkind (Parg2) = N_Integer_Literal
12425 Typ := Standard_Integer;
12427 Typ := RTE (RE_Interrupt_ID);
12430 if Expander_Active then
12431 Temp := New_Copy_Tree (Parg2);
12432 Set_Parent (Temp, N);
12433 Preanalyze_And_Resolve (Temp, Typ);
12436 Resolve (Parg2, Typ);
12440 Process_Interrupt_Or_Attach_Handler;
12443 --------------------
12444 -- C_Pass_By_Copy --
12445 --------------------
12447 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12449 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12455 Check_Valid_Configuration_Pragma;
12456 Check_Arg_Count (1);
12457 Check_Optional_Identifier (Arg1, "max_size");
12459 Arg := Get_Pragma_Arg (Arg1);
12460 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12462 Val := Expr_Value (Arg);
12466 ("maximum size for pragma% must be positive", Arg1);
12468 elsif UI_Is_In_Int_Range (Val) then
12469 Default_C_Record_Mechanism := UI_To_Int (Val);
12471 -- If a giant value is given, Int'Last will do well enough.
12472 -- If sometime someone complains that a record larger than
12473 -- two gigabytes is not copied, we will worry about it then.
12476 Default_C_Record_Mechanism := Mechanism_Type'Last;
12478 end C_Pass_By_Copy;
12484 -- pragma Check ([Name =>] CHECK_KIND,
12485 -- [Check =>] Boolean_EXPRESSION
12486 -- [,[Message =>] String_EXPRESSION]);
12488 -- CHECK_KIND ::= IDENTIFIER |
12491 -- Invariant'Class |
12492 -- Type_Invariant'Class
12494 -- The identifiers Assertions and Statement_Assertions are not
12495 -- allowed, since they have special meaning for Check_Policy.
12497 when Pragma_Check => Check : declare
12503 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
12506 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12507 -- the mode now to ensure that any nodes generated during analysis
12508 -- and expansion are marked as Ghost.
12510 Set_Ghost_Mode (N);
12513 Check_At_Least_N_Arguments (2);
12514 Check_At_Most_N_Arguments (3);
12515 Check_Optional_Identifier (Arg1, Name_Name);
12516 Check_Optional_Identifier (Arg2, Name_Check);
12518 if Arg_Count = 3 then
12519 Check_Optional_Identifier (Arg3, Name_Message);
12520 Str := Get_Pragma_Arg (Arg3);
12523 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12524 Check_Arg_Is_Identifier (Arg1);
12525 Cname := Chars (Get_Pragma_Arg (Arg1));
12527 -- Check forbidden name Assertions or Statement_Assertions
12530 when Name_Assertions =>
12532 ("""Assertions"" is not allowed as a check kind for "
12533 & "pragma%", Arg1);
12535 when Name_Statement_Assertions =>
12537 ("""Statement_Assertions"" is not allowed as a check kind "
12538 & "for pragma%", Arg1);
12544 -- Check applicable policy. We skip this if Checked/Ignored status
12545 -- is already set (e.g. in the case of a pragma from an aspect).
12547 if Is_Checked (N) or else Is_Ignored (N) then
12550 -- For a non-source pragma that is a rewriting of another pragma,
12551 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12553 elsif Is_Rewrite_Substitution (N)
12554 and then Nkind (Original_Node (N)) = N_Pragma
12555 and then Original_Node (N) /= N
12557 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12558 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12560 -- Otherwise query the applicable policy at this point
12563 case Check_Kind (Cname) is
12564 when Name_Ignore =>
12565 Set_Is_Ignored (N, True);
12566 Set_Is_Checked (N, False);
12569 Set_Is_Ignored (N, False);
12570 Set_Is_Checked (N, True);
12572 -- For disable, rewrite pragma as null statement and skip
12573 -- rest of the analysis of the pragma.
12575 when Name_Disable =>
12576 Rewrite (N, Make_Null_Statement (Loc));
12580 -- No other possibilities
12583 raise Program_Error;
12587 -- If check kind was not Disable, then continue pragma analysis
12589 Expr := Get_Pragma_Arg (Arg2);
12591 -- Deal with SCO generation
12595 -- Nothing to do for predicates as the checks occur in the
12596 -- client units. The SCO for the aspect in the declaration
12597 -- unit is conservatively always enabled.
12599 when Name_Predicate =>
12602 -- Otherwise mark aspect/pragma SCO as enabled
12605 if Is_Checked (N) and then not Split_PPC (N) then
12606 Set_SCO_Pragma_Enabled (Loc);
12610 -- Deal with analyzing the string argument
12612 if Arg_Count = 3 then
12614 -- If checks are not on we don't want any expansion (since
12615 -- such expansion would not get properly deleted) but
12616 -- we do want to analyze (to get proper references).
12617 -- The Preanalyze_And_Resolve routine does just what we want
12619 if Is_Ignored (N) then
12620 Preanalyze_And_Resolve (Str, Standard_String);
12622 -- Otherwise we need a proper analysis and expansion
12625 Analyze_And_Resolve (Str, Standard_String);
12629 -- Now you might think we could just do the same with the Boolean
12630 -- expression if checks are off (and expansion is on) and then
12631 -- rewrite the check as a null statement. This would work but we
12632 -- would lose the useful warnings about an assertion being bound
12633 -- to fail even if assertions are turned off.
12635 -- So instead we wrap the boolean expression in an if statement
12636 -- that looks like:
12638 -- if False and then condition then
12642 -- The reason we do this rewriting during semantic analysis rather
12643 -- than as part of normal expansion is that we cannot analyze and
12644 -- expand the code for the boolean expression directly, or it may
12645 -- cause insertion of actions that would escape the attempt to
12646 -- suppress the check code.
12648 -- Note that the Sloc for the if statement corresponds to the
12649 -- argument condition, not the pragma itself. The reason for
12650 -- this is that we may generate a warning if the condition is
12651 -- False at compile time, and we do not want to delete this
12652 -- warning when we delete the if statement.
12654 if Expander_Active and Is_Ignored (N) then
12655 Eloc := Sloc (Expr);
12658 Make_If_Statement (Eloc,
12660 Make_And_Then (Eloc,
12661 Left_Opnd => Make_Identifier (Eloc, Name_False),
12662 Right_Opnd => Expr),
12663 Then_Statements => New_List (
12664 Make_Null_Statement (Eloc))));
12666 -- Now go ahead and analyze the if statement
12668 In_Assertion_Expr := In_Assertion_Expr + 1;
12670 -- One rather special treatment. If we are now in Eliminated
12671 -- overflow mode, then suppress overflow checking since we do
12672 -- not want to drag in the bignum stuff if we are in Ignore
12673 -- mode anyway. This is particularly important if we are using
12674 -- a configurable run time that does not support bignum ops.
12676 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12678 Svo : constant Boolean :=
12679 Scope_Suppress.Suppress (Overflow_Check);
12681 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12682 Scope_Suppress.Suppress (Overflow_Check) := True;
12684 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12685 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12688 -- Not that special case
12694 -- All done with this check
12696 In_Assertion_Expr := In_Assertion_Expr - 1;
12698 -- Check is active or expansion not active. In these cases we can
12699 -- just go ahead and analyze the boolean with no worries.
12702 In_Assertion_Expr := In_Assertion_Expr + 1;
12703 Analyze_And_Resolve (Expr, Any_Boolean);
12704 In_Assertion_Expr := In_Assertion_Expr - 1;
12707 Ghost_Mode := Save_Ghost_Mode;
12710 --------------------------
12711 -- Check_Float_Overflow --
12712 --------------------------
12714 -- pragma Check_Float_Overflow;
12716 when Pragma_Check_Float_Overflow =>
12718 Check_Valid_Configuration_Pragma;
12719 Check_Arg_Count (0);
12720 Check_Float_Overflow := not Machine_Overflows_On_Target;
12726 -- pragma Check_Name (check_IDENTIFIER);
12728 when Pragma_Check_Name =>
12730 Check_No_Identifiers;
12731 Check_Valid_Configuration_Pragma;
12732 Check_Arg_Count (1);
12733 Check_Arg_Is_Identifier (Arg1);
12736 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12739 for J in Check_Names.First .. Check_Names.Last loop
12740 if Check_Names.Table (J) = Nam then
12745 Check_Names.Append (Nam);
12752 -- This is the old style syntax, which is still allowed in all modes:
12754 -- pragma Check_Policy ([Name =>] CHECK_KIND
12755 -- [Policy =>] POLICY_IDENTIFIER);
12757 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12759 -- CHECK_KIND ::= IDENTIFIER |
12762 -- Type_Invariant'Class |
12765 -- This is the new style syntax, compatible with Assertion_Policy
12766 -- and also allowed in all modes.
12768 -- Pragma Check_Policy (
12769 -- CHECK_KIND => POLICY_IDENTIFIER
12770 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12772 -- Note: the identifiers Name and Policy are not allowed as
12773 -- Check_Kind values. This avoids ambiguities between the old and
12774 -- new form syntax.
12776 when Pragma_Check_Policy => Check_Policy : declare
12781 Check_At_Least_N_Arguments (1);
12783 -- A Check_Policy pragma can appear either as a configuration
12784 -- pragma, or in a declarative part or a package spec (see RM
12785 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12786 -- followed for Check_Policy).
12788 if not Is_Configuration_Pragma then
12789 Check_Is_In_Decl_Part_Or_Package_Spec;
12792 -- Figure out if we have the old or new syntax. We have the
12793 -- old syntax if the first argument has no identifier, or the
12794 -- identifier is Name.
12796 if Nkind (Arg1) /= N_Pragma_Argument_Association
12797 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12801 Check_Arg_Count (2);
12802 Check_Optional_Identifier (Arg1, Name_Name);
12803 Kind := Get_Pragma_Arg (Arg1);
12804 Rewrite_Assertion_Kind (Kind);
12805 Check_Arg_Is_Identifier (Arg1);
12807 -- Check forbidden check kind
12809 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12810 Error_Msg_Name_2 := Chars (Kind);
12812 ("pragma% does not allow% as check name", Arg1);
12817 Check_Optional_Identifier (Arg2, Name_Policy);
12818 Check_Arg_Is_One_Of
12820 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12822 -- And chain pragma on the Check_Policy_List for search
12824 Set_Next_Pragma (N, Opt.Check_Policy_List);
12825 Opt.Check_Policy_List := N;
12827 -- For the new syntax, what we do is to convert each argument to
12828 -- an old syntax equivalent. We do that because we want to chain
12829 -- old style Check_Policy pragmas for the search (we don't want
12830 -- to have to deal with multiple arguments in the search).
12841 while Present (Arg) loop
12842 LocP := Sloc (Arg);
12843 Argx := Get_Pragma_Arg (Arg);
12845 -- Kind must be specified
12847 if Nkind (Arg) /= N_Pragma_Argument_Association
12848 or else Chars (Arg) = No_Name
12851 ("missing assertion kind for pragma%", Arg);
12854 -- Construct equivalent old form syntax Check_Policy
12855 -- pragma and insert it to get remaining checks.
12859 Chars => Name_Check_Policy,
12860 Pragma_Argument_Associations => New_List (
12861 Make_Pragma_Argument_Association (LocP,
12863 Make_Identifier (LocP, Chars (Arg))),
12864 Make_Pragma_Argument_Association (Sloc (Argx),
12865 Expression => Argx)));
12869 -- For a configuration pragma, insert old form in
12870 -- the corresponding file.
12872 if Is_Configuration_Pragma then
12873 Insert_After (N, New_P);
12877 Insert_Action (N, New_P);
12881 -- Rewrite original Check_Policy pragma to null, since we
12882 -- have converted it into a series of old syntax pragmas.
12884 Rewrite (N, Make_Null_Statement (Loc));
12894 -- pragma Comment (static_string_EXPRESSION)
12896 -- Processing for pragma Comment shares the circuitry for pragma
12897 -- Ident. The only differences are that Ident enforces a limit of 31
12898 -- characters on its argument, and also enforces limitations on
12899 -- placement for DEC compatibility. Pragma Comment shares neither of
12900 -- these restrictions.
12902 -------------------
12903 -- Common_Object --
12904 -------------------
12906 -- pragma Common_Object (
12907 -- [Internal =>] LOCAL_NAME
12908 -- [, [External =>] EXTERNAL_SYMBOL]
12909 -- [, [Size =>] EXTERNAL_SYMBOL]);
12911 -- Processing for this pragma is shared with Psect_Object
12913 ------------------------
12914 -- Compile_Time_Error --
12915 ------------------------
12917 -- pragma Compile_Time_Error
12918 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12920 when Pragma_Compile_Time_Error =>
12922 Process_Compile_Time_Warning_Or_Error;
12924 --------------------------
12925 -- Compile_Time_Warning --
12926 --------------------------
12928 -- pragma Compile_Time_Warning
12929 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12931 when Pragma_Compile_Time_Warning =>
12933 Process_Compile_Time_Warning_Or_Error;
12935 ---------------------------
12936 -- Compiler_Unit_Warning --
12937 ---------------------------
12939 -- pragma Compiler_Unit_Warning;
12943 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12944 -- errors not warnings. This means that we had introduced a big extra
12945 -- inertia to compiler changes, since even if we implemented a new
12946 -- feature, and even if all versions to be used for bootstrapping
12947 -- implemented this new feature, we could not use it, since old
12948 -- compilers would give errors for using this feature in units
12949 -- having Compiler_Unit pragmas.
12951 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12952 -- problem. We no longer have any units mentioning Compiler_Unit,
12953 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12954 -- and thus generates a warning which can be ignored. So that deals
12955 -- with the problem of old compilers not implementing the newer form
12958 -- Newer compilers recognize the new pragma, but generate warning
12959 -- messages instead of errors, which again can be ignored in the
12960 -- case of an old compiler which implements a wanted new feature
12961 -- but at the time felt like warning about it for older compilers.
12963 -- We retain Compiler_Unit so that new compilers can be used to build
12964 -- older run-times that use this pragma. That's an unusual case, but
12965 -- it's easy enough to handle, so why not?
12967 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12969 Check_Arg_Count (0);
12971 -- Only recognized in main unit
12973 if Current_Sem_Unit = Main_Unit then
12974 Compiler_Unit := True;
12977 -----------------------------
12978 -- Complete_Representation --
12979 -----------------------------
12981 -- pragma Complete_Representation;
12983 when Pragma_Complete_Representation =>
12985 Check_Arg_Count (0);
12987 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12989 ("pragma & must appear within record representation clause");
12992 ----------------------------
12993 -- Complex_Representation --
12994 ----------------------------
12996 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12998 when Pragma_Complex_Representation => Complex_Representation : declare
13005 Check_Arg_Count (1);
13006 Check_Optional_Identifier (Arg1, Name_Entity);
13007 Check_Arg_Is_Local_Name (Arg1);
13008 E_Id := Get_Pragma_Arg (Arg1);
13010 if Etype (E_Id) = Any_Type then
13014 E := Entity (E_Id);
13016 if not Is_Record_Type (E) then
13018 ("argument for pragma% must be record type", Arg1);
13021 Ent := First_Entity (E);
13024 or else No (Next_Entity (Ent))
13025 or else Present (Next_Entity (Next_Entity (Ent)))
13026 or else not Is_Floating_Point_Type (Etype (Ent))
13027 or else Etype (Ent) /= Etype (Next_Entity (Ent))
13030 ("record for pragma% must have two fields of the same "
13031 & "floating-point type", Arg1);
13034 Set_Has_Complex_Representation (Base_Type (E));
13036 -- We need to treat the type has having a non-standard
13037 -- representation, for back-end purposes, even though in
13038 -- general a complex will have the default representation
13039 -- of a record with two real components.
13041 Set_Has_Non_Standard_Rep (Base_Type (E));
13043 end Complex_Representation;
13045 -------------------------
13046 -- Component_Alignment --
13047 -------------------------
13049 -- pragma Component_Alignment (
13050 -- [Form =>] ALIGNMENT_CHOICE
13051 -- [, [Name =>] type_LOCAL_NAME]);
13053 -- ALIGNMENT_CHOICE ::=
13055 -- | Component_Size_4
13059 when Pragma_Component_Alignment => Component_AlignmentP : declare
13060 Args : Args_List (1 .. 2);
13061 Names : constant Name_List (1 .. 2) := (
13065 Form : Node_Id renames Args (1);
13066 Name : Node_Id renames Args (2);
13068 Atype : Component_Alignment_Kind;
13073 Gather_Associations (Names, Args);
13076 Error_Pragma ("missing Form argument for pragma%");
13079 Check_Arg_Is_Identifier (Form);
13081 -- Get proper alignment, note that Default = Component_Size on all
13082 -- machines we have so far, and we want to set this value rather
13083 -- than the default value to indicate that it has been explicitly
13084 -- set (and thus will not get overridden by the default component
13085 -- alignment for the current scope)
13087 if Chars (Form) = Name_Component_Size then
13088 Atype := Calign_Component_Size;
13090 elsif Chars (Form) = Name_Component_Size_4 then
13091 Atype := Calign_Component_Size_4;
13093 elsif Chars (Form) = Name_Default then
13094 Atype := Calign_Component_Size;
13096 elsif Chars (Form) = Name_Storage_Unit then
13097 Atype := Calign_Storage_Unit;
13101 ("invalid Form parameter for pragma%", Form);
13104 -- The pragma appears in a configuration file
13106 if No (Parent (N)) then
13107 Check_Valid_Configuration_Pragma;
13109 -- Capture the component alignment in a global variable when
13110 -- the pragma appears in a configuration file. Note that the
13111 -- scope stack is empty at this point and cannot be used to
13112 -- store the alignment value.
13114 Configuration_Component_Alignment := Atype;
13116 -- Case with no name, supplied, affects scope table entry
13118 elsif No (Name) then
13120 (Scope_Stack.Last).Component_Alignment_Default := Atype;
13122 -- Case of name supplied
13125 Check_Arg_Is_Local_Name (Name);
13127 Typ := Entity (Name);
13130 or else Rep_Item_Too_Early (Typ, N)
13134 Typ := Underlying_Type (Typ);
13137 if not Is_Record_Type (Typ)
13138 and then not Is_Array_Type (Typ)
13141 ("Name parameter of pragma% must identify record or "
13142 & "array type", Name);
13145 -- An explicit Component_Alignment pragma overrides an
13146 -- implicit pragma Pack, but not an explicit one.
13148 if not Has_Pragma_Pack (Base_Type (Typ)) then
13149 Set_Is_Packed (Base_Type (Typ), False);
13150 Set_Component_Alignment (Base_Type (Typ), Atype);
13153 end Component_AlignmentP;
13155 --------------------------------
13156 -- Constant_After_Elaboration --
13157 --------------------------------
13159 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13161 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
13163 Obj_Decl : Node_Id;
13164 Obj_Id : Entity_Id;
13168 Check_No_Identifiers;
13169 Check_At_Most_N_Arguments (1);
13171 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13173 -- Object declaration
13175 if Nkind (Obj_Decl) = N_Object_Declaration then
13178 -- Otherwise the pragma is associated with an illegal construct
13185 Obj_Id := Defining_Entity (Obj_Decl);
13187 -- The object declaration must be a library-level variable which
13188 -- is either explicitly initialized or obtains a value during the
13189 -- elaboration of a package body (SPARK RM 3.3.1).
13191 if Ekind (Obj_Id) = E_Variable then
13192 if not Is_Library_Level_Entity (Obj_Id) then
13194 ("pragma % must apply to a library level variable");
13198 -- Otherwise the pragma applies to a constant, which is illegal
13201 Error_Pragma ("pragma % must apply to a variable declaration");
13205 -- Chain the pragma on the contract for completeness
13207 Add_Contract_Item (N, Obj_Id);
13209 -- A pragma that applies to a Ghost entity becomes Ghost for the
13210 -- purposes of legality checks and removal of ignored Ghost code.
13212 Mark_Pragma_As_Ghost (N, Obj_Id);
13214 -- Analyze the Boolean expression (if any)
13216 if Present (Arg1) then
13217 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13219 end Constant_After_Elaboration;
13221 --------------------
13222 -- Contract_Cases --
13223 --------------------
13225 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13227 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13229 -- CASE_GUARD ::= boolean_EXPRESSION | others
13231 -- CONSEQUENCE ::= boolean_EXPRESSION
13233 -- Characteristics:
13235 -- * Analysis - The annotation undergoes initial checks to verify
13236 -- the legal placement and context. Secondary checks preanalyze the
13239 -- Analyze_Contract_Cases_In_Decl_Part
13241 -- * Expansion - The annotation is expanded during the expansion of
13242 -- the related subprogram [body] contract as performed in:
13244 -- Expand_Subprogram_Contract
13246 -- * Template - The annotation utilizes the generic template of the
13247 -- related subprogram [body] when it is:
13249 -- aspect on subprogram declaration
13250 -- aspect on stand alone subprogram body
13251 -- pragma on stand alone subprogram body
13253 -- The annotation must prepare its own template when it is:
13255 -- pragma on subprogram declaration
13257 -- * Globals - Capture of global references must occur after full
13260 -- * Instance - The annotation is instantiated automatically when
13261 -- the related generic subprogram [body] is instantiated except for
13262 -- the "pragma on subprogram declaration" case. In that scenario
13263 -- the annotation must instantiate itself.
13265 when Pragma_Contract_Cases => Contract_Cases : declare
13266 Spec_Id : Entity_Id;
13267 Subp_Decl : Node_Id;
13271 Check_No_Identifiers;
13272 Check_Arg_Count (1);
13274 -- Ensure the proper placement of the pragma. Contract_Cases must
13275 -- be associated with a subprogram declaration or a body that acts
13279 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13283 if Nkind (Subp_Decl) = N_Entry_Declaration then
13286 -- Generic subprogram
13288 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13291 -- Body acts as spec
13293 elsif Nkind (Subp_Decl) = N_Subprogram_Body
13294 and then No (Corresponding_Spec (Subp_Decl))
13298 -- Body stub acts as spec
13300 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13301 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13307 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13315 Spec_Id := Unique_Defining_Entity (Subp_Decl);
13317 -- Chain the pragma on the contract for further processing by
13318 -- Analyze_Contract_Cases_In_Decl_Part.
13320 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13322 -- A pragma that applies to a Ghost entity becomes Ghost for the
13323 -- purposes of legality checks and removal of ignored Ghost code.
13325 Mark_Pragma_As_Ghost (N, Spec_Id);
13326 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13328 -- Fully analyze the pragma when it appears inside an entry
13329 -- or subprogram body because it cannot benefit from forward
13332 if Nkind_In (Subp_Decl, N_Entry_Body,
13334 N_Subprogram_Body_Stub)
13336 -- The legality checks of pragma Contract_Cases are affected by
13337 -- the SPARK mode in effect and the volatility of the context.
13338 -- Analyze all pragmas in a specific order.
13340 Analyze_If_Present (Pragma_SPARK_Mode);
13341 Analyze_If_Present (Pragma_Volatile_Function);
13342 Analyze_Contract_Cases_In_Decl_Part (N);
13344 end Contract_Cases;
13350 -- pragma Controlled (first_subtype_LOCAL_NAME);
13352 when Pragma_Controlled => Controlled : declare
13356 Check_No_Identifiers;
13357 Check_Arg_Count (1);
13358 Check_Arg_Is_Local_Name (Arg1);
13359 Arg := Get_Pragma_Arg (Arg1);
13361 if not Is_Entity_Name (Arg)
13362 or else not Is_Access_Type (Entity (Arg))
13364 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13366 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13374 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13375 -- [Entity =>] LOCAL_NAME);
13377 when Pragma_Convention => Convention : declare
13380 pragma Warnings (Off, C);
13381 pragma Warnings (Off, E);
13383 Check_Arg_Order ((Name_Convention, Name_Entity));
13384 Check_Ada_83_Warning;
13385 Check_Arg_Count (2);
13386 Process_Convention (C, E);
13388 -- A pragma that applies to a Ghost entity becomes Ghost for the
13389 -- purposes of legality checks and removal of ignored Ghost code.
13391 Mark_Pragma_As_Ghost (N, E);
13394 ---------------------------
13395 -- Convention_Identifier --
13396 ---------------------------
13398 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13399 -- [Convention =>] convention_IDENTIFIER);
13401 when Pragma_Convention_Identifier => Convention_Identifier : declare
13407 Check_Arg_Order ((Name_Name, Name_Convention));
13408 Check_Arg_Count (2);
13409 Check_Optional_Identifier (Arg1, Name_Name);
13410 Check_Optional_Identifier (Arg2, Name_Convention);
13411 Check_Arg_Is_Identifier (Arg1);
13412 Check_Arg_Is_Identifier (Arg2);
13413 Idnam := Chars (Get_Pragma_Arg (Arg1));
13414 Cname := Chars (Get_Pragma_Arg (Arg2));
13416 if Is_Convention_Name (Cname) then
13417 Record_Convention_Identifier
13418 (Idnam, Get_Convention_Id (Cname));
13421 ("second arg for % pragma must be convention", Arg2);
13423 end Convention_Identifier;
13429 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13431 when Pragma_CPP_Class => CPP_Class : declare
13435 if Warn_On_Obsolescent_Feature then
13437 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13438 & "effect; replace it by pragma import?j?", N);
13441 Check_Arg_Count (1);
13445 Chars => Name_Import,
13446 Pragma_Argument_Associations => New_List (
13447 Make_Pragma_Argument_Association (Loc,
13448 Expression => Make_Identifier (Loc, Name_CPP)),
13449 New_Copy (First (Pragma_Argument_Associations (N))))));
13453 ---------------------
13454 -- CPP_Constructor --
13455 ---------------------
13457 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13458 -- [, [External_Name =>] static_string_EXPRESSION ]
13459 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13461 when Pragma_CPP_Constructor => CPP_Constructor : declare
13464 Def_Id : Entity_Id;
13465 Tag_Typ : Entity_Id;
13469 Check_At_Least_N_Arguments (1);
13470 Check_At_Most_N_Arguments (3);
13471 Check_Optional_Identifier (Arg1, Name_Entity);
13472 Check_Arg_Is_Local_Name (Arg1);
13474 Id := Get_Pragma_Arg (Arg1);
13475 Find_Program_Unit_Name (Id);
13477 -- If we did not find the name, we are done
13479 if Etype (Id) = Any_Type then
13483 Def_Id := Entity (Id);
13485 -- Check if already defined as constructor
13487 if Is_Constructor (Def_Id) then
13489 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13493 if Ekind (Def_Id) = E_Function
13494 and then (Is_CPP_Class (Etype (Def_Id))
13495 or else (Is_Class_Wide_Type (Etype (Def_Id))
13497 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13499 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13501 ("'C'P'P constructor must be defined in the scope of "
13502 & "its returned type", Arg1);
13505 if Arg_Count >= 2 then
13506 Set_Imported (Def_Id);
13507 Set_Is_Public (Def_Id);
13508 Process_Interface_Name (Def_Id, Arg2, Arg3);
13511 Set_Has_Completion (Def_Id);
13512 Set_Is_Constructor (Def_Id);
13513 Set_Convention (Def_Id, Convention_CPP);
13515 -- Imported C++ constructors are not dispatching primitives
13516 -- because in C++ they don't have a dispatch table slot.
13517 -- However, in Ada the constructor has the profile of a
13518 -- function that returns a tagged type and therefore it has
13519 -- been treated as a primitive operation during semantic
13520 -- analysis. We now remove it from the list of primitive
13521 -- operations of the type.
13523 if Is_Tagged_Type (Etype (Def_Id))
13524 and then not Is_Class_Wide_Type (Etype (Def_Id))
13525 and then Is_Dispatching_Operation (Def_Id)
13527 Tag_Typ := Etype (Def_Id);
13529 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13530 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13534 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13535 Set_Is_Dispatching_Operation (Def_Id, False);
13538 -- For backward compatibility, if the constructor returns a
13539 -- class wide type, and we internally change the return type to
13540 -- the corresponding root type.
13542 if Is_Class_Wide_Type (Etype (Def_Id)) then
13543 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13547 ("pragma% requires function returning a 'C'P'P_Class type",
13550 end CPP_Constructor;
13556 when Pragma_CPP_Virtual => CPP_Virtual : declare
13560 if Warn_On_Obsolescent_Feature then
13562 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13571 when Pragma_CPP_Vtable => CPP_Vtable : declare
13575 if Warn_On_Obsolescent_Feature then
13577 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13586 -- pragma CPU (EXPRESSION);
13588 when Pragma_CPU => CPU : declare
13589 P : constant Node_Id := Parent (N);
13595 Check_No_Identifiers;
13596 Check_Arg_Count (1);
13600 if Nkind (P) = N_Subprogram_Body then
13601 Check_In_Main_Program;
13603 Arg := Get_Pragma_Arg (Arg1);
13604 Analyze_And_Resolve (Arg, Any_Integer);
13606 Ent := Defining_Unit_Name (Specification (P));
13608 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13609 Ent := Defining_Identifier (Ent);
13614 if not Is_OK_Static_Expression (Arg) then
13615 Flag_Non_Static_Expr
13616 ("main subprogram affinity is not static!", Arg);
13619 -- If constraint error, then we already signalled an error
13621 elsif Raises_Constraint_Error (Arg) then
13624 -- Otherwise check in range
13628 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13629 -- This is the entity System.Multiprocessors.CPU_Range;
13631 Val : constant Uint := Expr_Value (Arg);
13634 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13636 Val > Expr_Value (Type_High_Bound (CPU_Id))
13639 ("main subprogram CPU is out of range", Arg1);
13645 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13649 elsif Nkind (P) = N_Task_Definition then
13650 Arg := Get_Pragma_Arg (Arg1);
13651 Ent := Defining_Identifier (Parent (P));
13653 -- The expression must be analyzed in the special manner
13654 -- described in "Handling of Default and Per-Object
13655 -- Expressions" in sem.ads.
13657 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13659 -- Anything else is incorrect
13665 -- Check duplicate pragma before we chain the pragma in the Rep
13666 -- Item chain of Ent.
13668 Check_Duplicate_Pragma (Ent);
13669 Record_Rep_Item (Ent, N);
13676 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13678 when Pragma_Debug => Debug : declare
13685 -- The condition for executing the call is that the expander
13686 -- is active and that we are not ignoring this debug pragma.
13691 (Expander_Active and then not Is_Ignored (N)),
13694 if not Is_Ignored (N) then
13695 Set_SCO_Pragma_Enabled (Loc);
13698 if Arg_Count = 2 then
13700 Make_And_Then (Loc,
13701 Left_Opnd => Relocate_Node (Cond),
13702 Right_Opnd => Get_Pragma_Arg (Arg1));
13703 Call := Get_Pragma_Arg (Arg2);
13705 Call := Get_Pragma_Arg (Arg1);
13709 N_Indexed_Component,
13713 N_Selected_Component)
13715 -- If this pragma Debug comes from source, its argument was
13716 -- parsed as a name form (which is syntactically identical).
13717 -- In a generic context a parameterless call will be left as
13718 -- an expanded name (if global) or selected_component if local.
13719 -- Change it to a procedure call statement now.
13721 Change_Name_To_Procedure_Call_Statement (Call);
13723 elsif Nkind (Call) = N_Procedure_Call_Statement then
13725 -- Already in the form of a procedure call statement: nothing
13726 -- to do (could happen in case of an internally generated
13732 -- All other cases: diagnose error
13735 ("argument of pragma ""Debug"" is not procedure call",
13740 -- Rewrite into a conditional with an appropriate condition. We
13741 -- wrap the procedure call in a block so that overhead from e.g.
13742 -- use of the secondary stack does not generate execution overhead
13743 -- for suppressed conditions.
13745 -- Normally the analysis that follows will freeze the subprogram
13746 -- being called. However, if the call is to a null procedure,
13747 -- we want to freeze it before creating the block, because the
13748 -- analysis that follows may be done with expansion disabled, in
13749 -- which case the body will not be generated, leading to spurious
13752 if Nkind (Call) = N_Procedure_Call_Statement
13753 and then Is_Entity_Name (Name (Call))
13755 Analyze (Name (Call));
13756 Freeze_Before (N, Entity (Name (Call)));
13760 Make_Implicit_If_Statement (N,
13762 Then_Statements => New_List (
13763 Make_Block_Statement (Loc,
13764 Handled_Statement_Sequence =>
13765 Make_Handled_Sequence_Of_Statements (Loc,
13766 Statements => New_List (Relocate_Node (Call)))))));
13769 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13770 -- after analysis of the normally rewritten node, to capture all
13771 -- references to entities, which avoids issuing wrong warnings
13772 -- about unused entities.
13774 if GNATprove_Mode then
13775 Rewrite (N, Make_Null_Statement (Loc));
13783 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13785 when Pragma_Debug_Policy =>
13787 Check_Arg_Count (1);
13788 Check_No_Identifiers;
13789 Check_Arg_Is_Identifier (Arg1);
13791 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13792 -- rewrite it that way, and let the rest of the checking come
13793 -- from analyzing the rewritten pragma.
13797 Chars => Name_Check_Policy,
13798 Pragma_Argument_Associations => New_List (
13799 Make_Pragma_Argument_Association (Loc,
13800 Expression => Make_Identifier (Loc, Name_Debug)),
13802 Make_Pragma_Argument_Association (Loc,
13803 Expression => Get_Pragma_Arg (Arg1)))));
13806 -------------------------------
13807 -- Default_Initial_Condition --
13808 -------------------------------
13810 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13812 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13819 Check_No_Identifiers;
13820 Check_At_Most_N_Arguments (1);
13823 while Present (Stmt) loop
13825 -- Skip prior pragmas, but check for duplicates
13827 if Nkind (Stmt) = N_Pragma then
13828 if Pragma_Name (Stmt) = Pname then
13829 Error_Msg_Name_1 := Pname;
13830 Error_Msg_Sloc := Sloc (Stmt);
13831 Error_Msg_N ("pragma % duplicates pragma declared#", N);
13834 -- Skip internally generated code
13836 elsif not Comes_From_Source (Stmt) then
13839 -- The associated private type [extension] has been found, stop
13842 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13843 N_Private_Type_Declaration)
13845 Typ := Defining_Entity (Stmt);
13848 -- The pragma does not apply to a legal construct, issue an
13849 -- error and stop the analysis.
13856 Stmt := Prev (Stmt);
13859 -- A pragma that applies to a Ghost entity becomes Ghost for the
13860 -- purposes of legality checks and removal of ignored Ghost code.
13862 Mark_Pragma_As_Ghost (N, Typ);
13863 Set_Has_Default_Init_Cond (Typ);
13864 Set_Has_Inherited_Default_Init_Cond (Typ, False);
13866 -- Chain the pragma on the rep item chain for further processing
13868 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13869 end Default_Init_Cond;
13871 ----------------------------------
13872 -- Default_Scalar_Storage_Order --
13873 ----------------------------------
13875 -- pragma Default_Scalar_Storage_Order
13876 -- (High_Order_First | Low_Order_First);
13878 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13879 Default : Character;
13883 Check_Arg_Count (1);
13885 -- Default_Scalar_Storage_Order can appear as a configuration
13886 -- pragma, or in a declarative part of a package spec.
13888 if not Is_Configuration_Pragma then
13889 Check_Is_In_Decl_Part_Or_Package_Spec;
13892 Check_No_Identifiers;
13893 Check_Arg_Is_One_Of
13894 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13895 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13896 Default := Fold_Upper (Name_Buffer (1));
13898 if not Support_Nondefault_SSO_On_Target
13899 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13901 if Warn_On_Unrecognized_Pragma then
13903 ("non-default Scalar_Storage_Order not supported "
13904 & "on target?g?", N);
13906 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13909 -- Here set the specified default
13912 Opt.Default_SSO := Default;
13916 --------------------------
13917 -- Default_Storage_Pool --
13918 --------------------------
13920 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13922 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13927 Check_Arg_Count (1);
13929 -- Default_Storage_Pool can appear as a configuration pragma, or
13930 -- in a declarative part of a package spec.
13932 if not Is_Configuration_Pragma then
13933 Check_Is_In_Decl_Part_Or_Package_Spec;
13936 if From_Aspect_Specification (N) then
13938 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
13940 if not In_Open_Scopes (E) then
13942 ("aspect must apply to package or subprogram", N);
13947 if Present (Arg1) then
13948 Pool := Get_Pragma_Arg (Arg1);
13950 -- Case of Default_Storage_Pool (null);
13952 if Nkind (Pool) = N_Null then
13955 -- This is an odd case, this is not really an expression,
13956 -- so we don't have a type for it. So just set the type to
13959 Set_Etype (Pool, Empty);
13961 -- Case of Default_Storage_Pool (storage_pool_NAME);
13964 -- If it's a configuration pragma, then the only allowed
13965 -- argument is "null".
13967 if Is_Configuration_Pragma then
13968 Error_Pragma_Arg ("NULL expected", Arg1);
13971 -- The expected type for a non-"null" argument is
13972 -- Root_Storage_Pool'Class, and the pool must be a variable.
13974 Analyze_And_Resolve
13975 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13977 if Is_Variable (Pool) then
13979 -- A pragma that applies to a Ghost entity becomes Ghost
13980 -- for the purposes of legality checks and removal of
13981 -- ignored Ghost code.
13983 Mark_Pragma_As_Ghost (N, Entity (Pool));
13987 ("default storage pool must be a variable", Arg1);
13991 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13992 -- access type will use this information to set the appropriate
13993 -- attributes of the access type.
13995 Default_Pool := Pool;
13997 end Default_Storage_Pool;
14003 -- pragma Depends (DEPENDENCY_RELATION);
14005 -- DEPENDENCY_RELATION ::=
14007 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14009 -- DEPENDENCY_CLAUSE ::=
14010 -- OUTPUT_LIST =>[+] INPUT_LIST
14011 -- | NULL_DEPENDENCY_CLAUSE
14013 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14015 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14017 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14019 -- OUTPUT ::= NAME | FUNCTION_RESULT
14022 -- where FUNCTION_RESULT is a function Result attribute_reference
14024 -- Characteristics:
14026 -- * Analysis - The annotation undergoes initial checks to verify
14027 -- the legal placement and context. Secondary checks fully analyze
14028 -- the dependency clauses in:
14030 -- Analyze_Depends_In_Decl_Part
14032 -- * Expansion - None.
14034 -- * Template - The annotation utilizes the generic template of the
14035 -- related subprogram [body] when it is:
14037 -- aspect on subprogram declaration
14038 -- aspect on stand alone subprogram body
14039 -- pragma on stand alone subprogram body
14041 -- The annotation must prepare its own template when it is:
14043 -- pragma on subprogram declaration
14045 -- * Globals - Capture of global references must occur after full
14048 -- * Instance - The annotation is instantiated automatically when
14049 -- the related generic subprogram [body] is instantiated except for
14050 -- the "pragma on subprogram declaration" case. In that scenario
14051 -- the annotation must instantiate itself.
14053 when Pragma_Depends => Depends : declare
14055 Spec_Id : Entity_Id;
14056 Subp_Decl : Node_Id;
14059 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14063 -- Chain the pragma on the contract for further processing by
14064 -- Analyze_Depends_In_Decl_Part.
14066 Add_Contract_Item (N, Spec_Id);
14068 -- Fully analyze the pragma when it appears inside an entry
14069 -- or subprogram body because it cannot benefit from forward
14072 if Nkind_In (Subp_Decl, N_Entry_Body,
14074 N_Subprogram_Body_Stub)
14076 -- The legality checks of pragmas Depends and Global are
14077 -- affected by the SPARK mode in effect and the volatility
14078 -- of the context. In addition these two pragmas are subject
14079 -- to an inherent order:
14084 -- Analyze all these pragmas in the order outlined above
14086 Analyze_If_Present (Pragma_SPARK_Mode);
14087 Analyze_If_Present (Pragma_Volatile_Function);
14088 Analyze_If_Present (Pragma_Global);
14089 Analyze_Depends_In_Decl_Part (N);
14094 ---------------------
14095 -- Detect_Blocking --
14096 ---------------------
14098 -- pragma Detect_Blocking;
14100 when Pragma_Detect_Blocking =>
14102 Check_Arg_Count (0);
14103 Check_Valid_Configuration_Pragma;
14104 Detect_Blocking := True;
14106 ------------------------------------
14107 -- Disable_Atomic_Synchronization --
14108 ------------------------------------
14110 -- pragma Disable_Atomic_Synchronization [(Entity)];
14112 when Pragma_Disable_Atomic_Synchronization =>
14114 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
14116 -------------------
14117 -- Discard_Names --
14118 -------------------
14120 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14122 when Pragma_Discard_Names => Discard_Names : declare
14127 Check_Ada_83_Warning;
14129 -- Deal with configuration pragma case
14131 if Arg_Count = 0 and then Is_Configuration_Pragma then
14132 Global_Discard_Names := True;
14135 -- Otherwise, check correct appropriate context
14138 Check_Is_In_Decl_Part_Or_Package_Spec;
14140 if Arg_Count = 0 then
14142 -- If there is no parameter, then from now on this pragma
14143 -- applies to any enumeration, exception or tagged type
14144 -- defined in the current declarative part, and recursively
14145 -- to any nested scope.
14147 Set_Discard_Names (Current_Scope);
14151 Check_Arg_Count (1);
14152 Check_Optional_Identifier (Arg1, Name_On);
14153 Check_Arg_Is_Local_Name (Arg1);
14155 E_Id := Get_Pragma_Arg (Arg1);
14157 if Etype (E_Id) = Any_Type then
14160 E := Entity (E_Id);
14163 -- A pragma that applies to a Ghost entity becomes Ghost for
14164 -- the purposes of legality checks and removal of ignored
14167 Mark_Pragma_As_Ghost (N, E);
14169 if (Is_First_Subtype (E)
14171 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
14172 or else Ekind (E) = E_Exception
14174 Set_Discard_Names (E);
14175 Record_Rep_Item (E, N);
14179 ("inappropriate entity for pragma%", Arg1);
14185 ------------------------
14186 -- Dispatching_Domain --
14187 ------------------------
14189 -- pragma Dispatching_Domain (EXPRESSION);
14191 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
14192 P : constant Node_Id := Parent (N);
14198 Check_No_Identifiers;
14199 Check_Arg_Count (1);
14201 -- This pragma is born obsolete, but not the aspect
14203 if not From_Aspect_Specification (N) then
14205 (No_Obsolescent_Features, Pragma_Identifier (N));
14208 if Nkind (P) = N_Task_Definition then
14209 Arg := Get_Pragma_Arg (Arg1);
14210 Ent := Defining_Identifier (Parent (P));
14212 -- A pragma that applies to a Ghost entity becomes Ghost for
14213 -- the purposes of legality checks and removal of ignored Ghost
14216 Mark_Pragma_As_Ghost (N, Ent);
14218 -- The expression must be analyzed in the special manner
14219 -- described in "Handling of Default and Per-Object
14220 -- Expressions" in sem.ads.
14222 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
14224 -- Check duplicate pragma before we chain the pragma in the Rep
14225 -- Item chain of Ent.
14227 Check_Duplicate_Pragma (Ent);
14228 Record_Rep_Item (Ent, N);
14230 -- Anything else is incorrect
14235 end Dispatching_Domain;
14241 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14243 when Pragma_Elaborate => Elaborate : declare
14248 -- Pragma must be in context items list of a compilation unit
14250 if not Is_In_Context_Clause then
14254 -- Must be at least one argument
14256 if Arg_Count = 0 then
14257 Error_Pragma ("pragma% requires at least one argument");
14260 -- In Ada 83 mode, there can be no items following it in the
14261 -- context list except other pragmas and implicit with clauses
14262 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14263 -- placement rule does not apply.
14265 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
14267 while Present (Citem) loop
14268 if Nkind (Citem) = N_Pragma
14269 or else (Nkind (Citem) = N_With_Clause
14270 and then Implicit_With (Citem))
14275 ("(Ada 83) pragma% must be at end of context clause");
14282 -- Finally, the arguments must all be units mentioned in a with
14283 -- clause in the same context clause. Note we already checked (in
14284 -- Par.Prag) that the arguments are all identifiers or selected
14288 Outer : while Present (Arg) loop
14289 Citem := First (List_Containing (N));
14290 Inner : while Citem /= N loop
14291 if Nkind (Citem) = N_With_Clause
14292 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14294 Set_Elaborate_Present (Citem, True);
14295 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14297 -- With the pragma present, elaboration calls on
14298 -- subprograms from the named unit need no further
14299 -- checks, as long as the pragma appears in the current
14300 -- compilation unit. If the pragma appears in some unit
14301 -- in the context, there might still be a need for an
14302 -- Elaborate_All_Desirable from the current compilation
14303 -- to the named unit, so we keep the check enabled.
14305 if In_Extended_Main_Source_Unit (N) then
14307 -- This does not apply in SPARK mode, where we allow
14308 -- pragma Elaborate, but we don't trust it to be right
14309 -- so we will still insist on the Elaborate_All.
14311 if SPARK_Mode /= On then
14312 Set_Suppress_Elaboration_Warnings
14313 (Entity (Name (Citem)));
14325 ("argument of pragma% is not withed unit", Arg);
14331 -- Give a warning if operating in static mode with one of the
14332 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14335 and not Dynamic_Elaboration_Checks
14337 -- pragma Elaborate not allowed in SPARK mode anyway. We
14338 -- already complained about it, no point in generating any
14339 -- further complaint.
14341 and SPARK_Mode /= On
14344 ("?l?use of pragma Elaborate may not be safe", N);
14346 ("?l?use pragma Elaborate_All instead if possible", N);
14350 -------------------
14351 -- Elaborate_All --
14352 -------------------
14354 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14356 when Pragma_Elaborate_All => Elaborate_All : declare
14361 Check_Ada_83_Warning;
14363 -- Pragma must be in context items list of a compilation unit
14365 if not Is_In_Context_Clause then
14369 -- Must be at least one argument
14371 if Arg_Count = 0 then
14372 Error_Pragma ("pragma% requires at least one argument");
14375 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14376 -- have to appear at the end of the context clause, but may
14377 -- appear mixed in with other items, even in Ada 83 mode.
14379 -- Final check: the arguments must all be units mentioned in
14380 -- a with clause in the same context clause. Note that we
14381 -- already checked (in Par.Prag) that all the arguments are
14382 -- either identifiers or selected components.
14385 Outr : while Present (Arg) loop
14386 Citem := First (List_Containing (N));
14387 Innr : while Citem /= N loop
14388 if Nkind (Citem) = N_With_Clause
14389 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14391 Set_Elaborate_All_Present (Citem, True);
14392 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14394 -- Suppress warnings and elaboration checks on the named
14395 -- unit if the pragma is in the current compilation, as
14396 -- for pragma Elaborate.
14398 if In_Extended_Main_Source_Unit (N) then
14399 Set_Suppress_Elaboration_Warnings
14400 (Entity (Name (Citem)));
14409 Set_Error_Posted (N);
14411 ("argument of pragma% is not withed unit", Arg);
14418 --------------------
14419 -- Elaborate_Body --
14420 --------------------
14422 -- pragma Elaborate_Body [( library_unit_NAME )];
14424 when Pragma_Elaborate_Body => Elaborate_Body : declare
14425 Cunit_Node : Node_Id;
14426 Cunit_Ent : Entity_Id;
14429 Check_Ada_83_Warning;
14430 Check_Valid_Library_Unit_Pragma;
14432 if Nkind (N) = N_Null_Statement then
14436 Cunit_Node := Cunit (Current_Sem_Unit);
14437 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14439 -- A pragma that applies to a Ghost entity becomes Ghost for the
14440 -- purposes of legality checks and removal of ignored Ghost code.
14442 Mark_Pragma_As_Ghost (N, Cunit_Ent);
14444 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14447 Error_Pragma ("pragma% must refer to a spec, not a body");
14449 Set_Body_Required (Cunit_Node, True);
14450 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14452 -- If we are in dynamic elaboration mode, then we suppress
14453 -- elaboration warnings for the unit, since it is definitely
14454 -- fine NOT to do dynamic checks at the first level (and such
14455 -- checks will be suppressed because no elaboration boolean
14456 -- is created for Elaborate_Body packages).
14458 -- But in the static model of elaboration, Elaborate_Body is
14459 -- definitely NOT good enough to ensure elaboration safety on
14460 -- its own, since the body may WITH other units that are not
14461 -- safe from an elaboration point of view, so a client must
14462 -- still do an Elaborate_All on such units.
14464 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14465 -- Elaborate_Body always suppressed elab warnings.
14467 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14468 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14471 end Elaborate_Body;
14473 ------------------------
14474 -- Elaboration_Checks --
14475 ------------------------
14477 -- pragma Elaboration_Checks (Static | Dynamic);
14479 when Pragma_Elaboration_Checks =>
14481 Check_Arg_Count (1);
14482 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14484 -- Set flag accordingly (ignore attempt at dynamic elaboration
14485 -- checks in SPARK mode).
14487 Dynamic_Elaboration_Checks :=
14488 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
14494 -- pragma Eliminate (
14495 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14496 -- [,[Entity =>] IDENTIFIER |
14497 -- SELECTED_COMPONENT |
14499 -- [, OVERLOADING_RESOLUTION]);
14501 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14504 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14505 -- FUNCTION_PROFILE
14507 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14509 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14510 -- Result_Type => result_SUBTYPE_NAME]
14512 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14513 -- SUBTYPE_NAME ::= STRING_LITERAL
14515 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14516 -- SOURCE_TRACE ::= STRING_LITERAL
14518 when Pragma_Eliminate => Eliminate : declare
14519 Args : Args_List (1 .. 5);
14520 Names : constant Name_List (1 .. 5) := (
14523 Name_Parameter_Types,
14525 Name_Source_Location);
14527 Unit_Name : Node_Id renames Args (1);
14528 Entity : Node_Id renames Args (2);
14529 Parameter_Types : Node_Id renames Args (3);
14530 Result_Type : Node_Id renames Args (4);
14531 Source_Location : Node_Id renames Args (5);
14535 Check_Valid_Configuration_Pragma;
14536 Gather_Associations (Names, Args);
14538 if No (Unit_Name) then
14539 Error_Pragma ("missing Unit_Name argument for pragma%");
14543 and then (Present (Parameter_Types)
14545 Present (Result_Type)
14547 Present (Source_Location))
14549 Error_Pragma ("missing Entity argument for pragma%");
14552 if (Present (Parameter_Types)
14554 Present (Result_Type))
14556 Present (Source_Location)
14559 ("parameter profile and source location cannot be used "
14560 & "together in pragma%");
14563 Process_Eliminate_Pragma
14572 -----------------------------------
14573 -- Enable_Atomic_Synchronization --
14574 -----------------------------------
14576 -- pragma Enable_Atomic_Synchronization [(Entity)];
14578 when Pragma_Enable_Atomic_Synchronization =>
14580 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14587 -- [ Convention =>] convention_IDENTIFIER,
14588 -- [ Entity =>] LOCAL_NAME
14589 -- [, [External_Name =>] static_string_EXPRESSION ]
14590 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14592 when Pragma_Export => Export : declare
14594 Def_Id : Entity_Id;
14596 pragma Warnings (Off, C);
14599 Check_Ada_83_Warning;
14603 Name_External_Name,
14606 Check_At_Least_N_Arguments (2);
14607 Check_At_Most_N_Arguments (4);
14609 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14610 -- pragma Export (Entity, "external name");
14612 if Relaxed_RM_Semantics
14613 and then Arg_Count = 2
14614 and then Nkind (Expression (Arg2)) = N_String_Literal
14617 Def_Id := Get_Pragma_Arg (Arg1);
14620 if not Is_Entity_Name (Def_Id) then
14621 Error_Pragma_Arg ("entity name required", Arg1);
14624 Def_Id := Entity (Def_Id);
14625 Set_Exported (Def_Id, Arg1);
14628 Process_Convention (C, Def_Id);
14630 -- A pragma that applies to a Ghost entity becomes Ghost for
14631 -- the purposes of legality checks and removal of ignored Ghost
14634 Mark_Pragma_As_Ghost (N, Def_Id);
14636 if Ekind (Def_Id) /= E_Constant then
14637 Note_Possible_Modification
14638 (Get_Pragma_Arg (Arg2), Sure => False);
14641 Process_Interface_Name (Def_Id, Arg3, Arg4);
14642 Set_Exported (Def_Id, Arg2);
14645 -- If the entity is a deferred constant, propagate the information
14646 -- to the full view, because gigi elaborates the full view only.
14648 if Ekind (Def_Id) = E_Constant
14649 and then Present (Full_View (Def_Id))
14652 Id2 : constant Entity_Id := Full_View (Def_Id);
14654 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14655 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14656 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14661 ---------------------
14662 -- Export_Function --
14663 ---------------------
14665 -- pragma Export_Function (
14666 -- [Internal =>] LOCAL_NAME
14667 -- [, [External =>] EXTERNAL_SYMBOL]
14668 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14669 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14670 -- [, [Mechanism =>] MECHANISM]
14671 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14673 -- EXTERNAL_SYMBOL ::=
14675 -- | static_string_EXPRESSION
14677 -- PARAMETER_TYPES ::=
14679 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14681 -- TYPE_DESIGNATOR ::=
14683 -- | subtype_Name ' Access
14687 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14689 -- MECHANISM_ASSOCIATION ::=
14690 -- [formal_parameter_NAME =>] MECHANISM_NAME
14692 -- MECHANISM_NAME ::=
14696 when Pragma_Export_Function => Export_Function : declare
14697 Args : Args_List (1 .. 6);
14698 Names : constant Name_List (1 .. 6) := (
14701 Name_Parameter_Types,
14704 Name_Result_Mechanism);
14706 Internal : Node_Id renames Args (1);
14707 External : Node_Id renames Args (2);
14708 Parameter_Types : Node_Id renames Args (3);
14709 Result_Type : Node_Id renames Args (4);
14710 Mechanism : Node_Id renames Args (5);
14711 Result_Mechanism : Node_Id renames Args (6);
14715 Gather_Associations (Names, Args);
14716 Process_Extended_Import_Export_Subprogram_Pragma (
14717 Arg_Internal => Internal,
14718 Arg_External => External,
14719 Arg_Parameter_Types => Parameter_Types,
14720 Arg_Result_Type => Result_Type,
14721 Arg_Mechanism => Mechanism,
14722 Arg_Result_Mechanism => Result_Mechanism);
14723 end Export_Function;
14725 -------------------
14726 -- Export_Object --
14727 -------------------
14729 -- pragma Export_Object (
14730 -- [Internal =>] LOCAL_NAME
14731 -- [, [External =>] EXTERNAL_SYMBOL]
14732 -- [, [Size =>] EXTERNAL_SYMBOL]);
14734 -- EXTERNAL_SYMBOL ::=
14736 -- | static_string_EXPRESSION
14738 -- PARAMETER_TYPES ::=
14740 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14742 -- TYPE_DESIGNATOR ::=
14744 -- | subtype_Name ' Access
14748 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14750 -- MECHANISM_ASSOCIATION ::=
14751 -- [formal_parameter_NAME =>] MECHANISM_NAME
14753 -- MECHANISM_NAME ::=
14757 when Pragma_Export_Object => Export_Object : declare
14758 Args : Args_List (1 .. 3);
14759 Names : constant Name_List (1 .. 3) := (
14764 Internal : Node_Id renames Args (1);
14765 External : Node_Id renames Args (2);
14766 Size : Node_Id renames Args (3);
14770 Gather_Associations (Names, Args);
14771 Process_Extended_Import_Export_Object_Pragma (
14772 Arg_Internal => Internal,
14773 Arg_External => External,
14777 ----------------------
14778 -- Export_Procedure --
14779 ----------------------
14781 -- pragma Export_Procedure (
14782 -- [Internal =>] LOCAL_NAME
14783 -- [, [External =>] EXTERNAL_SYMBOL]
14784 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14785 -- [, [Mechanism =>] MECHANISM]);
14787 -- EXTERNAL_SYMBOL ::=
14789 -- | static_string_EXPRESSION
14791 -- PARAMETER_TYPES ::=
14793 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14795 -- TYPE_DESIGNATOR ::=
14797 -- | subtype_Name ' Access
14801 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14803 -- MECHANISM_ASSOCIATION ::=
14804 -- [formal_parameter_NAME =>] MECHANISM_NAME
14806 -- MECHANISM_NAME ::=
14810 when Pragma_Export_Procedure => Export_Procedure : declare
14811 Args : Args_List (1 .. 4);
14812 Names : constant Name_List (1 .. 4) := (
14815 Name_Parameter_Types,
14818 Internal : Node_Id renames Args (1);
14819 External : Node_Id renames Args (2);
14820 Parameter_Types : Node_Id renames Args (3);
14821 Mechanism : Node_Id renames Args (4);
14825 Gather_Associations (Names, Args);
14826 Process_Extended_Import_Export_Subprogram_Pragma (
14827 Arg_Internal => Internal,
14828 Arg_External => External,
14829 Arg_Parameter_Types => Parameter_Types,
14830 Arg_Mechanism => Mechanism);
14831 end Export_Procedure;
14837 -- pragma Export_Value (
14838 -- [Value =>] static_integer_EXPRESSION,
14839 -- [Link_Name =>] static_string_EXPRESSION);
14841 when Pragma_Export_Value =>
14843 Check_Arg_Order ((Name_Value, Name_Link_Name));
14844 Check_Arg_Count (2);
14846 Check_Optional_Identifier (Arg1, Name_Value);
14847 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14849 Check_Optional_Identifier (Arg2, Name_Link_Name);
14850 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14852 -----------------------------
14853 -- Export_Valued_Procedure --
14854 -----------------------------
14856 -- pragma Export_Valued_Procedure (
14857 -- [Internal =>] LOCAL_NAME
14858 -- [, [External =>] EXTERNAL_SYMBOL,]
14859 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14860 -- [, [Mechanism =>] MECHANISM]);
14862 -- EXTERNAL_SYMBOL ::=
14864 -- | static_string_EXPRESSION
14866 -- PARAMETER_TYPES ::=
14868 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14870 -- TYPE_DESIGNATOR ::=
14872 -- | subtype_Name ' Access
14876 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14878 -- MECHANISM_ASSOCIATION ::=
14879 -- [formal_parameter_NAME =>] MECHANISM_NAME
14881 -- MECHANISM_NAME ::=
14885 when Pragma_Export_Valued_Procedure =>
14886 Export_Valued_Procedure : declare
14887 Args : Args_List (1 .. 4);
14888 Names : constant Name_List (1 .. 4) := (
14891 Name_Parameter_Types,
14894 Internal : Node_Id renames Args (1);
14895 External : Node_Id renames Args (2);
14896 Parameter_Types : Node_Id renames Args (3);
14897 Mechanism : Node_Id renames Args (4);
14901 Gather_Associations (Names, Args);
14902 Process_Extended_Import_Export_Subprogram_Pragma (
14903 Arg_Internal => Internal,
14904 Arg_External => External,
14905 Arg_Parameter_Types => Parameter_Types,
14906 Arg_Mechanism => Mechanism);
14907 end Export_Valued_Procedure;
14909 -------------------
14910 -- Extend_System --
14911 -------------------
14913 -- pragma Extend_System ([Name =>] Identifier);
14915 when Pragma_Extend_System => Extend_System : declare
14918 Check_Valid_Configuration_Pragma;
14919 Check_Arg_Count (1);
14920 Check_Optional_Identifier (Arg1, Name_Name);
14921 Check_Arg_Is_Identifier (Arg1);
14923 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14926 and then Name_Buffer (1 .. 4) = "aux_"
14928 if Present (System_Extend_Pragma_Arg) then
14929 if Chars (Get_Pragma_Arg (Arg1)) =
14930 Chars (Expression (System_Extend_Pragma_Arg))
14934 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14935 Error_Pragma ("pragma% conflicts with that #");
14939 System_Extend_Pragma_Arg := Arg1;
14941 if not GNAT_Mode then
14942 System_Extend_Unit := Arg1;
14946 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14950 ------------------------
14951 -- Extensions_Allowed --
14952 ------------------------
14954 -- pragma Extensions_Allowed (ON | OFF);
14956 when Pragma_Extensions_Allowed =>
14958 Check_Arg_Count (1);
14959 Check_No_Identifiers;
14960 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14962 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14963 Extensions_Allowed := True;
14964 Ada_Version := Ada_Version_Type'Last;
14967 Extensions_Allowed := False;
14968 Ada_Version := Ada_Version_Explicit;
14969 Ada_Version_Pragma := Empty;
14972 ------------------------
14973 -- Extensions_Visible --
14974 ------------------------
14976 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14978 -- Characteristics:
14980 -- * Analysis - The annotation is fully analyzed immediately upon
14981 -- elaboration as its expression must be static.
14983 -- * Expansion - None.
14985 -- * Template - The annotation utilizes the generic template of the
14986 -- related subprogram [body] when it is:
14988 -- aspect on subprogram declaration
14989 -- aspect on stand alone subprogram body
14990 -- pragma on stand alone subprogram body
14992 -- The annotation must prepare its own template when it is:
14994 -- pragma on subprogram declaration
14996 -- * Globals - Capture of global references must occur after full
14999 -- * Instance - The annotation is instantiated automatically when
15000 -- the related generic subprogram [body] is instantiated except for
15001 -- the "pragma on subprogram declaration" case. In that scenario
15002 -- the annotation must instantiate itself.
15004 when Pragma_Extensions_Visible => Extensions_Visible : declare
15005 Formal : Entity_Id;
15006 Has_OK_Formal : Boolean := False;
15007 Spec_Id : Entity_Id;
15008 Subp_Decl : Node_Id;
15012 Check_No_Identifiers;
15013 Check_At_Most_N_Arguments (1);
15016 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15018 -- Abstract subprogram declaration
15020 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
15023 -- Generic subprogram declaration
15025 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15028 -- Body acts as spec
15030 elsif Nkind (Subp_Decl) = N_Subprogram_Body
15031 and then No (Corresponding_Spec (Subp_Decl))
15035 -- Body stub acts as spec
15037 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15038 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15042 -- Subprogram declaration
15044 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15047 -- Otherwise the pragma is associated with an illegal construct
15050 Error_Pragma ("pragma % must apply to a subprogram");
15054 -- Chain the pragma on the contract for completeness
15056 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15058 -- The legality checks of pragma Extension_Visible are affected
15059 -- by the SPARK mode in effect. Analyze all pragmas in specific
15062 Analyze_If_Present (Pragma_SPARK_Mode);
15064 -- Mark the pragma as Ghost if the related subprogram is also
15065 -- Ghost. This also ensures that any expansion performed further
15066 -- below will produce Ghost nodes.
15068 Spec_Id := Unique_Defining_Entity (Subp_Decl);
15069 Mark_Pragma_As_Ghost (N, Spec_Id);
15071 -- Examine the formals of the related subprogram
15073 Formal := First_Formal (Spec_Id);
15074 while Present (Formal) loop
15076 -- At least one of the formals is of a specific tagged type,
15077 -- the pragma is legal.
15079 if Is_Specific_Tagged_Type (Etype (Formal)) then
15080 Has_OK_Formal := True;
15083 -- A generic subprogram with at least one formal of a private
15084 -- type ensures the legality of the pragma because the actual
15085 -- may be specifically tagged. Note that this is verified by
15086 -- the check above at instantiation time.
15088 elsif Is_Private_Type (Etype (Formal))
15089 and then Is_Generic_Type (Etype (Formal))
15091 Has_OK_Formal := True;
15095 Next_Formal (Formal);
15098 if not Has_OK_Formal then
15099 Error_Msg_Name_1 := Pname;
15100 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
15102 ("\subprogram & lacks parameter of specific tagged or "
15103 & "generic private type", N, Spec_Id);
15108 -- Analyze the Boolean expression (if any)
15110 if Present (Arg1) then
15111 Check_Static_Boolean_Expression
15112 (Expression (Get_Argument (N, Spec_Id)));
15114 end Extensions_Visible;
15120 -- pragma External (
15121 -- [ Convention =>] convention_IDENTIFIER,
15122 -- [ Entity =>] LOCAL_NAME
15123 -- [, [External_Name =>] static_string_EXPRESSION ]
15124 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15126 when Pragma_External => External : declare
15129 pragma Warnings (Off, C);
15136 Name_External_Name,
15138 Check_At_Least_N_Arguments (2);
15139 Check_At_Most_N_Arguments (4);
15140 Process_Convention (C, E);
15142 -- A pragma that applies to a Ghost entity becomes Ghost for the
15143 -- purposes of legality checks and removal of ignored Ghost code.
15145 Mark_Pragma_As_Ghost (N, E);
15147 Note_Possible_Modification
15148 (Get_Pragma_Arg (Arg2), Sure => False);
15149 Process_Interface_Name (E, Arg3, Arg4);
15150 Set_Exported (E, Arg2);
15153 --------------------------
15154 -- External_Name_Casing --
15155 --------------------------
15157 -- pragma External_Name_Casing (
15158 -- UPPERCASE | LOWERCASE
15159 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15161 when Pragma_External_Name_Casing => External_Name_Casing : declare
15164 Check_No_Identifiers;
15166 if Arg_Count = 2 then
15167 Check_Arg_Is_One_Of
15168 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
15170 case Chars (Get_Pragma_Arg (Arg2)) is
15172 Opt.External_Name_Exp_Casing := As_Is;
15174 when Name_Uppercase =>
15175 Opt.External_Name_Exp_Casing := Uppercase;
15177 when Name_Lowercase =>
15178 Opt.External_Name_Exp_Casing := Lowercase;
15185 Check_Arg_Count (1);
15188 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
15190 case Chars (Get_Pragma_Arg (Arg1)) is
15191 when Name_Uppercase =>
15192 Opt.External_Name_Imp_Casing := Uppercase;
15194 when Name_Lowercase =>
15195 Opt.External_Name_Imp_Casing := Lowercase;
15200 end External_Name_Casing;
15206 -- pragma Fast_Math;
15208 when Pragma_Fast_Math =>
15210 Check_No_Identifiers;
15211 Check_Valid_Configuration_Pragma;
15214 --------------------------
15215 -- Favor_Top_Level --
15216 --------------------------
15218 -- pragma Favor_Top_Level (type_NAME);
15220 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
15225 Check_No_Identifiers;
15226 Check_Arg_Count (1);
15227 Check_Arg_Is_Local_Name (Arg1);
15228 Typ := Entity (Get_Pragma_Arg (Arg1));
15230 -- A pragma that applies to a Ghost entity becomes Ghost for the
15231 -- purposes of legality checks and removal of ignored Ghost code.
15233 Mark_Pragma_As_Ghost (N, Typ);
15235 -- If it's an access-to-subprogram type (in particular, not a
15236 -- subtype), set the flag on that type.
15238 if Is_Access_Subprogram_Type (Typ) then
15239 Set_Can_Use_Internal_Rep (Typ, False);
15241 -- Otherwise it's an error (name denotes the wrong sort of entity)
15245 ("access-to-subprogram type expected",
15246 Get_Pragma_Arg (Arg1));
15248 end Favor_Top_Level;
15250 ---------------------------
15251 -- Finalize_Storage_Only --
15252 ---------------------------
15254 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15256 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
15257 Assoc : constant Node_Id := Arg1;
15258 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
15263 Check_No_Identifiers;
15264 Check_Arg_Count (1);
15265 Check_Arg_Is_Local_Name (Arg1);
15267 Find_Type (Type_Id);
15268 Typ := Entity (Type_Id);
15271 or else Rep_Item_Too_Early (Typ, N)
15275 Typ := Underlying_Type (Typ);
15278 if not Is_Controlled (Typ) then
15279 Error_Pragma ("pragma% must specify controlled type");
15282 Check_First_Subtype (Arg1);
15284 if Finalize_Storage_Only (Typ) then
15285 Error_Pragma ("duplicate pragma%, only one allowed");
15287 elsif not Rep_Item_Too_Late (Typ, N) then
15288 Set_Finalize_Storage_Only (Base_Type (Typ), True);
15290 end Finalize_Storage;
15296 -- pragma Ghost [ (boolean_EXPRESSION) ];
15298 when Pragma_Ghost => Ghost : declare
15302 Orig_Stmt : Node_Id;
15303 Prev_Id : Entity_Id;
15308 Check_No_Identifiers;
15309 Check_At_Most_N_Arguments (1);
15313 while Present (Stmt) loop
15315 -- Skip prior pragmas, but check for duplicates
15317 if Nkind (Stmt) = N_Pragma then
15318 if Pragma_Name (Stmt) = Pname then
15319 Error_Msg_Name_1 := Pname;
15320 Error_Msg_Sloc := Sloc (Stmt);
15321 Error_Msg_N ("pragma % duplicates pragma declared#", N);
15324 -- Task unit declared without a definition cannot be subject to
15325 -- pragma Ghost (SPARK RM 6.9(19)).
15327 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15328 N_Task_Type_Declaration)
15330 Error_Pragma ("pragma % cannot apply to a task type");
15333 -- Skip internally generated code
15335 elsif not Comes_From_Source (Stmt) then
15336 Orig_Stmt := Original_Node (Stmt);
15338 -- When pragma Ghost applies to an untagged derivation, the
15339 -- derivation is transformed into a [sub]type declaration.
15341 if Nkind_In (Stmt, N_Full_Type_Declaration,
15342 N_Subtype_Declaration)
15343 and then Comes_From_Source (Orig_Stmt)
15344 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15345 and then Nkind (Type_Definition (Orig_Stmt)) =
15346 N_Derived_Type_Definition
15348 Id := Defining_Entity (Stmt);
15351 -- When pragma Ghost applies to an object declaration which
15352 -- is initialized by means of a function call that returns
15353 -- on the secondary stack, the object declaration becomes a
15356 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15357 and then Comes_From_Source (Orig_Stmt)
15358 and then Nkind (Orig_Stmt) = N_Object_Declaration
15360 Id := Defining_Entity (Stmt);
15363 -- When pragma Ghost applies to an expression function, the
15364 -- expression function is transformed into a subprogram.
15366 elsif Nkind (Stmt) = N_Subprogram_Declaration
15367 and then Comes_From_Source (Orig_Stmt)
15368 and then Nkind (Orig_Stmt) = N_Expression_Function
15370 Id := Defining_Entity (Stmt);
15374 -- The pragma applies to a legal construct, stop the traversal
15376 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15377 N_Full_Type_Declaration,
15378 N_Generic_Subprogram_Declaration,
15379 N_Object_Declaration,
15380 N_Private_Extension_Declaration,
15381 N_Private_Type_Declaration,
15382 N_Subprogram_Declaration,
15383 N_Subtype_Declaration)
15385 Id := Defining_Entity (Stmt);
15388 -- The pragma does not apply to a legal construct, issue an
15389 -- error and stop the analysis.
15393 ("pragma % must apply to an object, package, subprogram "
15398 Stmt := Prev (Stmt);
15401 Context := Parent (N);
15403 -- Handle compilation units
15405 if Nkind (Context) = N_Compilation_Unit_Aux then
15406 Context := Unit (Parent (Context));
15409 -- Protected and task types cannot be subject to pragma Ghost
15410 -- (SPARK RM 6.9(19)).
15412 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15414 Error_Pragma ("pragma % cannot apply to a protected type");
15417 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15418 Error_Pragma ("pragma % cannot apply to a task type");
15424 -- When pragma Ghost is associated with a [generic] package, it
15425 -- appears in the visible declarations.
15427 if Nkind (Context) = N_Package_Specification
15428 and then Present (Visible_Declarations (Context))
15429 and then List_Containing (N) = Visible_Declarations (Context)
15431 Id := Defining_Entity (Context);
15433 -- Pragma Ghost applies to a stand alone subprogram body
15435 elsif Nkind (Context) = N_Subprogram_Body
15436 and then No (Corresponding_Spec (Context))
15438 Id := Defining_Entity (Context);
15440 -- Pragma Ghost applies to a subprogram declaration that acts
15441 -- as a compilation unit.
15443 elsif Nkind (Context) = N_Subprogram_Declaration then
15444 Id := Defining_Entity (Context);
15450 ("pragma % must apply to an object, package, subprogram or "
15455 -- Handle completions of types and constants that are subject to
15458 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15459 Prev_Id := Incomplete_Or_Partial_View (Id);
15461 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15462 Error_Msg_Name_1 := Pname;
15464 -- The full declaration of a deferred constant cannot be
15465 -- subject to pragma Ghost unless the deferred declaration
15466 -- is also Ghost (SPARK RM 6.9(9)).
15468 if Ekind (Prev_Id) = E_Constant then
15469 Error_Msg_Name_1 := Pname;
15470 Error_Msg_NE (Fix_Error
15471 ("pragma % must apply to declaration of deferred "
15472 & "constant &"), N, Id);
15475 -- Pragma Ghost may appear on the full view of an incomplete
15476 -- type because the incomplete declaration lacks aspects and
15477 -- cannot be subject to pragma Ghost.
15479 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15482 -- The full declaration of a type cannot be subject to
15483 -- pragma Ghost unless the partial view is also Ghost
15484 -- (SPARK RM 6.9(9)).
15487 Error_Msg_NE (Fix_Error
15488 ("pragma % must apply to partial view of type &"),
15494 -- A synchronized object cannot be subject to pragma Ghost
15495 -- (SPARK RM 6.9(19)).
15497 elsif Ekind (Id) = E_Variable then
15498 if Is_Protected_Type (Etype (Id)) then
15499 Error_Pragma ("pragma % cannot apply to a protected object");
15502 elsif Is_Task_Type (Etype (Id)) then
15503 Error_Pragma ("pragma % cannot apply to a task object");
15508 -- Analyze the Boolean expression (if any)
15510 if Present (Arg1) then
15511 Expr := Get_Pragma_Arg (Arg1);
15513 Analyze_And_Resolve (Expr, Standard_Boolean);
15515 if Is_OK_Static_Expression (Expr) then
15517 -- "Ghostness" cannot be turned off once enabled within a
15518 -- region (SPARK RM 6.9(6)).
15520 if Is_False (Expr_Value (Expr))
15521 and then Ghost_Mode > None
15524 ("pragma % with value False cannot appear in enabled "
15529 -- Otherwie the expression is not static
15533 ("expression of pragma % must be static", Expr);
15538 Set_Is_Ghost_Entity (Id);
15545 -- pragma Global (GLOBAL_SPECIFICATION);
15547 -- GLOBAL_SPECIFICATION ::=
15550 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15552 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15554 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15555 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15556 -- GLOBAL_ITEM ::= NAME
15558 -- Characteristics:
15560 -- * Analysis - The annotation undergoes initial checks to verify
15561 -- the legal placement and context. Secondary checks fully analyze
15562 -- the dependency clauses in:
15564 -- Analyze_Global_In_Decl_Part
15566 -- * Expansion - None.
15568 -- * Template - The annotation utilizes the generic template of the
15569 -- related subprogram [body] when it is:
15571 -- aspect on subprogram declaration
15572 -- aspect on stand alone subprogram body
15573 -- pragma on stand alone subprogram body
15575 -- The annotation must prepare its own template when it is:
15577 -- pragma on subprogram declaration
15579 -- * Globals - Capture of global references must occur after full
15582 -- * Instance - The annotation is instantiated automatically when
15583 -- the related generic subprogram [body] is instantiated except for
15584 -- the "pragma on subprogram declaration" case. In that scenario
15585 -- the annotation must instantiate itself.
15587 when Pragma_Global => Global : declare
15589 Spec_Id : Entity_Id;
15590 Subp_Decl : Node_Id;
15593 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15597 -- Chain the pragma on the contract for further processing by
15598 -- Analyze_Global_In_Decl_Part.
15600 Add_Contract_Item (N, Spec_Id);
15602 -- Fully analyze the pragma when it appears inside an entry
15603 -- or subprogram body because it cannot benefit from forward
15606 if Nkind_In (Subp_Decl, N_Entry_Body,
15608 N_Subprogram_Body_Stub)
15610 -- The legality checks of pragmas Depends and Global are
15611 -- affected by the SPARK mode in effect and the volatility
15612 -- of the context. In addition these two pragmas are subject
15613 -- to an inherent order:
15618 -- Analyze all these pragmas in the order outlined above
15620 Analyze_If_Present (Pragma_SPARK_Mode);
15621 Analyze_If_Present (Pragma_Volatile_Function);
15622 Analyze_Global_In_Decl_Part (N);
15623 Analyze_If_Present (Pragma_Depends);
15632 -- pragma Ident (static_string_EXPRESSION)
15634 -- Note: pragma Comment shares this processing. Pragma Ident is
15635 -- identical in effect to pragma Commment.
15637 when Pragma_Ident | Pragma_Comment => Ident : declare
15642 Check_Arg_Count (1);
15643 Check_No_Identifiers;
15644 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15647 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15654 GP := Parent (Parent (N));
15656 if Nkind_In (GP, N_Package_Declaration,
15657 N_Generic_Package_Declaration)
15662 -- If we have a compilation unit, then record the ident value,
15663 -- checking for improper duplication.
15665 if Nkind (GP) = N_Compilation_Unit then
15666 CS := Ident_String (Current_Sem_Unit);
15668 if Present (CS) then
15670 -- If we have multiple instances, concatenate them, but
15671 -- not in ASIS, where we want the original tree.
15673 if not ASIS_Mode then
15674 Start_String (Strval (CS));
15675 Store_String_Char (' ');
15676 Store_String_Chars (Strval (Str));
15677 Set_Strval (CS, End_String);
15681 Set_Ident_String (Current_Sem_Unit, Str);
15684 -- For subunits, we just ignore the Ident, since in GNAT these
15685 -- are not separate object files, and hence not separate units
15686 -- in the unit table.
15688 elsif Nkind (GP) = N_Subunit then
15694 -------------------
15695 -- Ignore_Pragma --
15696 -------------------
15698 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15700 -- Entirely handled in the parser, nothing to do here
15702 when Pragma_Ignore_Pragma =>
15705 ----------------------------
15706 -- Implementation_Defined --
15707 ----------------------------
15709 -- pragma Implementation_Defined (LOCAL_NAME);
15711 -- Marks previously declared entity as implementation defined. For
15712 -- an overloaded entity, applies to the most recent homonym.
15714 -- pragma Implementation_Defined;
15716 -- The form with no arguments appears anywhere within a scope, most
15717 -- typically a package spec, and indicates that all entities that are
15718 -- defined within the package spec are Implementation_Defined.
15720 when Pragma_Implementation_Defined => Implementation_Defined : declare
15725 Check_No_Identifiers;
15727 -- Form with no arguments
15729 if Arg_Count = 0 then
15730 Set_Is_Implementation_Defined (Current_Scope);
15732 -- Form with one argument
15735 Check_Arg_Count (1);
15736 Check_Arg_Is_Local_Name (Arg1);
15737 Ent := Entity (Get_Pragma_Arg (Arg1));
15738 Set_Is_Implementation_Defined (Ent);
15740 end Implementation_Defined;
15746 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15748 -- IMPLEMENTATION_KIND ::=
15749 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15751 -- "By_Any" and "Optional" are treated as synonyms in order to
15752 -- support Ada 2012 aspect Synchronization.
15754 when Pragma_Implemented => Implemented : declare
15755 Proc_Id : Entity_Id;
15760 Check_Arg_Count (2);
15761 Check_No_Identifiers;
15762 Check_Arg_Is_Identifier (Arg1);
15763 Check_Arg_Is_Local_Name (Arg1);
15764 Check_Arg_Is_One_Of (Arg2,
15767 Name_By_Protected_Procedure,
15770 -- Extract the name of the local procedure
15772 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15774 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15775 -- primitive procedure of a synchronized tagged type.
15777 if Ekind (Proc_Id) = E_Procedure
15778 and then Is_Primitive (Proc_Id)
15779 and then Present (First_Formal (Proc_Id))
15781 Typ := Etype (First_Formal (Proc_Id));
15783 if Is_Tagged_Type (Typ)
15786 -- Check for a protected, a synchronized or a task interface
15788 ((Is_Interface (Typ)
15789 and then Is_Synchronized_Interface (Typ))
15791 -- Check for a protected type or a task type that implements
15795 (Is_Concurrent_Record_Type (Typ)
15796 and then Present (Interfaces (Typ)))
15798 -- In analysis-only mode, examine original protected type
15801 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15802 and then Present (Interface_List (Parent (Typ))))
15804 -- Check for a private record extension with keyword
15808 (Ekind_In (Typ, E_Record_Type_With_Private,
15809 E_Record_Subtype_With_Private)
15810 and then Synchronized_Present (Parent (Typ))))
15815 ("controlling formal must be of synchronized tagged type",
15820 -- Procedures declared inside a protected type must be accepted
15822 elsif Ekind (Proc_Id) = E_Procedure
15823 and then Is_Protected_Type (Scope (Proc_Id))
15827 -- The first argument is not a primitive procedure
15831 ("pragma % must be applied to a primitive procedure", Arg1);
15835 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15836 -- By_Protected_Procedure to the primitive procedure of a task
15839 if Chars (Arg2) = Name_By_Protected_Procedure
15840 and then Is_Interface (Typ)
15841 and then Is_Task_Interface (Typ)
15844 ("implementation kind By_Protected_Procedure cannot be "
15845 & "applied to a task interface primitive", Arg2);
15849 Record_Rep_Item (Proc_Id, N);
15852 ----------------------
15853 -- Implicit_Packing --
15854 ----------------------
15856 -- pragma Implicit_Packing;
15858 when Pragma_Implicit_Packing =>
15860 Check_Arg_Count (0);
15861 Implicit_Packing := True;
15868 -- [Convention =>] convention_IDENTIFIER,
15869 -- [Entity =>] LOCAL_NAME
15870 -- [, [External_Name =>] static_string_EXPRESSION ]
15871 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15873 when Pragma_Import =>
15874 Check_Ada_83_Warning;
15878 Name_External_Name,
15881 Check_At_Least_N_Arguments (2);
15882 Check_At_Most_N_Arguments (4);
15883 Process_Import_Or_Interface;
15885 ---------------------
15886 -- Import_Function --
15887 ---------------------
15889 -- pragma Import_Function (
15890 -- [Internal =>] LOCAL_NAME,
15891 -- [, [External =>] EXTERNAL_SYMBOL]
15892 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15893 -- [, [Result_Type =>] SUBTYPE_MARK]
15894 -- [, [Mechanism =>] MECHANISM]
15895 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15897 -- EXTERNAL_SYMBOL ::=
15899 -- | static_string_EXPRESSION
15901 -- PARAMETER_TYPES ::=
15903 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15905 -- TYPE_DESIGNATOR ::=
15907 -- | subtype_Name ' Access
15911 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15913 -- MECHANISM_ASSOCIATION ::=
15914 -- [formal_parameter_NAME =>] MECHANISM_NAME
15916 -- MECHANISM_NAME ::=
15920 when Pragma_Import_Function => Import_Function : declare
15921 Args : Args_List (1 .. 6);
15922 Names : constant Name_List (1 .. 6) := (
15925 Name_Parameter_Types,
15928 Name_Result_Mechanism);
15930 Internal : Node_Id renames Args (1);
15931 External : Node_Id renames Args (2);
15932 Parameter_Types : Node_Id renames Args (3);
15933 Result_Type : Node_Id renames Args (4);
15934 Mechanism : Node_Id renames Args (5);
15935 Result_Mechanism : Node_Id renames Args (6);
15939 Gather_Associations (Names, Args);
15940 Process_Extended_Import_Export_Subprogram_Pragma (
15941 Arg_Internal => Internal,
15942 Arg_External => External,
15943 Arg_Parameter_Types => Parameter_Types,
15944 Arg_Result_Type => Result_Type,
15945 Arg_Mechanism => Mechanism,
15946 Arg_Result_Mechanism => Result_Mechanism);
15947 end Import_Function;
15949 -------------------
15950 -- Import_Object --
15951 -------------------
15953 -- pragma Import_Object (
15954 -- [Internal =>] LOCAL_NAME
15955 -- [, [External =>] EXTERNAL_SYMBOL]
15956 -- [, [Size =>] EXTERNAL_SYMBOL]);
15958 -- EXTERNAL_SYMBOL ::=
15960 -- | static_string_EXPRESSION
15962 when Pragma_Import_Object => Import_Object : declare
15963 Args : Args_List (1 .. 3);
15964 Names : constant Name_List (1 .. 3) := (
15969 Internal : Node_Id renames Args (1);
15970 External : Node_Id renames Args (2);
15971 Size : Node_Id renames Args (3);
15975 Gather_Associations (Names, Args);
15976 Process_Extended_Import_Export_Object_Pragma (
15977 Arg_Internal => Internal,
15978 Arg_External => External,
15982 ----------------------
15983 -- Import_Procedure --
15984 ----------------------
15986 -- pragma Import_Procedure (
15987 -- [Internal =>] LOCAL_NAME
15988 -- [, [External =>] EXTERNAL_SYMBOL]
15989 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15990 -- [, [Mechanism =>] MECHANISM]);
15992 -- EXTERNAL_SYMBOL ::=
15994 -- | static_string_EXPRESSION
15996 -- PARAMETER_TYPES ::=
15998 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16000 -- TYPE_DESIGNATOR ::=
16002 -- | subtype_Name ' Access
16006 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16008 -- MECHANISM_ASSOCIATION ::=
16009 -- [formal_parameter_NAME =>] MECHANISM_NAME
16011 -- MECHANISM_NAME ::=
16015 when Pragma_Import_Procedure => Import_Procedure : declare
16016 Args : Args_List (1 .. 4);
16017 Names : constant Name_List (1 .. 4) := (
16020 Name_Parameter_Types,
16023 Internal : Node_Id renames Args (1);
16024 External : Node_Id renames Args (2);
16025 Parameter_Types : Node_Id renames Args (3);
16026 Mechanism : Node_Id renames Args (4);
16030 Gather_Associations (Names, Args);
16031 Process_Extended_Import_Export_Subprogram_Pragma (
16032 Arg_Internal => Internal,
16033 Arg_External => External,
16034 Arg_Parameter_Types => Parameter_Types,
16035 Arg_Mechanism => Mechanism);
16036 end Import_Procedure;
16038 -----------------------------
16039 -- Import_Valued_Procedure --
16040 -----------------------------
16042 -- pragma Import_Valued_Procedure (
16043 -- [Internal =>] LOCAL_NAME
16044 -- [, [External =>] EXTERNAL_SYMBOL]
16045 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16046 -- [, [Mechanism =>] MECHANISM]);
16048 -- EXTERNAL_SYMBOL ::=
16050 -- | static_string_EXPRESSION
16052 -- PARAMETER_TYPES ::=
16054 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16056 -- TYPE_DESIGNATOR ::=
16058 -- | subtype_Name ' Access
16062 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16064 -- MECHANISM_ASSOCIATION ::=
16065 -- [formal_parameter_NAME =>] MECHANISM_NAME
16067 -- MECHANISM_NAME ::=
16071 when Pragma_Import_Valued_Procedure =>
16072 Import_Valued_Procedure : declare
16073 Args : Args_List (1 .. 4);
16074 Names : constant Name_List (1 .. 4) := (
16077 Name_Parameter_Types,
16080 Internal : Node_Id renames Args (1);
16081 External : Node_Id renames Args (2);
16082 Parameter_Types : Node_Id renames Args (3);
16083 Mechanism : Node_Id renames Args (4);
16087 Gather_Associations (Names, Args);
16088 Process_Extended_Import_Export_Subprogram_Pragma (
16089 Arg_Internal => Internal,
16090 Arg_External => External,
16091 Arg_Parameter_Types => Parameter_Types,
16092 Arg_Mechanism => Mechanism);
16093 end Import_Valued_Procedure;
16099 -- pragma Independent (LOCAL_NAME);
16101 when Pragma_Independent =>
16102 Process_Atomic_Independent_Shared_Volatile;
16104 ----------------------------
16105 -- Independent_Components --
16106 ----------------------------
16108 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16110 when Pragma_Independent_Components => Independent_Components : declare
16118 Check_Ada_83_Warning;
16120 Check_No_Identifiers;
16121 Check_Arg_Count (1);
16122 Check_Arg_Is_Local_Name (Arg1);
16123 E_Id := Get_Pragma_Arg (Arg1);
16125 if Etype (E_Id) = Any_Type then
16129 E := Entity (E_Id);
16131 -- A pragma that applies to a Ghost entity becomes Ghost for the
16132 -- purposes of legality checks and removal of ignored Ghost code.
16134 Mark_Pragma_As_Ghost (N, E);
16136 -- Check duplicate before we chain ourselves
16138 Check_Duplicate_Pragma (E);
16140 -- Check appropriate entity
16142 if Rep_Item_Too_Early (E, N)
16144 Rep_Item_Too_Late (E, N)
16149 D := Declaration_Node (E);
16152 -- The flag is set on the base type, or on the object
16154 if K = N_Full_Type_Declaration
16155 and then (Is_Array_Type (E) or else Is_Record_Type (E))
16157 Set_Has_Independent_Components (Base_Type (E));
16158 Record_Independence_Check (N, Base_Type (E));
16160 -- For record type, set all components independent
16162 if Is_Record_Type (E) then
16163 C := First_Component (E);
16164 while Present (C) loop
16165 Set_Is_Independent (C);
16166 Next_Component (C);
16170 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
16171 and then Nkind (D) = N_Object_Declaration
16172 and then Nkind (Object_Definition (D)) =
16173 N_Constrained_Array_Definition
16175 Set_Has_Independent_Components (E);
16176 Record_Independence_Check (N, E);
16179 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
16181 end Independent_Components;
16183 -----------------------
16184 -- Initial_Condition --
16185 -----------------------
16187 -- pragma Initial_Condition (boolean_EXPRESSION);
16189 -- Characteristics:
16191 -- * Analysis - The annotation undergoes initial checks to verify
16192 -- the legal placement and context. Secondary checks preanalyze the
16195 -- Analyze_Initial_Condition_In_Decl_Part
16197 -- * Expansion - The annotation is expanded during the expansion of
16198 -- the package body whose declaration is subject to the annotation
16201 -- Expand_Pragma_Initial_Condition
16203 -- * Template - The annotation utilizes the generic template of the
16204 -- related package declaration.
16206 -- * Globals - Capture of global references must occur after full
16209 -- * Instance - The annotation is instantiated automatically when
16210 -- the related generic package is instantiated.
16212 when Pragma_Initial_Condition => Initial_Condition : declare
16213 Pack_Decl : Node_Id;
16214 Pack_Id : Entity_Id;
16218 Check_No_Identifiers;
16219 Check_Arg_Count (1);
16221 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16223 -- Ensure the proper placement of the pragma. Initial_Condition
16224 -- must be associated with a package declaration.
16226 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16227 N_Package_Declaration)
16231 -- Otherwise the pragma is associated with an illegal context
16238 Pack_Id := Defining_Entity (Pack_Decl);
16240 -- Chain the pragma on the contract for further processing by
16241 -- Analyze_Initial_Condition_In_Decl_Part.
16243 Add_Contract_Item (N, Pack_Id);
16245 -- The legality checks of pragmas Abstract_State, Initializes, and
16246 -- Initial_Condition are affected by the SPARK mode in effect. In
16247 -- addition, these three pragmas are subject to an inherent order:
16249 -- 1) Abstract_State
16251 -- 3) Initial_Condition
16253 -- Analyze all these pragmas in the order outlined above
16255 Analyze_If_Present (Pragma_SPARK_Mode);
16256 Analyze_If_Present (Pragma_Abstract_State);
16257 Analyze_If_Present (Pragma_Initializes);
16259 -- A pragma that applies to a Ghost entity becomes Ghost for the
16260 -- purposes of legality checks and removal of ignored Ghost code.
16262 Mark_Pragma_As_Ghost (N, Pack_Id);
16263 end Initial_Condition;
16265 ------------------------
16266 -- Initialize_Scalars --
16267 ------------------------
16269 -- pragma Initialize_Scalars;
16271 when Pragma_Initialize_Scalars =>
16273 Check_Arg_Count (0);
16274 Check_Valid_Configuration_Pragma;
16275 Check_Restriction (No_Initialize_Scalars, N);
16277 -- Initialize_Scalars creates false positives in CodePeer, and
16278 -- incorrect negative results in GNATprove mode, so ignore this
16279 -- pragma in these modes.
16281 if not Restriction_Active (No_Initialize_Scalars)
16282 and then not (CodePeer_Mode or GNATprove_Mode)
16284 Init_Or_Norm_Scalars := True;
16285 Initialize_Scalars := True;
16292 -- pragma Initializes (INITIALIZATION_LIST);
16294 -- INITIALIZATION_LIST ::=
16296 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16298 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16303 -- | (INPUT {, INPUT})
16307 -- Characteristics:
16309 -- * Analysis - The annotation undergoes initial checks to verify
16310 -- the legal placement and context. Secondary checks preanalyze the
16313 -- Analyze_Initializes_In_Decl_Part
16315 -- * Expansion - None.
16317 -- * Template - The annotation utilizes the generic template of the
16318 -- related package declaration.
16320 -- * Globals - Capture of global references must occur after full
16323 -- * Instance - The annotation is instantiated automatically when
16324 -- the related generic package is instantiated.
16326 when Pragma_Initializes => Initializes : declare
16327 Pack_Decl : Node_Id;
16328 Pack_Id : Entity_Id;
16332 Check_No_Identifiers;
16333 Check_Arg_Count (1);
16335 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16337 -- Ensure the proper placement of the pragma. Initializes must be
16338 -- associated with a package declaration.
16340 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16341 N_Package_Declaration)
16345 -- Otherwise the pragma is associated with an illegal construc
16352 Pack_Id := Defining_Entity (Pack_Decl);
16354 -- Chain the pragma on the contract for further processing by
16355 -- Analyze_Initializes_In_Decl_Part.
16357 Add_Contract_Item (N, Pack_Id);
16359 -- The legality checks of pragmas Abstract_State, Initializes, and
16360 -- Initial_Condition are affected by the SPARK mode in effect. In
16361 -- addition, these three pragmas are subject to an inherent order:
16363 -- 1) Abstract_State
16365 -- 3) Initial_Condition
16367 -- Analyze all these pragmas in the order outlined above
16369 Analyze_If_Present (Pragma_SPARK_Mode);
16370 Analyze_If_Present (Pragma_Abstract_State);
16372 -- A pragma that applies to a Ghost entity becomes Ghost for the
16373 -- purposes of legality checks and removal of ignored Ghost code.
16375 Mark_Pragma_As_Ghost (N, Pack_Id);
16376 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16378 Analyze_If_Present (Pragma_Initial_Condition);
16385 -- pragma Inline ( NAME {, NAME} );
16387 when Pragma_Inline =>
16389 -- Pragma always active unless in GNATprove mode. It is disabled
16390 -- in GNATprove mode because frontend inlining is applied
16391 -- independently of pragmas Inline and Inline_Always for
16392 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16395 if not GNATprove_Mode then
16397 -- Inline status is Enabled if option -gnatn is specified.
16398 -- However this status determines only the value of the
16399 -- Is_Inlined flag on the subprogram and does not prevent
16400 -- the pragma itself from being recorded for later use,
16401 -- in particular for a later modification of Is_Inlined
16402 -- independently of the -gnatn option.
16404 -- In other words, if -gnatn is specified for a unit, then
16405 -- all Inline pragmas processed for the compilation of this
16406 -- unit, including those in the spec of other units, are
16407 -- activated, so subprograms will be inlined across units.
16409 -- If -gnatn is not specified, no Inline pragma is activated
16410 -- here, which means that subprograms will not be inlined
16411 -- across units. The Is_Inlined flag will nevertheless be
16412 -- set later when bodies are analyzed, so subprograms will
16413 -- be inlined within the unit.
16415 if Inline_Active then
16416 Process_Inline (Enabled);
16418 Process_Inline (Disabled);
16422 -------------------
16423 -- Inline_Always --
16424 -------------------
16426 -- pragma Inline_Always ( NAME {, NAME} );
16428 when Pragma_Inline_Always =>
16431 -- Pragma always active unless in CodePeer mode or GNATprove
16432 -- mode. It is disabled in CodePeer mode because inlining is
16433 -- not helpful, and enabling it caused walk order issues. It
16434 -- is disabled in GNATprove mode because frontend inlining is
16435 -- applied independently of pragmas Inline and Inline_Always for
16436 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16439 if not CodePeer_Mode and not GNATprove_Mode then
16440 Process_Inline (Enabled);
16443 --------------------
16444 -- Inline_Generic --
16445 --------------------
16447 -- pragma Inline_Generic (NAME {, NAME});
16449 when Pragma_Inline_Generic =>
16451 Process_Generic_List;
16453 ----------------------
16454 -- Inspection_Point --
16455 ----------------------
16457 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16459 when Pragma_Inspection_Point => Inspection_Point : declare
16466 if Arg_Count > 0 then
16469 Exp := Get_Pragma_Arg (Arg);
16472 if not Is_Entity_Name (Exp)
16473 or else not Is_Object (Entity (Exp))
16475 Error_Pragma_Arg ("object name required", Arg);
16479 exit when No (Arg);
16482 end Inspection_Point;
16488 -- pragma Interface (
16489 -- [ Convention =>] convention_IDENTIFIER,
16490 -- [ Entity =>] LOCAL_NAME
16491 -- [, [External_Name =>] static_string_EXPRESSION ]
16492 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16494 when Pragma_Interface =>
16499 Name_External_Name,
16501 Check_At_Least_N_Arguments (2);
16502 Check_At_Most_N_Arguments (4);
16503 Process_Import_Or_Interface;
16505 -- In Ada 2005, the permission to use Interface (a reserved word)
16506 -- as a pragma name is considered an obsolescent feature, and this
16507 -- pragma was already obsolescent in Ada 95.
16509 if Ada_Version >= Ada_95 then
16511 (No_Obsolescent_Features, Pragma_Identifier (N));
16513 if Warn_On_Obsolescent_Feature then
16515 ("pragma Interface is an obsolescent feature?j?", N);
16517 ("|use pragma Import instead?j?", N);
16521 --------------------
16522 -- Interface_Name --
16523 --------------------
16525 -- pragma Interface_Name (
16526 -- [ Entity =>] LOCAL_NAME
16527 -- [,[External_Name =>] static_string_EXPRESSION ]
16528 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16530 when Pragma_Interface_Name => Interface_Name : declare
16532 Def_Id : Entity_Id;
16533 Hom_Id : Entity_Id;
16539 ((Name_Entity, Name_External_Name, Name_Link_Name));
16540 Check_At_Least_N_Arguments (2);
16541 Check_At_Most_N_Arguments (3);
16542 Id := Get_Pragma_Arg (Arg1);
16545 -- This is obsolete from Ada 95 on, but it is an implementation
16546 -- defined pragma, so we do not consider that it violates the
16547 -- restriction (No_Obsolescent_Features).
16549 if Ada_Version >= Ada_95 then
16550 if Warn_On_Obsolescent_Feature then
16552 ("pragma Interface_Name is an obsolescent feature?j?", N);
16554 ("|use pragma Import instead?j?", N);
16558 if not Is_Entity_Name (Id) then
16560 ("first argument for pragma% must be entity name", Arg1);
16561 elsif Etype (Id) = Any_Type then
16564 Def_Id := Entity (Id);
16567 -- Special DEC-compatible processing for the object case, forces
16568 -- object to be imported.
16570 if Ekind (Def_Id) = E_Variable then
16571 Kill_Size_Check_Code (Def_Id);
16572 Note_Possible_Modification (Id, Sure => False);
16574 -- Initialization is not allowed for imported variable
16576 if Present (Expression (Parent (Def_Id)))
16577 and then Comes_From_Source (Expression (Parent (Def_Id)))
16579 Error_Msg_Sloc := Sloc (Def_Id);
16581 ("no initialization allowed for declaration of& #",
16585 -- For compatibility, support VADS usage of providing both
16586 -- pragmas Interface and Interface_Name to obtain the effect
16587 -- of a single Import pragma.
16589 if Is_Imported (Def_Id)
16590 and then Present (First_Rep_Item (Def_Id))
16591 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16593 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
16597 Set_Imported (Def_Id);
16600 Set_Is_Public (Def_Id);
16601 Process_Interface_Name (Def_Id, Arg2, Arg3);
16604 -- Otherwise must be subprogram
16606 elsif not Is_Subprogram (Def_Id) then
16608 ("argument of pragma% is not subprogram", Arg1);
16611 Check_At_Most_N_Arguments (3);
16615 -- Loop through homonyms
16618 Def_Id := Get_Base_Subprogram (Hom_Id);
16620 if Is_Imported (Def_Id) then
16621 Process_Interface_Name (Def_Id, Arg2, Arg3);
16625 exit when From_Aspect_Specification (N);
16626 Hom_Id := Homonym (Hom_Id);
16628 exit when No (Hom_Id)
16629 or else Scope (Hom_Id) /= Current_Scope;
16634 ("argument of pragma% is not imported subprogram",
16638 end Interface_Name;
16640 -----------------------
16641 -- Interrupt_Handler --
16642 -----------------------
16644 -- pragma Interrupt_Handler (handler_NAME);
16646 when Pragma_Interrupt_Handler =>
16647 Check_Ada_83_Warning;
16648 Check_Arg_Count (1);
16649 Check_No_Identifiers;
16651 if No_Run_Time_Mode then
16652 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16654 Check_Interrupt_Or_Attach_Handler;
16655 Process_Interrupt_Or_Attach_Handler;
16658 ------------------------
16659 -- Interrupt_Priority --
16660 ------------------------
16662 -- pragma Interrupt_Priority [(EXPRESSION)];
16664 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16665 P : constant Node_Id := Parent (N);
16670 Check_Ada_83_Warning;
16672 if Arg_Count /= 0 then
16673 Arg := Get_Pragma_Arg (Arg1);
16674 Check_Arg_Count (1);
16675 Check_No_Identifiers;
16677 -- The expression must be analyzed in the special manner
16678 -- described in "Handling of Default and Per-Object
16679 -- Expressions" in sem.ads.
16681 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16684 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16689 Ent := Defining_Identifier (Parent (P));
16691 -- Check duplicate pragma before we chain the pragma in the Rep
16692 -- Item chain of Ent.
16694 Check_Duplicate_Pragma (Ent);
16695 Record_Rep_Item (Ent, N);
16697 -- Check the No_Task_At_Interrupt_Priority restriction
16699 if Nkind (P) = N_Task_Definition then
16700 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16703 end Interrupt_Priority;
16705 ---------------------
16706 -- Interrupt_State --
16707 ---------------------
16709 -- pragma Interrupt_State (
16710 -- [Name =>] INTERRUPT_ID,
16711 -- [State =>] INTERRUPT_STATE);
16713 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16714 -- INTERRUPT_STATE => System | Runtime | User
16716 -- Note: if the interrupt id is given as an identifier, then it must
16717 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16718 -- given as a static integer expression which must be in the range of
16719 -- Ada.Interrupts.Interrupt_ID.
16721 when Pragma_Interrupt_State => Interrupt_State : declare
16722 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16723 -- This is the entity Ada.Interrupts.Interrupt_ID;
16725 State_Type : Character;
16726 -- Set to 's'/'r'/'u' for System/Runtime/User
16729 -- Index to entry in Interrupt_States table
16732 -- Value of interrupt
16734 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16735 -- The first argument to the pragma
16737 Int_Ent : Entity_Id;
16738 -- Interrupt entity in Ada.Interrupts.Names
16742 Check_Arg_Order ((Name_Name, Name_State));
16743 Check_Arg_Count (2);
16745 Check_Optional_Identifier (Arg1, Name_Name);
16746 Check_Optional_Identifier (Arg2, Name_State);
16747 Check_Arg_Is_Identifier (Arg2);
16749 -- First argument is identifier
16751 if Nkind (Arg1X) = N_Identifier then
16753 -- Search list of names in Ada.Interrupts.Names
16755 Int_Ent := First_Entity (RTE (RE_Names));
16757 if No (Int_Ent) then
16758 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16760 elsif Chars (Int_Ent) = Chars (Arg1X) then
16761 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16765 Next_Entity (Int_Ent);
16768 -- First argument is not an identifier, so it must be a static
16769 -- expression of type Ada.Interrupts.Interrupt_ID.
16772 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16773 Int_Val := Expr_Value (Arg1X);
16775 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16777 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16780 ("value not in range of type "
16781 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16787 case Chars (Get_Pragma_Arg (Arg2)) is
16788 when Name_Runtime => State_Type := 'r';
16789 when Name_System => State_Type := 's';
16790 when Name_User => State_Type := 'u';
16793 Error_Pragma_Arg ("invalid interrupt state", Arg2);
16796 -- Check if entry is already stored
16798 IST_Num := Interrupt_States.First;
16800 -- If entry not found, add it
16802 if IST_Num > Interrupt_States.Last then
16803 Interrupt_States.Append
16804 ((Interrupt_Number => UI_To_Int (Int_Val),
16805 Interrupt_State => State_Type,
16806 Pragma_Loc => Loc));
16809 -- Case of entry for the same entry
16811 elsif Int_Val = Interrupt_States.Table (IST_Num).
16814 -- If state matches, done, no need to make redundant entry
16817 State_Type = Interrupt_States.Table (IST_Num).
16820 -- Otherwise if state does not match, error
16823 Interrupt_States.Table (IST_Num).Pragma_Loc;
16825 ("state conflicts with that given #", Arg2);
16829 IST_Num := IST_Num + 1;
16831 end Interrupt_State;
16837 -- pragma Invariant
16838 -- ([Entity =>] type_LOCAL_NAME,
16839 -- [Check =>] EXPRESSION
16840 -- [,[Message =>] String_Expression]);
16842 when Pragma_Invariant => Invariant : declare
16847 CRec_Typ : Entity_Id;
16848 -- The corresponding record type of Full_Typ
16850 Full_Base : Entity_Id;
16851 -- The base type of Full_Typ
16853 Full_Typ : Entity_Id;
16854 -- The full view of Typ
16856 Priv_Typ : Entity_Id;
16857 -- The partial view of Typ
16861 Check_At_Least_N_Arguments (2);
16862 Check_At_Most_N_Arguments (3);
16863 Check_Optional_Identifier (Arg1, Name_Entity);
16864 Check_Optional_Identifier (Arg2, Name_Check);
16866 if Arg_Count = 3 then
16867 Check_Optional_Identifier (Arg3, Name_Message);
16868 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16871 Check_Arg_Is_Local_Name (Arg1);
16873 Typ_Arg := Get_Pragma_Arg (Arg1);
16874 Find_Type (Typ_Arg);
16875 Typ := Entity (Typ_Arg);
16877 -- Nothing to do of the related type is erroneous in some way
16879 if Typ = Any_Type then
16882 -- AI12-0041: Invariants are allowed in interface types
16884 elsif Is_Interface (Typ) then
16887 -- An invariant must apply to a private type, or appear in the
16888 -- private part of a package spec and apply to a completion.
16889 -- a class-wide invariant can only appear on a private declaration
16890 -- or private extension, not a completion.
16892 -- A [class-wide] invariant may be associated a [limited] private
16893 -- type or a private extension.
16895 elsif Ekind_In (Typ, E_Limited_Private_Type,
16897 E_Record_Type_With_Private)
16901 -- A non-class-wide invariant may be associated with the full view
16902 -- of a [limited] private type or a private extension.
16904 elsif Has_Private_Declaration (Typ)
16905 and then not Class_Present (N)
16909 -- A class-wide invariant may appear on the partial view only
16911 elsif Class_Present (N) then
16913 ("pragma % only allowed for private type", Arg1);
16916 -- A regular invariant may appear on both views
16920 ("pragma % only allowed for private type or corresponding "
16921 & "full view", Arg1);
16925 -- An invariant associated with an abstract type (this includes
16926 -- interfaces) must be class-wide.
16928 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16930 ("pragma % not allowed for abstract type", Arg1);
16934 -- A pragma that applies to a Ghost entity becomes Ghost for the
16935 -- purposes of legality checks and removal of ignored Ghost code.
16937 Mark_Pragma_As_Ghost (N, Typ);
16939 -- The pragma defines a type-specific invariant, the type is said
16940 -- to have invariants of its "own".
16942 Set_Has_Own_Invariants (Typ);
16944 -- If the invariant is class-wide, then it can be inherited by
16945 -- derived or interface implementing types. The type is said to
16946 -- have "inheritable" invariants.
16948 if Class_Present (N) then
16949 Set_Has_Inheritable_Invariants (Typ);
16952 Get_Views (Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
16954 -- Propagate invariant-related attributes to all views of the type
16955 -- and any additional types that may have been created.
16957 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Typ);
16958 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Typ);
16959 Propagate_Invariant_Attributes (Full_Base, From_Typ => Typ);
16960 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Typ);
16962 -- Chain the pragma on to the rep item chain, for processing when
16963 -- the type is frozen.
16965 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16967 -- Create the declaration of the invariant procedure which will
16968 -- verify the invariant at run-time. Note that interfaces do not
16969 -- carry such a declaration.
16971 Build_Invariant_Procedure_Declaration (Typ);
16978 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16980 when Pragma_Keep_Names => Keep_Names : declare
16985 Check_Arg_Count (1);
16986 Check_Optional_Identifier (Arg1, Name_On);
16987 Check_Arg_Is_Local_Name (Arg1);
16989 Arg := Get_Pragma_Arg (Arg1);
16992 if Etype (Arg) = Any_Type then
16996 if not Is_Entity_Name (Arg)
16997 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
17000 ("pragma% requires a local enumeration type", Arg1);
17003 Set_Discard_Names (Entity (Arg), False);
17010 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17012 when Pragma_License =>
17015 -- Do not analyze pragma any further in CodePeer mode, to avoid
17016 -- extraneous errors in this implementation-dependent pragma,
17017 -- which has a different profile on other compilers.
17019 if CodePeer_Mode then
17023 Check_Arg_Count (1);
17024 Check_No_Identifiers;
17025 Check_Valid_Configuration_Pragma;
17026 Check_Arg_Is_Identifier (Arg1);
17029 Sind : constant Source_File_Index :=
17030 Source_Index (Current_Sem_Unit);
17033 case Chars (Get_Pragma_Arg (Arg1)) is
17035 Set_License (Sind, GPL);
17037 when Name_Modified_GPL =>
17038 Set_License (Sind, Modified_GPL);
17040 when Name_Restricted =>
17041 Set_License (Sind, Restricted);
17043 when Name_Unrestricted =>
17044 Set_License (Sind, Unrestricted);
17047 Error_Pragma_Arg ("invalid license name", Arg1);
17055 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17057 when Pragma_Link_With => Link_With : declare
17063 if Operating_Mode = Generate_Code
17064 and then In_Extended_Main_Source_Unit (N)
17066 Check_At_Least_N_Arguments (1);
17067 Check_No_Identifiers;
17068 Check_Is_In_Decl_Part_Or_Package_Spec;
17069 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17073 while Present (Arg) loop
17074 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17076 -- Store argument, converting sequences of spaces to a
17077 -- single null character (this is one of the differences
17078 -- in processing between Link_With and Linker_Options).
17080 Arg_Store : declare
17081 C : constant Char_Code := Get_Char_Code (' ');
17082 S : constant String_Id :=
17083 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
17084 L : constant Nat := String_Length (S);
17087 procedure Skip_Spaces;
17088 -- Advance F past any spaces
17094 procedure Skip_Spaces is
17096 while F <= L and then Get_String_Char (S, F) = C loop
17101 -- Start of processing for Arg_Store
17104 Skip_Spaces; -- skip leading spaces
17106 -- Loop through characters, changing any embedded
17107 -- sequence of spaces to a single null character (this
17108 -- is how Link_With/Linker_Options differ)
17111 if Get_String_Char (S, F) = C then
17114 Store_String_Char (ASCII.NUL);
17117 Store_String_Char (Get_String_Char (S, F));
17125 if Present (Arg) then
17126 Store_String_Char (ASCII.NUL);
17130 Store_Linker_Option_String (End_String);
17138 -- pragma Linker_Alias (
17139 -- [Entity =>] LOCAL_NAME
17140 -- [Target =>] static_string_EXPRESSION);
17142 when Pragma_Linker_Alias =>
17144 Check_Arg_Order ((Name_Entity, Name_Target));
17145 Check_Arg_Count (2);
17146 Check_Optional_Identifier (Arg1, Name_Entity);
17147 Check_Optional_Identifier (Arg2, Name_Target);
17148 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17149 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17151 -- The only processing required is to link this item on to the
17152 -- list of rep items for the given entity. This is accomplished
17153 -- by the call to Rep_Item_Too_Late (when no error is detected
17154 -- and False is returned).
17156 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
17159 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17162 ------------------------
17163 -- Linker_Constructor --
17164 ------------------------
17166 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17168 -- Code is shared with Linker_Destructor
17170 -----------------------
17171 -- Linker_Destructor --
17172 -----------------------
17174 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17176 when Pragma_Linker_Constructor |
17177 Pragma_Linker_Destructor =>
17178 Linker_Constructor : declare
17184 Check_Arg_Count (1);
17185 Check_No_Identifiers;
17186 Check_Arg_Is_Local_Name (Arg1);
17187 Arg1_X := Get_Pragma_Arg (Arg1);
17189 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
17191 if not Is_Library_Level_Entity (Proc) then
17193 ("argument for pragma% must be library level entity", Arg1);
17196 -- The only processing required is to link this item on to the
17197 -- list of rep items for the given entity. This is accomplished
17198 -- by the call to Rep_Item_Too_Late (when no error is detected
17199 -- and False is returned).
17201 if Rep_Item_Too_Late (Proc, N) then
17204 Set_Has_Gigi_Rep_Item (Proc);
17206 end Linker_Constructor;
17208 --------------------
17209 -- Linker_Options --
17210 --------------------
17212 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17214 when Pragma_Linker_Options => Linker_Options : declare
17218 Check_Ada_83_Warning;
17219 Check_No_Identifiers;
17220 Check_Arg_Count (1);
17221 Check_Is_In_Decl_Part_Or_Package_Spec;
17222 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17223 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
17226 while Present (Arg) loop
17227 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17228 Store_String_Char (ASCII.NUL);
17230 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
17234 if Operating_Mode = Generate_Code
17235 and then In_Extended_Main_Source_Unit (N)
17237 Store_Linker_Option_String (End_String);
17239 end Linker_Options;
17241 --------------------
17242 -- Linker_Section --
17243 --------------------
17245 -- pragma Linker_Section (
17246 -- [Entity =>] LOCAL_NAME
17247 -- [Section =>] static_string_EXPRESSION);
17249 when Pragma_Linker_Section => Linker_Section : declare
17254 Ghost_Error_Posted : Boolean := False;
17255 -- Flag set when an error concerning the illegal mix of Ghost and
17256 -- non-Ghost subprograms is emitted.
17258 Ghost_Id : Entity_Id := Empty;
17259 -- The entity of the first Ghost subprogram encountered while
17260 -- processing the arguments of the pragma.
17264 Check_Arg_Order ((Name_Entity, Name_Section));
17265 Check_Arg_Count (2);
17266 Check_Optional_Identifier (Arg1, Name_Entity);
17267 Check_Optional_Identifier (Arg2, Name_Section);
17268 Check_Arg_Is_Library_Level_Local_Name (Arg1);
17269 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17271 -- Check kind of entity
17273 Arg := Get_Pragma_Arg (Arg1);
17274 Ent := Entity (Arg);
17276 case Ekind (Ent) is
17278 -- Objects (constants and variables) and types. For these cases
17279 -- all we need to do is to set the Linker_Section_pragma field,
17280 -- checking that we do not have a duplicate.
17282 when E_Constant | E_Variable | Type_Kind =>
17283 LPE := Linker_Section_Pragma (Ent);
17285 if Present (LPE) then
17286 Error_Msg_Sloc := Sloc (LPE);
17288 ("Linker_Section already specified for &#", Arg1, Ent);
17291 Set_Linker_Section_Pragma (Ent, N);
17293 -- A pragma that applies to a Ghost entity becomes Ghost for
17294 -- the purposes of legality checks and removal of ignored
17297 Mark_Pragma_As_Ghost (N, Ent);
17301 when Subprogram_Kind =>
17303 -- Aspect case, entity already set
17305 if From_Aspect_Specification (N) then
17306 Set_Linker_Section_Pragma
17307 (Entity (Corresponding_Aspect (N)), N);
17309 -- Pragma case, we must climb the homonym chain, but skip
17310 -- any for which the linker section is already set.
17314 if No (Linker_Section_Pragma (Ent)) then
17315 Set_Linker_Section_Pragma (Ent, N);
17317 -- A pragma that applies to a Ghost entity becomes
17318 -- Ghost for the purposes of legality checks and
17319 -- removal of ignored Ghost code.
17321 Mark_Pragma_As_Ghost (N, Ent);
17323 -- Capture the entity of the first Ghost subprogram
17324 -- being processed for error detection purposes.
17326 if Is_Ghost_Entity (Ent) then
17327 if No (Ghost_Id) then
17331 -- Otherwise the subprogram is non-Ghost. It is
17332 -- illegal to mix references to Ghost and non-Ghost
17333 -- entities (SPARK RM 6.9).
17335 elsif Present (Ghost_Id)
17336 and then not Ghost_Error_Posted
17338 Ghost_Error_Posted := True;
17340 Error_Msg_Name_1 := Pname;
17342 ("pragma % cannot mention ghost and "
17343 & "non-ghost subprograms", N);
17345 Error_Msg_Sloc := Sloc (Ghost_Id);
17347 ("\& # declared as ghost", N, Ghost_Id);
17349 Error_Msg_Sloc := Sloc (Ent);
17351 ("\& # declared as non-ghost", N, Ent);
17355 Ent := Homonym (Ent);
17357 or else Scope (Ent) /= Current_Scope;
17361 -- All other cases are illegal
17365 ("pragma% applies only to objects, subprograms, and types",
17368 end Linker_Section;
17374 -- pragma List (On | Off)
17376 -- There is nothing to do here, since we did all the processing for
17377 -- this pragma in Par.Prag (so that it works properly even in syntax
17380 when Pragma_List =>
17387 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17389 when Pragma_Lock_Free => Lock_Free : declare
17390 P : constant Node_Id := Parent (N);
17396 Check_No_Identifiers;
17397 Check_At_Most_N_Arguments (1);
17399 -- Protected definition case
17401 if Nkind (P) = N_Protected_Definition then
17402 Ent := Defining_Identifier (Parent (P));
17406 if Arg_Count = 1 then
17407 Arg := Get_Pragma_Arg (Arg1);
17408 Val := Is_True (Static_Boolean (Arg));
17410 -- No arguments (expression is considered to be True)
17416 -- Check duplicate pragma before we chain the pragma in the Rep
17417 -- Item chain of Ent.
17419 Check_Duplicate_Pragma (Ent);
17420 Record_Rep_Item (Ent, N);
17421 Set_Uses_Lock_Free (Ent, Val);
17423 -- Anything else is incorrect placement
17430 --------------------
17431 -- Locking_Policy --
17432 --------------------
17434 -- pragma Locking_Policy (policy_IDENTIFIER);
17436 when Pragma_Locking_Policy => declare
17437 subtype LP_Range is Name_Id
17438 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17443 Check_Ada_83_Warning;
17444 Check_Arg_Count (1);
17445 Check_No_Identifiers;
17446 Check_Arg_Is_Locking_Policy (Arg1);
17447 Check_Valid_Configuration_Pragma;
17448 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17451 when Name_Ceiling_Locking =>
17453 when Name_Inheritance_Locking =>
17455 when Name_Concurrent_Readers_Locking =>
17459 if Locking_Policy /= ' '
17460 and then Locking_Policy /= LP
17462 Error_Msg_Sloc := Locking_Policy_Sloc;
17463 Error_Pragma ("locking policy incompatible with policy#");
17465 -- Set new policy, but always preserve System_Location since we
17466 -- like the error message with the run time name.
17469 Locking_Policy := LP;
17471 if Locking_Policy_Sloc /= System_Location then
17472 Locking_Policy_Sloc := Loc;
17477 -------------------
17478 -- Loop_Optimize --
17479 -------------------
17481 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17483 -- OPTIMIZATION_HINT ::=
17484 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17486 when Pragma_Loop_Optimize => Loop_Optimize : declare
17491 Check_At_Least_N_Arguments (1);
17492 Check_No_Identifiers;
17494 Hint := First (Pragma_Argument_Associations (N));
17495 while Present (Hint) loop
17496 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17504 Check_Loop_Pragma_Placement;
17511 -- pragma Loop_Variant
17512 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17514 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17516 -- CHANGE_DIRECTION ::= Increases | Decreases
17518 when Pragma_Loop_Variant => Loop_Variant : declare
17523 Check_At_Least_N_Arguments (1);
17524 Check_Loop_Pragma_Placement;
17526 -- Process all increasing / decreasing expressions
17528 Variant := First (Pragma_Argument_Associations (N));
17529 while Present (Variant) loop
17530 if not Nam_In (Chars (Variant), Name_Decreases,
17533 Error_Pragma_Arg ("wrong change modifier", Variant);
17536 Preanalyze_Assert_Expression
17537 (Expression (Variant), Any_Discrete);
17543 -----------------------
17544 -- Machine_Attribute --
17545 -----------------------
17547 -- pragma Machine_Attribute (
17548 -- [Entity =>] LOCAL_NAME,
17549 -- [Attribute_Name =>] static_string_EXPRESSION
17550 -- [, [Info =>] static_EXPRESSION] );
17552 when Pragma_Machine_Attribute => Machine_Attribute : declare
17553 Def_Id : Entity_Id;
17557 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17559 if Arg_Count = 3 then
17560 Check_Optional_Identifier (Arg3, Name_Info);
17561 Check_Arg_Is_OK_Static_Expression (Arg3);
17563 Check_Arg_Count (2);
17566 Check_Optional_Identifier (Arg1, Name_Entity);
17567 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17568 Check_Arg_Is_Local_Name (Arg1);
17569 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17570 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17572 if Is_Access_Type (Def_Id) then
17573 Def_Id := Designated_Type (Def_Id);
17576 if Rep_Item_Too_Early (Def_Id, N) then
17580 Def_Id := Underlying_Type (Def_Id);
17582 -- The only processing required is to link this item on to the
17583 -- list of rep items for the given entity. This is accomplished
17584 -- by the call to Rep_Item_Too_Late (when no error is detected
17585 -- and False is returned).
17587 if Rep_Item_Too_Late (Def_Id, N) then
17590 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17592 end Machine_Attribute;
17599 -- (MAIN_OPTION [, MAIN_OPTION]);
17602 -- [STACK_SIZE =>] static_integer_EXPRESSION
17603 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17604 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17606 when Pragma_Main => Main : declare
17607 Args : Args_List (1 .. 3);
17608 Names : constant Name_List (1 .. 3) := (
17610 Name_Task_Stack_Size_Default,
17611 Name_Time_Slicing_Enabled);
17617 Gather_Associations (Names, Args);
17619 for J in 1 .. 2 loop
17620 if Present (Args (J)) then
17621 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17625 if Present (Args (3)) then
17626 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17630 while Present (Nod) loop
17631 if Nkind (Nod) = N_Pragma
17632 and then Pragma_Name (Nod) = Name_Main
17634 Error_Msg_Name_1 := Pname;
17635 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17646 -- pragma Main_Storage
17647 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17649 -- MAIN_STORAGE_OPTION ::=
17650 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17651 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17653 when Pragma_Main_Storage => Main_Storage : declare
17654 Args : Args_List (1 .. 2);
17655 Names : constant Name_List (1 .. 2) := (
17656 Name_Working_Storage,
17663 Gather_Associations (Names, Args);
17665 for J in 1 .. 2 loop
17666 if Present (Args (J)) then
17667 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17671 Check_In_Main_Program;
17674 while Present (Nod) loop
17675 if Nkind (Nod) = N_Pragma
17676 and then Pragma_Name (Nod) = Name_Main_Storage
17678 Error_Msg_Name_1 := Pname;
17679 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17690 -- pragma Memory_Size (NUMERIC_LITERAL)
17692 when Pragma_Memory_Size =>
17695 -- Memory size is simply ignored
17697 Check_No_Identifiers;
17698 Check_Arg_Count (1);
17699 Check_Arg_Is_Integer_Literal (Arg1);
17707 -- The only correct use of this pragma is on its own in a file, in
17708 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17709 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17710 -- check for a file containing nothing but a No_Body pragma). If we
17711 -- attempt to process it during normal semantics processing, it means
17712 -- it was misplaced.
17714 when Pragma_No_Body =>
17718 -----------------------------
17719 -- No_Elaboration_Code_All --
17720 -----------------------------
17722 -- pragma No_Elaboration_Code_All;
17724 when Pragma_No_Elaboration_Code_All =>
17726 Check_Valid_Library_Unit_Pragma;
17728 if Nkind (N) = N_Null_Statement then
17732 -- Must appear for a spec or generic spec
17734 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17735 N_Generic_Package_Declaration,
17736 N_Generic_Subprogram_Declaration,
17737 N_Package_Declaration,
17738 N_Subprogram_Declaration)
17742 ("pragma% can only occur for package "
17743 & "or subprogram spec"));
17746 -- Set flag in unit table
17748 Set_No_Elab_Code_All (Current_Sem_Unit);
17750 -- Set restriction No_Elaboration_Code if this is the main unit
17752 if Current_Sem_Unit = Main_Unit then
17753 Set_Restriction (No_Elaboration_Code, N);
17756 -- If we are in the main unit or in an extended main source unit,
17757 -- then we also add it to the configuration restrictions so that
17758 -- it will apply to all units in the extended main source.
17760 if Current_Sem_Unit = Main_Unit
17761 or else In_Extended_Main_Source_Unit (N)
17763 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17766 -- If in main extended unit, activate transitive with test
17768 if In_Extended_Main_Source_Unit (N) then
17769 Opt.No_Elab_Code_All_Pragma := N;
17776 -- pragma No_Inline ( NAME {, NAME} );
17778 when Pragma_No_Inline =>
17780 Process_Inline (Suppressed);
17786 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17788 when Pragma_No_Return => No_Return : declare
17794 Ghost_Error_Posted : Boolean := False;
17795 -- Flag set when an error concerning the illegal mix of Ghost and
17796 -- non-Ghost subprograms is emitted.
17798 Ghost_Id : Entity_Id := Empty;
17799 -- The entity of the first Ghost procedure encountered while
17800 -- processing the arguments of the pragma.
17804 Check_At_Least_N_Arguments (1);
17806 -- Loop through arguments of pragma
17809 while Present (Arg) loop
17810 Check_Arg_Is_Local_Name (Arg);
17811 Id := Get_Pragma_Arg (Arg);
17814 if not Is_Entity_Name (Id) then
17815 Error_Pragma_Arg ("entity name required", Arg);
17818 if Etype (Id) = Any_Type then
17822 -- Loop to find matching procedures
17828 and then Scope (E) = Current_Scope
17830 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17833 -- A pragma that applies to a Ghost entity becomes Ghost
17834 -- for the purposes of legality checks and removal of
17835 -- ignored Ghost code.
17837 Mark_Pragma_As_Ghost (N, E);
17839 -- Capture the entity of the first Ghost procedure being
17840 -- processed for error detection purposes.
17842 if Is_Ghost_Entity (E) then
17843 if No (Ghost_Id) then
17847 -- Otherwise the subprogram is non-Ghost. It is illegal
17848 -- to mix references to Ghost and non-Ghost entities
17851 elsif Present (Ghost_Id)
17852 and then not Ghost_Error_Posted
17854 Ghost_Error_Posted := True;
17856 Error_Msg_Name_1 := Pname;
17858 ("pragma % cannot mention ghost and non-ghost "
17859 & "procedures", N);
17861 Error_Msg_Sloc := Sloc (Ghost_Id);
17862 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17864 Error_Msg_Sloc := Sloc (E);
17865 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17868 -- Set flag on any alias as well
17870 if Is_Overloadable (E) and then Present (Alias (E)) then
17871 Set_No_Return (Alias (E));
17877 exit when From_Aspect_Specification (N);
17881 -- If entity in not in current scope it may be the enclosing
17882 -- suprogram body to which the aspect applies.
17885 if Entity (Id) = Current_Scope
17886 and then From_Aspect_Specification (N)
17888 Set_No_Return (Entity (Id));
17890 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17902 -- pragma No_Run_Time;
17904 -- Note: this pragma is retained for backwards compatibility. See
17905 -- body of Rtsfind for full details on its handling.
17907 when Pragma_No_Run_Time =>
17909 Check_Valid_Configuration_Pragma;
17910 Check_Arg_Count (0);
17912 -- Remove backward compatibility if Build_Type is FSF or GPL and
17913 -- generate a warning.
17916 Ignore : constant Boolean := Build_Type in FSF .. GPL;
17919 Error_Pragma ("pragma% is ignored, has no effect??");
17921 No_Run_Time_Mode := True;
17922 Configurable_Run_Time_Mode := True;
17924 -- Set Duration to 32 bits if word size is 32
17926 if Ttypes.System_Word_Size = 32 then
17927 Duration_32_Bits_On_Target := True;
17930 -- Set appropriate restrictions
17932 Set_Restriction (No_Finalization, N);
17933 Set_Restriction (No_Exception_Handlers, N);
17934 Set_Restriction (Max_Tasks, N, 0);
17935 Set_Restriction (No_Tasking, N);
17939 -----------------------
17940 -- No_Tagged_Streams --
17941 -----------------------
17943 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
17945 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17951 Check_At_Most_N_Arguments (1);
17953 -- One argument case
17955 if Arg_Count = 1 then
17956 Check_Optional_Identifier (Arg1, Name_Entity);
17957 Check_Arg_Is_Local_Name (Arg1);
17958 E_Id := Get_Pragma_Arg (Arg1);
17960 if Etype (E_Id) = Any_Type then
17964 E := Entity (E_Id);
17966 Check_Duplicate_Pragma (E);
17968 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17970 ("argument for pragma% must be root tagged type", Arg1);
17973 if Rep_Item_Too_Early (E, N)
17975 Rep_Item_Too_Late (E, N)
17979 Set_No_Tagged_Streams_Pragma (E, N);
17982 -- Zero argument case
17985 Check_Is_In_Decl_Part_Or_Package_Spec;
17986 No_Tagged_Streams := N;
17988 end No_Tagged_Strms;
17990 ------------------------
17991 -- No_Strict_Aliasing --
17992 ------------------------
17994 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17996 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
18001 Check_At_Most_N_Arguments (1);
18003 if Arg_Count = 0 then
18004 Check_Valid_Configuration_Pragma;
18005 Opt.No_Strict_Aliasing := True;
18008 Check_Optional_Identifier (Arg2, Name_Entity);
18009 Check_Arg_Is_Local_Name (Arg1);
18010 E_Id := Entity (Get_Pragma_Arg (Arg1));
18012 if E_Id = Any_Type then
18014 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
18015 Error_Pragma_Arg ("pragma% requires access type", Arg1);
18018 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
18020 end No_Strict_Aliasing;
18022 -----------------------
18023 -- Normalize_Scalars --
18024 -----------------------
18026 -- pragma Normalize_Scalars;
18028 when Pragma_Normalize_Scalars =>
18029 Check_Ada_83_Warning;
18030 Check_Arg_Count (0);
18031 Check_Valid_Configuration_Pragma;
18033 -- Normalize_Scalars creates false positives in CodePeer, and
18034 -- incorrect negative results in GNATprove mode, so ignore this
18035 -- pragma in these modes.
18037 if not (CodePeer_Mode or GNATprove_Mode) then
18038 Normalize_Scalars := True;
18039 Init_Or_Norm_Scalars := True;
18046 -- pragma Obsolescent;
18048 -- pragma Obsolescent (
18049 -- [Message =>] static_string_EXPRESSION
18050 -- [,[Version =>] Ada_05]]);
18052 -- pragma Obsolescent (
18053 -- [Entity =>] NAME
18054 -- [,[Message =>] static_string_EXPRESSION
18055 -- [,[Version =>] Ada_05]] );
18057 when Pragma_Obsolescent => Obsolescent : declare
18061 procedure Set_Obsolescent (E : Entity_Id);
18062 -- Given an entity Ent, mark it as obsolescent if appropriate
18064 ---------------------
18065 -- Set_Obsolescent --
18066 ---------------------
18068 procedure Set_Obsolescent (E : Entity_Id) is
18077 -- A pragma that applies to a Ghost entity becomes Ghost for
18078 -- the purposes of legality checks and removal of ignored Ghost
18081 Mark_Pragma_As_Ghost (N, E);
18083 -- Entity name was given
18085 if Present (Ename) then
18087 -- If entity name matches, we are fine. Save entity in
18088 -- pragma argument, for ASIS use.
18090 if Chars (Ename) = Chars (Ent) then
18091 Set_Entity (Ename, Ent);
18092 Generate_Reference (Ent, Ename);
18094 -- If entity name does not match, only possibility is an
18095 -- enumeration literal from an enumeration type declaration.
18097 elsif Ekind (Ent) /= E_Enumeration_Type then
18099 ("pragma % entity name does not match declaration");
18102 Ent := First_Literal (E);
18106 ("pragma % entity name does not match any "
18107 & "enumeration literal");
18109 elsif Chars (Ent) = Chars (Ename) then
18110 Set_Entity (Ename, Ent);
18111 Generate_Reference (Ent, Ename);
18115 Ent := Next_Literal (Ent);
18121 -- Ent points to entity to be marked
18123 if Arg_Count >= 1 then
18125 -- Deal with static string argument
18127 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18128 S := Strval (Get_Pragma_Arg (Arg1));
18130 for J in 1 .. String_Length (S) loop
18131 if not In_Character_Range (Get_String_Char (S, J)) then
18133 ("pragma% argument does not allow wide characters",
18138 Obsolescent_Warnings.Append
18139 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
18141 -- Check for Ada_05 parameter
18143 if Arg_Count /= 1 then
18144 Check_Arg_Count (2);
18147 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
18150 Check_Arg_Is_Identifier (Argx);
18152 if Chars (Argx) /= Name_Ada_05 then
18153 Error_Msg_Name_2 := Name_Ada_05;
18155 ("only allowed argument for pragma% is %", Argx);
18158 if Ada_Version_Explicit < Ada_2005
18159 or else not Warn_On_Ada_2005_Compatibility
18167 -- Set flag if pragma active
18170 Set_Is_Obsolescent (Ent);
18174 end Set_Obsolescent;
18176 -- Start of processing for pragma Obsolescent
18181 Check_At_Most_N_Arguments (3);
18183 -- See if first argument specifies an entity name
18187 (Chars (Arg1) = Name_Entity
18189 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
18191 N_Operator_Symbol))
18193 Ename := Get_Pragma_Arg (Arg1);
18195 -- Eliminate first argument, so we can share processing
18199 Arg_Count := Arg_Count - 1;
18201 -- No Entity name argument given
18207 if Arg_Count >= 1 then
18208 Check_Optional_Identifier (Arg1, Name_Message);
18210 if Arg_Count = 2 then
18211 Check_Optional_Identifier (Arg2, Name_Version);
18215 -- Get immediately preceding declaration
18218 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
18222 -- Cases where we do not follow anything other than another pragma
18226 -- First case: library level compilation unit declaration with
18227 -- the pragma immediately following the declaration.
18229 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
18231 (Defining_Entity (Unit (Parent (Parent (N)))));
18234 -- Case 2: library unit placement for package
18238 Ent : constant Entity_Id := Find_Lib_Unit_Name;
18240 if Is_Package_Or_Generic_Package (Ent) then
18241 Set_Obsolescent (Ent);
18247 -- Cases where we must follow a declaration, including an
18248 -- abstract subprogram declaration, which is not in the
18249 -- other node subtypes.
18252 if Nkind (Decl) not in N_Declaration
18253 and then Nkind (Decl) not in N_Later_Decl_Item
18254 and then Nkind (Decl) not in N_Generic_Declaration
18255 and then Nkind (Decl) not in N_Renaming_Declaration
18256 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
18259 ("pragma% misplaced, "
18260 & "must immediately follow a declaration");
18263 Set_Obsolescent (Defining_Entity (Decl));
18273 -- pragma Optimize (Time | Space | Off);
18275 -- The actual check for optimize is done in Gigi. Note that this
18276 -- pragma does not actually change the optimization setting, it
18277 -- simply checks that it is consistent with the pragma.
18279 when Pragma_Optimize =>
18280 Check_No_Identifiers;
18281 Check_Arg_Count (1);
18282 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
18284 ------------------------
18285 -- Optimize_Alignment --
18286 ------------------------
18288 -- pragma Optimize_Alignment (Time | Space | Off);
18290 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
18292 Check_No_Identifiers;
18293 Check_Arg_Count (1);
18294 Check_Valid_Configuration_Pragma;
18297 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
18301 Opt.Optimize_Alignment := 'T';
18303 Opt.Optimize_Alignment := 'S';
18305 Opt.Optimize_Alignment := 'O';
18307 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
18311 -- Set indication that mode is set locally. If we are in fact in a
18312 -- configuration pragma file, this setting is harmless since the
18313 -- switch will get reset anyway at the start of each unit.
18315 Optimize_Alignment_Local := True;
18316 end Optimize_Alignment;
18322 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18324 when Pragma_Ordered => Ordered : declare
18325 Assoc : constant Node_Id := Arg1;
18331 Check_No_Identifiers;
18332 Check_Arg_Count (1);
18333 Check_Arg_Is_Local_Name (Arg1);
18335 Type_Id := Get_Pragma_Arg (Assoc);
18336 Find_Type (Type_Id);
18337 Typ := Entity (Type_Id);
18339 if Typ = Any_Type then
18342 Typ := Underlying_Type (Typ);
18345 if not Is_Enumeration_Type (Typ) then
18346 Error_Pragma ("pragma% must specify enumeration type");
18349 Check_First_Subtype (Arg1);
18350 Set_Has_Pragma_Ordered (Base_Type (Typ));
18353 -------------------
18354 -- Overflow_Mode --
18355 -------------------
18357 -- pragma Overflow_Mode
18358 -- ([General => ] MODE [, [Assertions => ] MODE]);
18360 -- MODE := STRICT | MINIMIZED | ELIMINATED
18362 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18363 -- since System.Bignums makes this assumption. This is true of nearly
18364 -- all (all?) targets.
18366 when Pragma_Overflow_Mode => Overflow_Mode : declare
18367 function Get_Overflow_Mode
18369 Arg : Node_Id) return Overflow_Mode_Type;
18370 -- Function to process one pragma argument, Arg. If an identifier
18371 -- is present, it must be Name. Mode type is returned if a valid
18372 -- argument exists, otherwise an error is signalled.
18374 -----------------------
18375 -- Get_Overflow_Mode --
18376 -----------------------
18378 function Get_Overflow_Mode
18380 Arg : Node_Id) return Overflow_Mode_Type
18382 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18385 Check_Optional_Identifier (Arg, Name);
18386 Check_Arg_Is_Identifier (Argx);
18388 if Chars (Argx) = Name_Strict then
18391 elsif Chars (Argx) = Name_Minimized then
18394 elsif Chars (Argx) = Name_Eliminated then
18395 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18397 ("Eliminated not implemented on this target", Argx);
18403 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18405 end Get_Overflow_Mode;
18407 -- Start of processing for Overflow_Mode
18411 Check_At_Least_N_Arguments (1);
18412 Check_At_Most_N_Arguments (2);
18414 -- Process first argument
18416 Scope_Suppress.Overflow_Mode_General :=
18417 Get_Overflow_Mode (Name_General, Arg1);
18419 -- Case of only one argument
18421 if Arg_Count = 1 then
18422 Scope_Suppress.Overflow_Mode_Assertions :=
18423 Scope_Suppress.Overflow_Mode_General;
18425 -- Case of two arguments present
18428 Scope_Suppress.Overflow_Mode_Assertions :=
18429 Get_Overflow_Mode (Name_Assertions, Arg2);
18433 --------------------------
18434 -- Overriding Renamings --
18435 --------------------------
18437 -- pragma Overriding_Renamings;
18439 when Pragma_Overriding_Renamings =>
18441 Check_Arg_Count (0);
18442 Check_Valid_Configuration_Pragma;
18443 Overriding_Renamings := True;
18449 -- pragma Pack (first_subtype_LOCAL_NAME);
18451 when Pragma_Pack => Pack : declare
18452 Assoc : constant Node_Id := Arg1;
18454 Ignore : Boolean := False;
18459 Check_No_Identifiers;
18460 Check_Arg_Count (1);
18461 Check_Arg_Is_Local_Name (Arg1);
18462 Type_Id := Get_Pragma_Arg (Assoc);
18464 if not Is_Entity_Name (Type_Id)
18465 or else not Is_Type (Entity (Type_Id))
18468 ("argument for pragma% must be type or subtype", Arg1);
18471 Find_Type (Type_Id);
18472 Typ := Entity (Type_Id);
18475 or else Rep_Item_Too_Early (Typ, N)
18479 Typ := Underlying_Type (Typ);
18482 -- A pragma that applies to a Ghost entity becomes Ghost for the
18483 -- purposes of legality checks and removal of ignored Ghost code.
18485 Mark_Pragma_As_Ghost (N, Typ);
18487 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18488 Error_Pragma ("pragma% must specify array or record type");
18491 Check_First_Subtype (Arg1);
18492 Check_Duplicate_Pragma (Typ);
18496 if Is_Array_Type (Typ) then
18497 Ctyp := Component_Type (Typ);
18499 -- Ignore pack that does nothing
18501 if Known_Static_Esize (Ctyp)
18502 and then Known_Static_RM_Size (Ctyp)
18503 and then Esize (Ctyp) = RM_Size (Ctyp)
18504 and then Addressable (Esize (Ctyp))
18509 -- Process OK pragma Pack. Note that if there is a separate
18510 -- component clause present, the Pack will be cancelled. This
18511 -- processing is in Freeze.
18513 if not Rep_Item_Too_Late (Typ, N) then
18515 -- In CodePeer mode, we do not need complex front-end
18516 -- expansions related to pragma Pack, so disable handling
18519 if CodePeer_Mode then
18522 -- Normal case where we do the pack action
18526 Set_Is_Packed (Base_Type (Typ));
18527 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18530 Set_Has_Pragma_Pack (Base_Type (Typ));
18534 -- For record types, the pack is always effective
18536 else pragma Assert (Is_Record_Type (Typ));
18537 if not Rep_Item_Too_Late (Typ, N) then
18538 Set_Is_Packed (Base_Type (Typ));
18539 Set_Has_Pragma_Pack (Base_Type (Typ));
18540 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18551 -- There is nothing to do here, since we did all the processing for
18552 -- this pragma in Par.Prag (so that it works properly even in syntax
18555 when Pragma_Page =>
18562 -- pragma Part_Of (ABSTRACT_STATE);
18564 -- ABSTRACT_STATE ::= NAME
18566 when Pragma_Part_Of => Part_Of : declare
18567 procedure Propagate_Part_Of
18568 (Pack_Id : Entity_Id;
18569 State_Id : Entity_Id;
18570 Instance : Node_Id);
18571 -- Propagate the Part_Of indicator to all abstract states and
18572 -- objects declared in the visible state space of a package
18573 -- denoted by Pack_Id. State_Id is the encapsulating state.
18574 -- Instance is the package instantiation node.
18576 -----------------------
18577 -- Propagate_Part_Of --
18578 -----------------------
18580 procedure Propagate_Part_Of
18581 (Pack_Id : Entity_Id;
18582 State_Id : Entity_Id;
18583 Instance : Node_Id)
18585 Has_Item : Boolean := False;
18586 -- Flag set when the visible state space contains at least one
18587 -- abstract state or variable.
18589 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
18590 -- Propagate the Part_Of indicator to all abstract states and
18591 -- objects declared in the visible state space of a package
18592 -- denoted by Pack_Id.
18594 -----------------------
18595 -- Propagate_Part_Of --
18596 -----------------------
18598 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
18599 Constits : Elist_Id;
18600 Item_Id : Entity_Id;
18603 -- Traverse the entity chain of the package and set relevant
18604 -- attributes of abstract states and objects declared in the
18605 -- visible state space of the package.
18607 Item_Id := First_Entity (Pack_Id);
18608 while Present (Item_Id)
18609 and then not In_Private_Part (Item_Id)
18611 -- Do not consider internally generated items
18613 if not Comes_From_Source (Item_Id) then
18616 -- The Part_Of indicator turns an abstract state or an
18617 -- object into a constituent of the encapsulating state.
18619 elsif Ekind_In (Item_Id, E_Abstract_State,
18624 Constits := Part_Of_Constituents (State_Id);
18626 if No (Constits) then
18627 Constits := New_Elmt_List;
18628 Set_Part_Of_Constituents (State_Id, Constits);
18631 Append_Elmt (Item_Id, Constits);
18632 Set_Encapsulating_State (Item_Id, State_Id);
18634 -- Recursively handle nested packages and instantiations
18636 elsif Ekind (Item_Id) = E_Package then
18637 Propagate_Part_Of (Item_Id);
18640 Next_Entity (Item_Id);
18642 end Propagate_Part_Of;
18644 -- Start of processing for Propagate_Part_Of
18647 Propagate_Part_Of (Pack_Id);
18649 -- Detect a package instantiation that is subject to a Part_Of
18650 -- indicator, but has no visible state.
18652 if not Has_Item then
18654 ("package instantiation & has Part_Of indicator but "
18655 & "lacks visible state", Instance, Pack_Id);
18657 end Propagate_Part_Of;
18661 Constits : Elist_Id;
18663 Encap_Id : Entity_Id;
18664 Item_Id : Entity_Id;
18668 -- Start of processing for Part_Of
18672 Check_No_Identifiers;
18673 Check_Arg_Count (1);
18675 Stmt := Find_Related_Context (N, Do_Checks => True);
18677 -- Object declaration
18679 if Nkind (Stmt) = N_Object_Declaration then
18682 -- Package instantiation
18684 elsif Nkind (Stmt) = N_Package_Instantiation then
18687 -- Single concurrent type declaration
18689 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
18692 -- Otherwise the pragma is associated with an illegal construct
18699 -- Extract the entity of the related object declaration or package
18700 -- instantiation. In the case of the instantiation, use the entity
18701 -- of the instance spec.
18703 if Nkind (Stmt) = N_Package_Instantiation then
18704 Stmt := Instance_Spec (Stmt);
18707 Item_Id := Defining_Entity (Stmt);
18708 Encap := Get_Pragma_Arg (Arg1);
18710 -- A pragma that applies to a Ghost entity becomes Ghost for the
18711 -- purposes of legality checks and removal of ignored Ghost code.
18713 Mark_Pragma_As_Ghost (N, Item_Id);
18715 -- Chain the pragma on the contract for further processing by
18716 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18718 Add_Contract_Item (N, Item_Id);
18720 -- A variable may act as consituent of a single concurrent type
18721 -- which in turn could be declared after the variable. Due to this
18722 -- discrepancy, the full analysis of indicator Part_Of is delayed
18723 -- until the end of the enclosing declarative region (see routine
18724 -- Analyze_Part_Of_In_Decl_Part).
18726 if Ekind (Item_Id) = E_Variable then
18729 -- Otherwise indicator Part_Of applies to a constant or a package
18733 -- Detect any discrepancies between the placement of the
18734 -- constant or package instantiation with respect to state
18735 -- space and the encapsulating state.
18739 Item_Id => Item_Id,
18741 Encap_Id => Encap_Id,
18745 pragma Assert (Present (Encap_Id));
18747 if Ekind (Item_Id) = E_Constant then
18748 Constits := Part_Of_Constituents (Encap_Id);
18750 if No (Constits) then
18751 Constits := New_Elmt_List;
18752 Set_Part_Of_Constituents (Encap_Id, Constits);
18755 Append_Elmt (Item_Id, Constits);
18756 Set_Encapsulating_State (Item_Id, Encap_Id);
18758 -- Propagate the Part_Of indicator to the visible state
18759 -- space of the package instantiation.
18763 (Pack_Id => Item_Id,
18764 State_Id => Encap_Id,
18771 ----------------------------------
18772 -- Partition_Elaboration_Policy --
18773 ----------------------------------
18775 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18777 when Pragma_Partition_Elaboration_Policy => declare
18778 subtype PEP_Range is Name_Id
18779 range First_Partition_Elaboration_Policy_Name
18780 .. Last_Partition_Elaboration_Policy_Name;
18781 PEP_Val : PEP_Range;
18786 Check_Arg_Count (1);
18787 Check_No_Identifiers;
18788 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18789 Check_Valid_Configuration_Pragma;
18790 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18793 when Name_Concurrent =>
18795 when Name_Sequential =>
18799 if Partition_Elaboration_Policy /= ' '
18800 and then Partition_Elaboration_Policy /= PEP
18802 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18804 ("partition elaboration policy incompatible with policy#");
18806 -- Set new policy, but always preserve System_Location since we
18807 -- like the error message with the run time name.
18810 Partition_Elaboration_Policy := PEP;
18812 if Partition_Elaboration_Policy_Sloc /= System_Location then
18813 Partition_Elaboration_Policy_Sloc := Loc;
18822 -- pragma Passive [(PASSIVE_FORM)];
18824 -- PASSIVE_FORM ::= Semaphore | No
18826 when Pragma_Passive =>
18829 if Nkind (Parent (N)) /= N_Task_Definition then
18830 Error_Pragma ("pragma% must be within task definition");
18833 if Arg_Count /= 0 then
18834 Check_Arg_Count (1);
18835 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18838 ----------------------------------
18839 -- Preelaborable_Initialization --
18840 ----------------------------------
18842 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18844 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18849 Check_Arg_Count (1);
18850 Check_No_Identifiers;
18851 Check_Arg_Is_Identifier (Arg1);
18852 Check_Arg_Is_Local_Name (Arg1);
18853 Check_First_Subtype (Arg1);
18854 Ent := Entity (Get_Pragma_Arg (Arg1));
18856 -- A pragma that applies to a Ghost entity becomes Ghost for the
18857 -- purposes of legality checks and removal of ignored Ghost code.
18859 Mark_Pragma_As_Ghost (N, Ent);
18861 -- The pragma may come from an aspect on a private declaration,
18862 -- even if the freeze point at which this is analyzed in the
18863 -- private part after the full view.
18865 if Has_Private_Declaration (Ent)
18866 and then From_Aspect_Specification (N)
18870 -- Check appropriate type argument
18872 elsif Is_Private_Type (Ent)
18873 or else Is_Protected_Type (Ent)
18874 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18876 -- AI05-0028: The pragma applies to all composite types. Note
18877 -- that we apply this binding interpretation to earlier versions
18878 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18879 -- choice since there are other compilers that do the same.
18881 or else Is_Composite_Type (Ent)
18887 ("pragma % can only be applied to private, formal derived, "
18888 & "protected, or composite type", Arg1);
18891 -- Give an error if the pragma is applied to a protected type that
18892 -- does not qualify (due to having entries, or due to components
18893 -- that do not qualify).
18895 if Is_Protected_Type (Ent)
18896 and then not Has_Preelaborable_Initialization (Ent)
18899 ("protected type & does not have preelaborable "
18900 & "initialization", Ent);
18902 -- Otherwise mark the type as definitely having preelaborable
18906 Set_Known_To_Have_Preelab_Init (Ent);
18909 if Has_Pragma_Preelab_Init (Ent)
18910 and then Warn_On_Redundant_Constructs
18912 Error_Pragma ("?r?duplicate pragma%!");
18914 Set_Has_Pragma_Preelab_Init (Ent);
18918 --------------------
18919 -- Persistent_BSS --
18920 --------------------
18922 -- pragma Persistent_BSS [(object_NAME)];
18924 when Pragma_Persistent_BSS => Persistent_BSS : declare
18931 Check_At_Most_N_Arguments (1);
18933 -- Case of application to specific object (one argument)
18935 if Arg_Count = 1 then
18936 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18938 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18940 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18943 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18946 Ent := Entity (Get_Pragma_Arg (Arg1));
18947 Decl := Parent (Ent);
18949 -- A pragma that applies to a Ghost entity becomes Ghost for
18950 -- the purposes of legality checks and removal of ignored Ghost
18953 Mark_Pragma_As_Ghost (N, Ent);
18955 -- Check for duplication before inserting in list of
18956 -- representation items.
18958 Check_Duplicate_Pragma (Ent);
18960 if Rep_Item_Too_Late (Ent, N) then
18964 if Present (Expression (Decl)) then
18966 ("object for pragma% cannot have initialization", Arg1);
18969 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18971 ("object type for pragma% is not potentially persistent",
18976 Make_Linker_Section_Pragma
18977 (Ent, Sloc (N), ".persistent.bss");
18978 Insert_After (N, Prag);
18981 -- Case of use as configuration pragma with no arguments
18984 Check_Valid_Configuration_Pragma;
18985 Persistent_BSS_Mode := True;
18987 end Persistent_BSS;
18993 -- pragma Polling (ON | OFF);
18995 when Pragma_Polling =>
18997 Check_Arg_Count (1);
18998 Check_No_Identifiers;
18999 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
19000 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
19002 -----------------------------------
19003 -- Post/Post_Class/Postcondition --
19004 -----------------------------------
19006 -- pragma Post (Boolean_EXPRESSION);
19007 -- pragma Post_Class (Boolean_EXPRESSION);
19008 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19009 -- [,[Message =>] String_EXPRESSION]);
19011 -- Characteristics:
19013 -- * Analysis - The annotation undergoes initial checks to verify
19014 -- the legal placement and context. Secondary checks preanalyze the
19017 -- Analyze_Pre_Post_Condition_In_Decl_Part
19019 -- * Expansion - The annotation is expanded during the expansion of
19020 -- the related subprogram [body] contract as performed in:
19022 -- Expand_Subprogram_Contract
19024 -- * Template - The annotation utilizes the generic template of the
19025 -- related subprogram [body] when it is:
19027 -- aspect on subprogram declaration
19028 -- aspect on stand alone subprogram body
19029 -- pragma on stand alone subprogram body
19031 -- The annotation must prepare its own template when it is:
19033 -- pragma on subprogram declaration
19035 -- * Globals - Capture of global references must occur after full
19038 -- * Instance - The annotation is instantiated automatically when
19039 -- the related generic subprogram [body] is instantiated except for
19040 -- the "pragma on subprogram declaration" case. In that scenario
19041 -- the annotation must instantiate itself.
19044 Pragma_Post_Class |
19045 Pragma_Postcondition =>
19046 Analyze_Pre_Post_Condition;
19048 --------------------------------
19049 -- Pre/Pre_Class/Precondition --
19050 --------------------------------
19052 -- pragma Pre (Boolean_EXPRESSION);
19053 -- pragma Pre_Class (Boolean_EXPRESSION);
19054 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19055 -- [,[Message =>] String_EXPRESSION]);
19057 -- Characteristics:
19059 -- * Analysis - The annotation undergoes initial checks to verify
19060 -- the legal placement and context. Secondary checks preanalyze the
19063 -- Analyze_Pre_Post_Condition_In_Decl_Part
19065 -- * Expansion - The annotation is expanded during the expansion of
19066 -- the related subprogram [body] contract as performed in:
19068 -- Expand_Subprogram_Contract
19070 -- * Template - The annotation utilizes the generic template of the
19071 -- related subprogram [body] when it is:
19073 -- aspect on subprogram declaration
19074 -- aspect on stand alone subprogram body
19075 -- pragma on stand alone subprogram body
19077 -- The annotation must prepare its own template when it is:
19079 -- pragma on subprogram declaration
19081 -- * Globals - Capture of global references must occur after full
19084 -- * Instance - The annotation is instantiated automatically when
19085 -- the related generic subprogram [body] is instantiated except for
19086 -- the "pragma on subprogram declaration" case. In that scenario
19087 -- the annotation must instantiate itself.
19091 Pragma_Precondition =>
19092 Analyze_Pre_Post_Condition;
19098 -- pragma Predicate
19099 -- ([Entity =>] type_LOCAL_NAME,
19100 -- [Check =>] boolean_EXPRESSION);
19102 when Pragma_Predicate => Predicate : declare
19109 Check_Arg_Count (2);
19110 Check_Optional_Identifier (Arg1, Name_Entity);
19111 Check_Optional_Identifier (Arg2, Name_Check);
19113 Check_Arg_Is_Local_Name (Arg1);
19115 Type_Id := Get_Pragma_Arg (Arg1);
19116 Find_Type (Type_Id);
19117 Typ := Entity (Type_Id);
19119 if Typ = Any_Type then
19123 -- A pragma that applies to a Ghost entity becomes Ghost for the
19124 -- purposes of legality checks and removal of ignored Ghost code.
19126 Mark_Pragma_As_Ghost (N, Typ);
19128 -- The remaining processing is simply to link the pragma on to
19129 -- the rep item chain, for processing when the type is frozen.
19130 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19131 -- mark the type as having predicates.
19132 -- If the current policy is Ignore mark the subtype accordingly.
19133 -- In the case of predicates we consider them enabled unless an
19134 -- Ignore is specified, to preserve existing warnings.
19136 Set_Has_Predicates (Typ);
19137 Set_Predicates_Ignored (Typ,
19138 Present (Check_Policy_List)
19140 Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore);
19141 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19144 -----------------------
19145 -- Predicate_Failure --
19146 -----------------------
19148 -- pragma Predicate_Failure
19149 -- ([Entity =>] type_LOCAL_NAME,
19150 -- [Message =>] string_EXPRESSION);
19152 when Pragma_Predicate_Failure => Predicate_Failure : declare
19159 Check_Arg_Count (2);
19160 Check_Optional_Identifier (Arg1, Name_Entity);
19161 Check_Optional_Identifier (Arg2, Name_Message);
19163 Check_Arg_Is_Local_Name (Arg1);
19165 Type_Id := Get_Pragma_Arg (Arg1);
19166 Find_Type (Type_Id);
19167 Typ := Entity (Type_Id);
19169 if Typ = Any_Type then
19173 -- A pragma that applies to a Ghost entity becomes Ghost for the
19174 -- purposes of legality checks and removal of ignored Ghost code.
19176 Mark_Pragma_As_Ghost (N, Typ);
19178 -- The remaining processing is simply to link the pragma on to
19179 -- the rep item chain, for processing when the type is frozen.
19180 -- This is accomplished by a call to Rep_Item_Too_Late.
19182 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19183 end Predicate_Failure;
19189 -- pragma Preelaborate [(library_unit_NAME)];
19191 -- Set the flag Is_Preelaborated of program unit name entity
19193 when Pragma_Preelaborate => Preelaborate : declare
19194 Pa : constant Node_Id := Parent (N);
19195 Pk : constant Node_Kind := Nkind (Pa);
19199 Check_Ada_83_Warning;
19200 Check_Valid_Library_Unit_Pragma;
19202 if Nkind (N) = N_Null_Statement then
19206 Ent := Find_Lib_Unit_Name;
19208 -- A pragma that applies to a Ghost entity becomes Ghost for the
19209 -- purposes of legality checks and removal of ignored Ghost code.
19211 Mark_Pragma_As_Ghost (N, Ent);
19212 Check_Duplicate_Pragma (Ent);
19214 -- This filters out pragmas inside generic parents that show up
19215 -- inside instantiations. Pragmas that come from aspects in the
19216 -- unit are not ignored.
19218 if Present (Ent) then
19219 if Pk = N_Package_Specification
19220 and then Present (Generic_Parent (Pa))
19221 and then not From_Aspect_Specification (N)
19226 if not Debug_Flag_U then
19227 Set_Is_Preelaborated (Ent);
19228 Set_Suppress_Elaboration_Warnings (Ent);
19234 -------------------------------
19235 -- Prefix_Exception_Messages --
19236 -------------------------------
19238 -- pragma Prefix_Exception_Messages;
19240 when Pragma_Prefix_Exception_Messages =>
19242 Check_Valid_Configuration_Pragma;
19243 Check_Arg_Count (0);
19244 Prefix_Exception_Messages := True;
19250 -- pragma Priority (EXPRESSION);
19252 when Pragma_Priority => Priority : declare
19253 P : constant Node_Id := Parent (N);
19258 Check_No_Identifiers;
19259 Check_Arg_Count (1);
19263 if Nkind (P) = N_Subprogram_Body then
19264 Check_In_Main_Program;
19266 Ent := Defining_Unit_Name (Specification (P));
19268 if Nkind (Ent) = N_Defining_Program_Unit_Name then
19269 Ent := Defining_Identifier (Ent);
19272 Arg := Get_Pragma_Arg (Arg1);
19273 Analyze_And_Resolve (Arg, Standard_Integer);
19277 if not Is_OK_Static_Expression (Arg) then
19278 Flag_Non_Static_Expr
19279 ("main subprogram priority is not static!", Arg);
19282 -- If constraint error, then we already signalled an error
19284 elsif Raises_Constraint_Error (Arg) then
19287 -- Otherwise check in range except if Relaxed_RM_Semantics
19288 -- where we ignore the value if out of range.
19291 if not Relaxed_RM_Semantics
19292 and then not Is_In_Range (Arg, RTE (RE_Priority))
19295 ("main subprogram priority is out of range", Arg1);
19298 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
19302 -- Load an arbitrary entity from System.Tasking.Stages or
19303 -- System.Tasking.Restricted.Stages (depending on the
19304 -- supported profile) to make sure that one of these packages
19305 -- is implicitly with'ed, since we need to have the tasking
19306 -- run time active for the pragma Priority to have any effect.
19307 -- Previously we with'ed the package System.Tasking, but this
19308 -- package does not trigger the required initialization of the
19309 -- run-time library.
19312 Discard : Entity_Id;
19313 pragma Warnings (Off, Discard);
19315 if Restricted_Profile then
19316 Discard := RTE (RE_Activate_Restricted_Tasks);
19318 Discard := RTE (RE_Activate_Tasks);
19322 -- Task or Protected, must be of type Integer
19324 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
19325 Arg := Get_Pragma_Arg (Arg1);
19326 Ent := Defining_Identifier (Parent (P));
19328 -- The expression must be analyzed in the special manner
19329 -- described in "Handling of Default and Per-Object
19330 -- Expressions" in sem.ads.
19332 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
19334 if not Is_OK_Static_Expression (Arg) then
19335 Check_Restriction (Static_Priorities, Arg);
19338 -- Anything else is incorrect
19344 -- Check duplicate pragma before we chain the pragma in the Rep
19345 -- Item chain of Ent.
19347 Check_Duplicate_Pragma (Ent);
19348 Record_Rep_Item (Ent, N);
19351 -----------------------------------
19352 -- Priority_Specific_Dispatching --
19353 -----------------------------------
19355 -- pragma Priority_Specific_Dispatching (
19356 -- policy_IDENTIFIER,
19357 -- first_priority_EXPRESSION,
19358 -- last_priority_EXPRESSION);
19360 when Pragma_Priority_Specific_Dispatching =>
19361 Priority_Specific_Dispatching : declare
19362 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19363 -- This is the entity System.Any_Priority;
19366 Lower_Bound : Node_Id;
19367 Upper_Bound : Node_Id;
19373 Check_Arg_Count (3);
19374 Check_No_Identifiers;
19375 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19376 Check_Valid_Configuration_Pragma;
19377 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19378 DP := Fold_Upper (Name_Buffer (1));
19380 Lower_Bound := Get_Pragma_Arg (Arg2);
19381 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19382 Lower_Val := Expr_Value (Lower_Bound);
19384 Upper_Bound := Get_Pragma_Arg (Arg3);
19385 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19386 Upper_Val := Expr_Value (Upper_Bound);
19388 -- It is not allowed to use Task_Dispatching_Policy and
19389 -- Priority_Specific_Dispatching in the same partition.
19391 if Task_Dispatching_Policy /= ' ' then
19392 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19394 ("pragma% incompatible with Task_Dispatching_Policy#");
19396 -- Check lower bound in range
19398 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19400 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19403 ("first_priority is out of range", Arg2);
19405 -- Check upper bound in range
19407 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19409 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19412 ("last_priority is out of range", Arg3);
19414 -- Check that the priority range is valid
19416 elsif Lower_Val > Upper_Val then
19418 ("last_priority_expression must be greater than or equal to "
19419 & "first_priority_expression");
19421 -- Store the new policy, but always preserve System_Location since
19422 -- we like the error message with the run-time name.
19425 -- Check overlapping in the priority ranges specified in other
19426 -- Priority_Specific_Dispatching pragmas within the same
19427 -- partition. We can only check those we know about.
19430 Specific_Dispatching.First .. Specific_Dispatching.Last
19432 if Specific_Dispatching.Table (J).First_Priority in
19433 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19434 or else Specific_Dispatching.Table (J).Last_Priority in
19435 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19438 Specific_Dispatching.Table (J).Pragma_Loc;
19440 ("priority range overlaps with "
19441 & "Priority_Specific_Dispatching#");
19445 -- The use of Priority_Specific_Dispatching is incompatible
19446 -- with Task_Dispatching_Policy.
19448 if Task_Dispatching_Policy /= ' ' then
19449 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19451 ("Priority_Specific_Dispatching incompatible "
19452 & "with Task_Dispatching_Policy#");
19455 -- The use of Priority_Specific_Dispatching forces ceiling
19458 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19459 Error_Msg_Sloc := Locking_Policy_Sloc;
19461 ("Priority_Specific_Dispatching incompatible "
19462 & "with Locking_Policy#");
19464 -- Set the Ceiling_Locking policy, but preserve System_Location
19465 -- since we like the error message with the run time name.
19468 Locking_Policy := 'C';
19470 if Locking_Policy_Sloc /= System_Location then
19471 Locking_Policy_Sloc := Loc;
19475 -- Add entry in the table
19477 Specific_Dispatching.Append
19478 ((Dispatching_Policy => DP,
19479 First_Priority => UI_To_Int (Lower_Val),
19480 Last_Priority => UI_To_Int (Upper_Val),
19481 Pragma_Loc => Loc));
19483 end Priority_Specific_Dispatching;
19489 -- pragma Profile (profile_IDENTIFIER);
19491 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19493 when Pragma_Profile =>
19495 Check_Arg_Count (1);
19496 Check_Valid_Configuration_Pragma;
19497 Check_No_Identifiers;
19500 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19503 if Chars (Argx) = Name_Ravenscar then
19504 Set_Ravenscar_Profile (Ravenscar, N);
19506 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19507 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19509 elsif Chars (Argx) = Name_Restricted then
19510 Set_Profile_Restrictions
19512 N, Warn => Treat_Restrictions_As_Warnings);
19514 elsif Chars (Argx) = Name_Rational then
19515 Set_Rational_Profile;
19517 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19518 Set_Profile_Restrictions
19519 (No_Implementation_Extensions,
19520 N, Warn => Treat_Restrictions_As_Warnings);
19523 Error_Pragma_Arg ("& is not a valid profile", Argx);
19527 ----------------------
19528 -- Profile_Warnings --
19529 ----------------------
19531 -- pragma Profile_Warnings (profile_IDENTIFIER);
19533 -- profile_IDENTIFIER => Restricted | Ravenscar
19535 when Pragma_Profile_Warnings =>
19537 Check_Arg_Count (1);
19538 Check_Valid_Configuration_Pragma;
19539 Check_No_Identifiers;
19542 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19545 if Chars (Argx) = Name_Ravenscar then
19546 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
19548 elsif Chars (Argx) = Name_Restricted then
19549 Set_Profile_Restrictions (Restricted, N, Warn => True);
19551 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19552 Set_Profile_Restrictions
19553 (No_Implementation_Extensions, N, Warn => True);
19556 Error_Pragma_Arg ("& is not a valid profile", Argx);
19560 --------------------------
19561 -- Propagate_Exceptions --
19562 --------------------------
19564 -- pragma Propagate_Exceptions;
19566 -- Note: this pragma is obsolete and has no effect
19568 when Pragma_Propagate_Exceptions =>
19570 Check_Arg_Count (0);
19572 if Warn_On_Obsolescent_Feature then
19574 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19575 "and has no effect?j?", N);
19578 -----------------------------
19579 -- Provide_Shift_Operators --
19580 -----------------------------
19582 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19584 when Pragma_Provide_Shift_Operators =>
19585 Provide_Shift_Operators : declare
19588 procedure Declare_Shift_Operator (Nam : Name_Id);
19589 -- Insert declaration and pragma Instrinsic for named shift op
19591 ----------------------------
19592 -- Declare_Shift_Operator --
19593 ----------------------------
19595 procedure Declare_Shift_Operator (Nam : Name_Id) is
19601 Make_Subprogram_Declaration (Loc,
19602 Make_Function_Specification (Loc,
19603 Defining_Unit_Name =>
19604 Make_Defining_Identifier (Loc, Chars => Nam),
19606 Result_Definition =>
19607 Make_Identifier (Loc, Chars => Chars (Ent)),
19609 Parameter_Specifications => New_List (
19610 Make_Parameter_Specification (Loc,
19611 Defining_Identifier =>
19612 Make_Defining_Identifier (Loc, Name_Value),
19614 Make_Identifier (Loc, Chars => Chars (Ent))),
19616 Make_Parameter_Specification (Loc,
19617 Defining_Identifier =>
19618 Make_Defining_Identifier (Loc, Name_Amount),
19620 New_Occurrence_Of (Standard_Natural, Loc)))));
19624 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
19625 Pragma_Argument_Associations => New_List (
19626 Make_Pragma_Argument_Association (Loc,
19627 Expression => Make_Identifier (Loc, Name_Intrinsic)),
19628 Make_Pragma_Argument_Association (Loc,
19629 Expression => Make_Identifier (Loc, Nam))));
19631 Insert_After (N, Import);
19632 Insert_After (N, Func);
19633 end Declare_Shift_Operator;
19635 -- Start of processing for Provide_Shift_Operators
19639 Check_Arg_Count (1);
19640 Check_Arg_Is_Local_Name (Arg1);
19642 Arg1 := Get_Pragma_Arg (Arg1);
19644 -- We must have an entity name
19646 if not Is_Entity_Name (Arg1) then
19648 ("pragma % must apply to integer first subtype", Arg1);
19651 -- If no Entity, means there was a prior error so ignore
19653 if Present (Entity (Arg1)) then
19654 Ent := Entity (Arg1);
19656 -- Apply error checks
19658 if not Is_First_Subtype (Ent) then
19660 ("cannot apply pragma %",
19661 "\& is not a first subtype",
19664 elsif not Is_Integer_Type (Ent) then
19666 ("cannot apply pragma %",
19667 "\& is not an integer type",
19670 elsif Has_Shift_Operator (Ent) then
19672 ("cannot apply pragma %",
19673 "\& already has declared shift operators",
19676 elsif Is_Frozen (Ent) then
19678 ("pragma % appears too late",
19679 "\& is already frozen",
19683 -- Now declare the operators. We do this during analysis rather
19684 -- than expansion, since we want the operators available if we
19685 -- are operating in -gnatc or ASIS mode.
19687 Declare_Shift_Operator (Name_Rotate_Left);
19688 Declare_Shift_Operator (Name_Rotate_Right);
19689 Declare_Shift_Operator (Name_Shift_Left);
19690 Declare_Shift_Operator (Name_Shift_Right);
19691 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
19693 end Provide_Shift_Operators;
19699 -- pragma Psect_Object (
19700 -- [Internal =>] LOCAL_NAME,
19701 -- [, [External =>] EXTERNAL_SYMBOL]
19702 -- [, [Size =>] EXTERNAL_SYMBOL]);
19704 when Pragma_Psect_Object | Pragma_Common_Object =>
19705 Psect_Object : declare
19706 Args : Args_List (1 .. 3);
19707 Names : constant Name_List (1 .. 3) := (
19712 Internal : Node_Id renames Args (1);
19713 External : Node_Id renames Args (2);
19714 Size : Node_Id renames Args (3);
19716 Def_Id : Entity_Id;
19718 procedure Check_Arg (Arg : Node_Id);
19719 -- Checks that argument is either a string literal or an
19720 -- identifier, and posts error message if not.
19726 procedure Check_Arg (Arg : Node_Id) is
19728 if not Nkind_In (Original_Node (Arg),
19733 ("inappropriate argument for pragma %", Arg);
19737 -- Start of processing for Common_Object/Psect_Object
19741 Gather_Associations (Names, Args);
19742 Process_Extended_Import_Export_Internal_Arg (Internal);
19744 Def_Id := Entity (Internal);
19746 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19748 ("pragma% must designate an object", Internal);
19751 Check_Arg (Internal);
19753 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19755 ("cannot use pragma% for imported/exported object",
19759 if Is_Concurrent_Type (Etype (Internal)) then
19761 ("cannot specify pragma % for task/protected object",
19765 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19767 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19769 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19772 if Ekind (Def_Id) = E_Constant then
19774 ("cannot specify pragma % for a constant", Internal);
19777 if Is_Record_Type (Etype (Internal)) then
19783 Ent := First_Entity (Etype (Internal));
19784 while Present (Ent) loop
19785 Decl := Declaration_Node (Ent);
19787 if Ekind (Ent) = E_Component
19788 and then Nkind (Decl) = N_Component_Declaration
19789 and then Present (Expression (Decl))
19790 and then Warn_On_Export_Import
19793 ("?x?object for pragma % has defaults", Internal);
19803 if Present (Size) then
19807 if Present (External) then
19808 Check_Arg_Is_External_Name (External);
19811 -- If all error tests pass, link pragma on to the rep item chain
19813 Record_Rep_Item (Def_Id, N);
19820 -- pragma Pure [(library_unit_NAME)];
19822 when Pragma_Pure => Pure : declare
19826 Check_Ada_83_Warning;
19828 -- If the pragma comes from a subprogram instantiation, nothing to
19829 -- check, this can happen at any level of nesting.
19831 if Is_Wrapper_Package (Current_Scope) then
19834 Check_Valid_Library_Unit_Pragma;
19837 if Nkind (N) = N_Null_Statement then
19841 Ent := Find_Lib_Unit_Name;
19843 -- A pragma that applies to a Ghost entity becomes Ghost for the
19844 -- purposes of legality checks and removal of ignored Ghost code.
19846 Mark_Pragma_As_Ghost (N, Ent);
19848 if not Debug_Flag_U then
19850 Set_Has_Pragma_Pure (Ent);
19851 Set_Suppress_Elaboration_Warnings (Ent);
19855 -------------------
19856 -- Pure_Function --
19857 -------------------
19859 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19861 when Pragma_Pure_Function => Pure_Function : declare
19862 Def_Id : Entity_Id;
19865 Effective : Boolean := False;
19869 Check_Arg_Count (1);
19870 Check_Optional_Identifier (Arg1, Name_Entity);
19871 Check_Arg_Is_Local_Name (Arg1);
19872 E_Id := Get_Pragma_Arg (Arg1);
19874 if Error_Posted (E_Id) then
19878 -- Loop through homonyms (overloadings) of referenced entity
19880 E := Entity (E_Id);
19882 -- A pragma that applies to a Ghost entity becomes Ghost for the
19883 -- purposes of legality checks and removal of ignored Ghost code.
19885 Mark_Pragma_As_Ghost (N, E);
19887 if Present (E) then
19889 Def_Id := Get_Base_Subprogram (E);
19891 if not Ekind_In (Def_Id, E_Function,
19892 E_Generic_Function,
19896 ("pragma% requires a function name", Arg1);
19899 Set_Is_Pure (Def_Id);
19901 if not Has_Pragma_Pure_Function (Def_Id) then
19902 Set_Has_Pragma_Pure_Function (Def_Id);
19906 exit when From_Aspect_Specification (N);
19908 exit when No (E) or else Scope (E) /= Current_Scope;
19912 and then Warn_On_Redundant_Constructs
19915 ("pragma Pure_Function on& is redundant?r?",
19921 --------------------
19922 -- Queuing_Policy --
19923 --------------------
19925 -- pragma Queuing_Policy (policy_IDENTIFIER);
19927 when Pragma_Queuing_Policy => declare
19931 Check_Ada_83_Warning;
19932 Check_Arg_Count (1);
19933 Check_No_Identifiers;
19934 Check_Arg_Is_Queuing_Policy (Arg1);
19935 Check_Valid_Configuration_Pragma;
19936 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19937 QP := Fold_Upper (Name_Buffer (1));
19939 if Queuing_Policy /= ' '
19940 and then Queuing_Policy /= QP
19942 Error_Msg_Sloc := Queuing_Policy_Sloc;
19943 Error_Pragma ("queuing policy incompatible with policy#");
19945 -- Set new policy, but always preserve System_Location since we
19946 -- like the error message with the run time name.
19949 Queuing_Policy := QP;
19951 if Queuing_Policy_Sloc /= System_Location then
19952 Queuing_Policy_Sloc := Loc;
19961 -- pragma Rational, for compatibility with foreign compiler
19963 when Pragma_Rational =>
19964 Set_Rational_Profile;
19966 ---------------------
19967 -- Refined_Depends --
19968 ---------------------
19970 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19972 -- DEPENDENCY_RELATION ::=
19974 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19976 -- DEPENDENCY_CLAUSE ::=
19977 -- OUTPUT_LIST =>[+] INPUT_LIST
19978 -- | NULL_DEPENDENCY_CLAUSE
19980 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19982 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19984 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19986 -- OUTPUT ::= NAME | FUNCTION_RESULT
19989 -- where FUNCTION_RESULT is a function Result attribute_reference
19991 -- Characteristics:
19993 -- * Analysis - The annotation undergoes initial checks to verify
19994 -- the legal placement and context. Secondary checks fully analyze
19995 -- the dependency clauses/global list in:
19997 -- Analyze_Refined_Depends_In_Decl_Part
19999 -- * Expansion - None.
20001 -- * Template - The annotation utilizes the generic template of the
20002 -- related subprogram body.
20004 -- * Globals - Capture of global references must occur after full
20007 -- * Instance - The annotation is instantiated automatically when
20008 -- the related generic subprogram body is instantiated.
20010 when Pragma_Refined_Depends => Refined_Depends : declare
20011 Body_Id : Entity_Id;
20013 Spec_Id : Entity_Id;
20016 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20020 -- Chain the pragma on the contract for further processing by
20021 -- Analyze_Refined_Depends_In_Decl_Part.
20023 Add_Contract_Item (N, Body_Id);
20025 -- The legality checks of pragmas Refined_Depends and
20026 -- Refined_Global are affected by the SPARK mode in effect and
20027 -- the volatility of the context. In addition these two pragmas
20028 -- are subject to an inherent order:
20030 -- 1) Refined_Global
20031 -- 2) Refined_Depends
20033 -- Analyze all these pragmas in the order outlined above
20035 Analyze_If_Present (Pragma_SPARK_Mode);
20036 Analyze_If_Present (Pragma_Volatile_Function);
20037 Analyze_If_Present (Pragma_Refined_Global);
20038 Analyze_Refined_Depends_In_Decl_Part (N);
20040 end Refined_Depends;
20042 --------------------
20043 -- Refined_Global --
20044 --------------------
20046 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20048 -- GLOBAL_SPECIFICATION ::=
20051 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20053 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20055 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20056 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20057 -- GLOBAL_ITEM ::= NAME
20059 -- Characteristics:
20061 -- * Analysis - The annotation undergoes initial checks to verify
20062 -- the legal placement and context. Secondary checks fully analyze
20063 -- the dependency clauses/global list in:
20065 -- Analyze_Refined_Global_In_Decl_Part
20067 -- * Expansion - None.
20069 -- * Template - The annotation utilizes the generic template of the
20070 -- related subprogram body.
20072 -- * Globals - Capture of global references must occur after full
20075 -- * Instance - The annotation is instantiated automatically when
20076 -- the related generic subprogram body is instantiated.
20078 when Pragma_Refined_Global => Refined_Global : declare
20079 Body_Id : Entity_Id;
20081 Spec_Id : Entity_Id;
20084 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20088 -- Chain the pragma on the contract for further processing by
20089 -- Analyze_Refined_Global_In_Decl_Part.
20091 Add_Contract_Item (N, Body_Id);
20093 -- The legality checks of pragmas Refined_Depends and
20094 -- Refined_Global are affected by the SPARK mode in effect and
20095 -- the volatility of the context. In addition these two pragmas
20096 -- are subject to an inherent order:
20098 -- 1) Refined_Global
20099 -- 2) Refined_Depends
20101 -- Analyze all these pragmas in the order outlined above
20103 Analyze_If_Present (Pragma_SPARK_Mode);
20104 Analyze_If_Present (Pragma_Volatile_Function);
20105 Analyze_Refined_Global_In_Decl_Part (N);
20106 Analyze_If_Present (Pragma_Refined_Depends);
20108 end Refined_Global;
20114 -- pragma Refined_Post (boolean_EXPRESSION);
20116 -- Characteristics:
20118 -- * Analysis - The annotation is fully analyzed immediately upon
20119 -- elaboration as it cannot forward reference entities.
20121 -- * Expansion - The annotation is expanded during the expansion of
20122 -- the related subprogram body contract as performed in:
20124 -- Expand_Subprogram_Contract
20126 -- * Template - The annotation utilizes the generic template of the
20127 -- related subprogram body.
20129 -- * Globals - Capture of global references must occur after full
20132 -- * Instance - The annotation is instantiated automatically when
20133 -- the related generic subprogram body is instantiated.
20135 when Pragma_Refined_Post => Refined_Post : declare
20136 Body_Id : Entity_Id;
20138 Spec_Id : Entity_Id;
20141 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20143 -- Fully analyze the pragma when it appears inside a subprogram
20144 -- body because it cannot benefit from forward references.
20148 -- Chain the pragma on the contract for completeness
20150 Add_Contract_Item (N, Body_Id);
20152 -- The legality checks of pragma Refined_Post are affected by
20153 -- the SPARK mode in effect and the volatility of the context.
20154 -- Analyze all pragmas in a specific order.
20156 Analyze_If_Present (Pragma_SPARK_Mode);
20157 Analyze_If_Present (Pragma_Volatile_Function);
20158 Analyze_Pre_Post_Condition_In_Decl_Part (N);
20160 -- Currently it is not possible to inline pre/postconditions on
20161 -- a subprogram subject to pragma Inline_Always.
20163 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
20167 -------------------
20168 -- Refined_State --
20169 -------------------
20171 -- pragma Refined_State (REFINEMENT_LIST);
20173 -- REFINEMENT_LIST ::=
20174 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20176 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20178 -- CONSTITUENT_LIST ::=
20181 -- | (CONSTITUENT {, CONSTITUENT})
20183 -- CONSTITUENT ::= object_NAME | state_NAME
20185 -- Characteristics:
20187 -- * Analysis - The annotation undergoes initial checks to verify
20188 -- the legal placement and context. Secondary checks preanalyze the
20189 -- refinement clauses in:
20191 -- Analyze_Refined_State_In_Decl_Part
20193 -- * Expansion - None.
20195 -- * Template - The annotation utilizes the template of the related
20198 -- * Globals - Capture of global references must occur after full
20201 -- * Instance - The annotation is instantiated automatically when
20202 -- the related generic package body is instantiated.
20204 when Pragma_Refined_State => Refined_State : declare
20205 Pack_Decl : Node_Id;
20206 Spec_Id : Entity_Id;
20210 Check_No_Identifiers;
20211 Check_Arg_Count (1);
20213 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
20215 -- Ensure the proper placement of the pragma. Refined states must
20216 -- be associated with a package body.
20218 if Nkind (Pack_Decl) = N_Package_Body then
20221 -- Otherwise the pragma is associated with an illegal construct
20228 Spec_Id := Corresponding_Spec (Pack_Decl);
20230 -- Chain the pragma on the contract for further processing by
20231 -- Analyze_Refined_State_In_Decl_Part.
20233 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
20235 -- The legality checks of pragma Refined_State are affected by the
20236 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20238 Analyze_If_Present (Pragma_SPARK_Mode);
20240 -- A pragma that applies to a Ghost entity becomes Ghost for the
20241 -- purposes of legality checks and removal of ignored Ghost code.
20243 Mark_Pragma_As_Ghost (N, Spec_Id);
20245 -- State refinement is allowed only when the corresponding package
20246 -- declaration has non-null pragma Abstract_State. Refinement not
20247 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20249 if SPARK_Mode /= Off
20251 (No (Abstract_States (Spec_Id))
20252 or else Has_Null_Abstract_State (Spec_Id))
20255 ("useless refinement, package & does not define abstract "
20256 & "states", N, Spec_Id);
20261 -----------------------
20262 -- Relative_Deadline --
20263 -----------------------
20265 -- pragma Relative_Deadline (time_span_EXPRESSION);
20267 when Pragma_Relative_Deadline => Relative_Deadline : declare
20268 P : constant Node_Id := Parent (N);
20273 Check_No_Identifiers;
20274 Check_Arg_Count (1);
20276 Arg := Get_Pragma_Arg (Arg1);
20278 -- The expression must be analyzed in the special manner described
20279 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20281 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
20285 if Nkind (P) = N_Subprogram_Body then
20286 Check_In_Main_Program;
20288 -- Only Task and subprogram cases allowed
20290 elsif Nkind (P) /= N_Task_Definition then
20294 -- Check duplicate pragma before we set the corresponding flag
20296 if Has_Relative_Deadline_Pragma (P) then
20297 Error_Pragma ("duplicate pragma% not allowed");
20300 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20301 -- Relative_Deadline pragma node cannot be inserted in the Rep
20302 -- Item chain of Ent since it is rewritten by the expander as a
20303 -- procedure call statement that will break the chain.
20305 Set_Has_Relative_Deadline_Pragma (P);
20306 end Relative_Deadline;
20308 ------------------------
20309 -- Remote_Access_Type --
20310 ------------------------
20312 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20314 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
20319 Check_Arg_Count (1);
20320 Check_Optional_Identifier (Arg1, Name_Entity);
20321 Check_Arg_Is_Local_Name (Arg1);
20323 E := Entity (Get_Pragma_Arg (Arg1));
20325 -- A pragma that applies to a Ghost entity becomes Ghost for the
20326 -- purposes of legality checks and removal of ignored Ghost code.
20328 Mark_Pragma_As_Ghost (N, E);
20330 if Nkind (Parent (E)) = N_Formal_Type_Declaration
20331 and then Ekind (E) = E_General_Access_Type
20332 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
20333 and then Scope (Root_Type (Directly_Designated_Type (E)))
20335 and then Is_Valid_Remote_Object_Type
20336 (Root_Type (Directly_Designated_Type (E)))
20338 Set_Is_Remote_Types (E);
20342 ("pragma% applies only to formal access-to-class-wide types",
20345 end Remote_Access_Type;
20347 ---------------------------
20348 -- Remote_Call_Interface --
20349 ---------------------------
20351 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20353 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20354 Cunit_Node : Node_Id;
20355 Cunit_Ent : Entity_Id;
20359 Check_Ada_83_Warning;
20360 Check_Valid_Library_Unit_Pragma;
20362 if Nkind (N) = N_Null_Statement then
20366 Cunit_Node := Cunit (Current_Sem_Unit);
20367 K := Nkind (Unit (Cunit_Node));
20368 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20370 -- A pragma that applies to a Ghost entity becomes Ghost for the
20371 -- purposes of legality checks and removal of ignored Ghost code.
20373 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20375 if K = N_Package_Declaration
20376 or else K = N_Generic_Package_Declaration
20377 or else K = N_Subprogram_Declaration
20378 or else K = N_Generic_Subprogram_Declaration
20379 or else (K = N_Subprogram_Body
20380 and then Acts_As_Spec (Unit (Cunit_Node)))
20385 "pragma% must apply to package or subprogram declaration");
20388 Set_Is_Remote_Call_Interface (Cunit_Ent);
20389 end Remote_Call_Interface;
20395 -- pragma Remote_Types [(library_unit_NAME)];
20397 when Pragma_Remote_Types => Remote_Types : declare
20398 Cunit_Node : Node_Id;
20399 Cunit_Ent : Entity_Id;
20402 Check_Ada_83_Warning;
20403 Check_Valid_Library_Unit_Pragma;
20405 if Nkind (N) = N_Null_Statement then
20409 Cunit_Node := Cunit (Current_Sem_Unit);
20410 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20412 -- A pragma that applies to a Ghost entity becomes Ghost for the
20413 -- purposes of legality checks and removal of ignored Ghost code.
20415 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20417 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20418 N_Generic_Package_Declaration)
20421 ("pragma% can only apply to a package declaration");
20424 Set_Is_Remote_Types (Cunit_Ent);
20431 -- pragma Ravenscar;
20433 when Pragma_Ravenscar =>
20435 Check_Arg_Count (0);
20436 Check_Valid_Configuration_Pragma;
20437 Set_Ravenscar_Profile (Ravenscar, N);
20439 if Warn_On_Obsolescent_Feature then
20441 ("pragma Ravenscar is an obsolescent feature?j?", N);
20443 ("|use pragma Profile (Ravenscar) instead?j?", N);
20446 -------------------------
20447 -- Restricted_Run_Time --
20448 -------------------------
20450 -- pragma Restricted_Run_Time;
20452 when Pragma_Restricted_Run_Time =>
20454 Check_Arg_Count (0);
20455 Check_Valid_Configuration_Pragma;
20456 Set_Profile_Restrictions
20457 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20459 if Warn_On_Obsolescent_Feature then
20461 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20464 ("|use pragma Profile (Restricted) instead?j?", N);
20471 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20474 -- restriction_IDENTIFIER
20475 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20477 when Pragma_Restrictions =>
20478 Process_Restrictions_Or_Restriction_Warnings
20479 (Warn => Treat_Restrictions_As_Warnings);
20481 --------------------------
20482 -- Restriction_Warnings --
20483 --------------------------
20485 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20488 -- restriction_IDENTIFIER
20489 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20491 when Pragma_Restriction_Warnings =>
20493 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20499 -- pragma Reviewable;
20501 when Pragma_Reviewable =>
20502 Check_Ada_83_Warning;
20503 Check_Arg_Count (0);
20505 -- Call dummy debugging function rv. This is done to assist front
20506 -- end debugging. By placing a Reviewable pragma in the source
20507 -- program, a breakpoint on rv catches this place in the source,
20508 -- allowing convenient stepping to the point of interest.
20512 --------------------------
20513 -- Short_Circuit_And_Or --
20514 --------------------------
20516 -- pragma Short_Circuit_And_Or;
20518 when Pragma_Short_Circuit_And_Or =>
20520 Check_Arg_Count (0);
20521 Check_Valid_Configuration_Pragma;
20522 Short_Circuit_And_Or := True;
20524 -------------------
20525 -- Share_Generic --
20526 -------------------
20528 -- pragma Share_Generic (GNAME {, GNAME});
20530 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20532 when Pragma_Share_Generic =>
20534 Process_Generic_List;
20540 -- pragma Shared (LOCAL_NAME);
20542 when Pragma_Shared =>
20544 Process_Atomic_Independent_Shared_Volatile;
20546 --------------------
20547 -- Shared_Passive --
20548 --------------------
20550 -- pragma Shared_Passive [(library_unit_NAME)];
20552 -- Set the flag Is_Shared_Passive of program unit name entity
20554 when Pragma_Shared_Passive => Shared_Passive : declare
20555 Cunit_Node : Node_Id;
20556 Cunit_Ent : Entity_Id;
20559 Check_Ada_83_Warning;
20560 Check_Valid_Library_Unit_Pragma;
20562 if Nkind (N) = N_Null_Statement then
20566 Cunit_Node := Cunit (Current_Sem_Unit);
20567 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20569 -- A pragma that applies to a Ghost entity becomes Ghost for the
20570 -- purposes of legality checks and removal of ignored Ghost code.
20572 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20574 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20575 N_Generic_Package_Declaration)
20578 ("pragma% can only apply to a package declaration");
20581 Set_Is_Shared_Passive (Cunit_Ent);
20582 end Shared_Passive;
20584 -----------------------
20585 -- Short_Descriptors --
20586 -----------------------
20588 -- pragma Short_Descriptors;
20590 -- Recognize and validate, but otherwise ignore
20592 when Pragma_Short_Descriptors =>
20594 Check_Arg_Count (0);
20595 Check_Valid_Configuration_Pragma;
20597 ------------------------------
20598 -- Simple_Storage_Pool_Type --
20599 ------------------------------
20601 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20603 when Pragma_Simple_Storage_Pool_Type =>
20604 Simple_Storage_Pool_Type : declare
20610 Check_Arg_Count (1);
20611 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20613 Type_Id := Get_Pragma_Arg (Arg1);
20614 Find_Type (Type_Id);
20615 Typ := Entity (Type_Id);
20617 if Typ = Any_Type then
20621 -- A pragma that applies to a Ghost entity becomes Ghost for the
20622 -- purposes of legality checks and removal of ignored Ghost code.
20624 Mark_Pragma_As_Ghost (N, Typ);
20626 -- We require the pragma to apply to a type declared in a package
20627 -- declaration, but not (immediately) within a package body.
20629 if Ekind (Current_Scope) /= E_Package
20630 or else In_Package_Body (Current_Scope)
20633 ("pragma% can only apply to type declared immediately "
20634 & "within a package declaration");
20637 -- A simple storage pool type must be an immutably limited record
20638 -- or private type. If the pragma is given for a private type,
20639 -- the full type is similarly restricted (which is checked later
20640 -- in Freeze_Entity).
20642 if Is_Record_Type (Typ)
20643 and then not Is_Limited_View (Typ)
20646 ("pragma% can only apply to explicitly limited record type");
20648 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
20650 ("pragma% can only apply to a private type that is limited");
20652 elsif not Is_Record_Type (Typ)
20653 and then not Is_Private_Type (Typ)
20656 ("pragma% can only apply to limited record or private type");
20659 Record_Rep_Item (Typ, N);
20660 end Simple_Storage_Pool_Type;
20662 ----------------------
20663 -- Source_File_Name --
20664 ----------------------
20666 -- There are five forms for this pragma:
20668 -- pragma Source_File_Name (
20669 -- [UNIT_NAME =>] unit_NAME,
20670 -- BODY_FILE_NAME => STRING_LITERAL
20671 -- [, [INDEX =>] INTEGER_LITERAL]);
20673 -- pragma Source_File_Name (
20674 -- [UNIT_NAME =>] unit_NAME,
20675 -- SPEC_FILE_NAME => STRING_LITERAL
20676 -- [, [INDEX =>] INTEGER_LITERAL]);
20678 -- pragma Source_File_Name (
20679 -- BODY_FILE_NAME => STRING_LITERAL
20680 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20681 -- [, CASING => CASING_SPEC]);
20683 -- pragma Source_File_Name (
20684 -- SPEC_FILE_NAME => STRING_LITERAL
20685 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20686 -- [, CASING => CASING_SPEC]);
20688 -- pragma Source_File_Name (
20689 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20690 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20691 -- [, CASING => CASING_SPEC]);
20693 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20695 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20696 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20697 -- only be used when no project file is used, while SFNP can only be
20698 -- used when a project file is used.
20700 -- No processing here. Processing was completed during parsing, since
20701 -- we need to have file names set as early as possible. Units are
20702 -- loaded well before semantic processing starts.
20704 -- The only processing we defer to this point is the check for
20705 -- correct placement.
20707 when Pragma_Source_File_Name =>
20709 Check_Valid_Configuration_Pragma;
20711 ------------------------------
20712 -- Source_File_Name_Project --
20713 ------------------------------
20715 -- See Source_File_Name for syntax
20717 -- No processing here. Processing was completed during parsing, since
20718 -- we need to have file names set as early as possible. Units are
20719 -- loaded well before semantic processing starts.
20721 -- The only processing we defer to this point is the check for
20722 -- correct placement.
20724 when Pragma_Source_File_Name_Project =>
20726 Check_Valid_Configuration_Pragma;
20728 -- Check that a pragma Source_File_Name_Project is used only in a
20729 -- configuration pragmas file.
20731 -- Pragmas Source_File_Name_Project should only be generated by
20732 -- the Project Manager in configuration pragmas files.
20734 -- This is really an ugly test. It seems to depend on some
20735 -- accidental and undocumented property. At the very least it
20736 -- needs to be documented, but it would be better to have a
20737 -- clean way of testing if we are in a configuration file???
20739 if Present (Parent (N)) then
20741 ("pragma% can only appear in a configuration pragmas file");
20744 ----------------------
20745 -- Source_Reference --
20746 ----------------------
20748 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20750 -- Nothing to do, all processing completed in Par.Prag, since we need
20751 -- the information for possible parser messages that are output.
20753 when Pragma_Source_Reference =>
20760 -- pragma SPARK_Mode [(On | Off)];
20762 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20763 Mode_Id : SPARK_Mode_Type;
20765 procedure Check_Pragma_Conformance
20766 (Context_Pragma : Node_Id;
20767 Entity : Entity_Id;
20768 Entity_Pragma : Node_Id);
20769 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20770 -- conformance of pragma N depending the following scenarios:
20772 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20773 -- compatible with the pragma Context_Pragma that was inherited
20774 -- from the context:
20775 -- * If the mode of Context_Pragma is ON, then the new mode can
20777 -- * If the mode of Context_Pragma is OFF, then the only allowed
20778 -- new mode is also OFF. Emit error if this is not the case.
20780 -- If Entity is not Empty, verify that pragma N is compatible with
20781 -- pragma Entity_Pragma that belongs to Entity.
20782 -- * If Entity_Pragma is Empty, always issue an error as this
20783 -- corresponds to the case where a previous section of Entity
20784 -- has no SPARK_Mode set.
20785 -- * If the mode of Entity_Pragma is ON, then the new mode can
20787 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20788 -- new mode is also OFF. Emit error if this is not the case.
20790 procedure Check_Library_Level_Entity (E : Entity_Id);
20791 -- Subsidiary to routines Process_xxx. Verify that the related
20792 -- entity E subject to pragma SPARK_Mode is library-level.
20794 procedure Process_Body (Decl : Node_Id);
20795 -- Verify the legality of pragma SPARK_Mode when it appears as the
20796 -- top of the body declarations of entry, package, protected unit,
20797 -- subprogram or task unit body denoted by Decl.
20799 procedure Process_Overloadable (Decl : Node_Id);
20800 -- Verify the legality of pragma SPARK_Mode when it applies to an
20801 -- entry or [generic] subprogram declaration denoted by Decl.
20803 procedure Process_Private_Part (Decl : Node_Id);
20804 -- Verify the legality of pragma SPARK_Mode when it appears at the
20805 -- top of the private declarations of a package spec, protected or
20806 -- task unit declaration denoted by Decl.
20808 procedure Process_Statement_Part (Decl : Node_Id);
20809 -- Verify the legality of pragma SPARK_Mode when it appears at the
20810 -- top of the statement sequence of a package body denoted by node
20813 procedure Process_Visible_Part (Decl : Node_Id);
20814 -- Verify the legality of pragma SPARK_Mode when it appears at the
20815 -- top of the visible declarations of a package spec, protected or
20816 -- task unit declaration denoted by Decl. The routine is also used
20817 -- on protected or task units declared without a definition.
20819 procedure Set_SPARK_Context;
20820 -- Subsidiary to routines Process_xxx. Set the global variables
20821 -- which represent the mode of the context from pragma N. Ensure
20822 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20824 ------------------------------
20825 -- Check_Pragma_Conformance --
20826 ------------------------------
20828 procedure Check_Pragma_Conformance
20829 (Context_Pragma : Node_Id;
20830 Entity : Entity_Id;
20831 Entity_Pragma : Node_Id)
20833 Err_Id : Entity_Id;
20837 -- The current pragma may appear without an argument. If this
20838 -- is the case, associate all error messages with the pragma
20841 if Present (Arg1) then
20847 -- The mode of the current pragma is compared against that of
20848 -- an enclosing context.
20850 if Present (Context_Pragma) then
20851 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20853 -- Issue an error if the new mode is less restrictive than
20854 -- that of the context.
20856 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
20857 and then Get_SPARK_Mode_From_Annotation (N) = On
20860 ("cannot change SPARK_Mode from Off to On", Err_N);
20861 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20862 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20867 -- The mode of the current pragma is compared against that of
20868 -- an initial package, protected type, subprogram or task type
20871 if Present (Entity) then
20873 -- A simple protected or task type is transformed into an
20874 -- anonymous type whose name cannot be used to issue error
20875 -- messages. Recover the original entity of the type.
20877 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20880 (Original_Node (Unit_Declaration_Node (Entity)));
20885 -- Both the initial declaration and the completion carry
20886 -- SPARK_Mode pragmas.
20888 if Present (Entity_Pragma) then
20889 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20891 -- Issue an error if the new mode is less restrictive
20892 -- than that of the initial declaration.
20894 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
20895 and then Get_SPARK_Mode_From_Annotation (N) = On
20897 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20898 Error_Msg_Sloc := Sloc (Entity_Pragma);
20900 ("\value Off was set for SPARK_Mode on&#",
20905 -- Otherwise the initial declaration lacks a SPARK_Mode
20906 -- pragma in which case the current pragma is illegal as
20907 -- it cannot "complete".
20910 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20911 Error_Msg_Sloc := Sloc (Err_Id);
20913 ("\no value was set for SPARK_Mode on&#",
20918 end Check_Pragma_Conformance;
20920 --------------------------------
20921 -- Check_Library_Level_Entity --
20922 --------------------------------
20924 procedure Check_Library_Level_Entity (E : Entity_Id) is
20925 procedure Add_Entity_To_Name_Buffer;
20926 -- Add the E_Kind of entity E to the name buffer
20928 -------------------------------
20929 -- Add_Entity_To_Name_Buffer --
20930 -------------------------------
20932 procedure Add_Entity_To_Name_Buffer is
20934 if Ekind_In (E, E_Entry, E_Entry_Family) then
20935 Add_Str_To_Name_Buffer ("entry");
20937 elsif Ekind_In (E, E_Generic_Package,
20941 Add_Str_To_Name_Buffer ("package");
20943 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20944 Add_Str_To_Name_Buffer ("protected type");
20946 elsif Ekind_In (E, E_Function,
20947 E_Generic_Function,
20948 E_Generic_Procedure,
20952 Add_Str_To_Name_Buffer ("subprogram");
20955 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20956 Add_Str_To_Name_Buffer ("task type");
20958 end Add_Entity_To_Name_Buffer;
20962 Msg_1 : constant String := "incorrect placement of pragma%";
20965 -- Start of processing for Check_Library_Level_Entity
20968 if not Is_Library_Level_Entity (E) then
20969 Error_Msg_Name_1 := Pname;
20970 Error_Msg_N (Fix_Error (Msg_1), N);
20973 Add_Str_To_Name_Buffer ("\& is not a library-level ");
20974 Add_Entity_To_Name_Buffer;
20976 Msg_2 := Name_Find;
20977 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20981 end Check_Library_Level_Entity;
20987 procedure Process_Body (Decl : Node_Id) is
20988 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20989 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20992 -- Ignore pragma when applied to the special body created for
20993 -- inlining, recognized by its internal name _Parent.
20995 if Chars (Body_Id) = Name_uParent then
20999 Check_Library_Level_Entity (Body_Id);
21001 -- For entry bodies, verify the legality against:
21002 -- * The mode of the context
21003 -- * The mode of the spec (if any)
21005 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
21007 -- A stand alone subprogram body
21009 if Body_Id = Spec_Id then
21010 Check_Pragma_Conformance
21011 (Context_Pragma => SPARK_Pragma (Body_Id),
21013 Entity_Pragma => Empty);
21015 -- An entry or subprogram body that completes a previous
21019 Check_Pragma_Conformance
21020 (Context_Pragma => SPARK_Pragma (Body_Id),
21022 Entity_Pragma => SPARK_Pragma (Spec_Id));
21026 Set_SPARK_Pragma (Body_Id, N);
21027 Set_SPARK_Pragma_Inherited (Body_Id, False);
21029 -- For package bodies, verify the legality against:
21030 -- * The mode of the context
21031 -- * The mode of the private part
21033 -- This case is separated from protected and task bodies
21034 -- because the statement part of the package body inherits
21035 -- the mode of the body declarations.
21037 elsif Nkind (Decl) = N_Package_Body then
21038 Check_Pragma_Conformance
21039 (Context_Pragma => SPARK_Pragma (Body_Id),
21041 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21044 Set_SPARK_Pragma (Body_Id, N);
21045 Set_SPARK_Pragma_Inherited (Body_Id, False);
21046 Set_SPARK_Aux_Pragma (Body_Id, N);
21047 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
21049 -- For protected and task bodies, verify the legality against:
21050 -- * The mode of the context
21051 -- * The mode of the private part
21055 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
21057 Check_Pragma_Conformance
21058 (Context_Pragma => SPARK_Pragma (Body_Id),
21060 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
21063 Set_SPARK_Pragma (Body_Id, N);
21064 Set_SPARK_Pragma_Inherited (Body_Id, False);
21068 --------------------------
21069 -- Process_Overloadable --
21070 --------------------------
21072 procedure Process_Overloadable (Decl : Node_Id) is
21073 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21074 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
21077 Check_Library_Level_Entity (Spec_Id);
21079 -- Verify the legality against:
21080 -- * The mode of the context
21082 Check_Pragma_Conformance
21083 (Context_Pragma => SPARK_Pragma (Spec_Id),
21085 Entity_Pragma => Empty);
21087 Set_SPARK_Pragma (Spec_Id, N);
21088 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21090 -- When the pragma applies to the anonymous object created for
21091 -- a single task type, decorate the type as well. This scenario
21092 -- arises when the single task type lacks a task definition,
21093 -- therefore there is no issue with respect to a potential
21094 -- pragma SPARK_Mode in the private part.
21096 -- task type Anon_Task_Typ;
21097 -- Obj : Anon_Task_Typ;
21098 -- pragma SPARK_Mode ...;
21100 if Is_Single_Task_Object (Spec_Id) then
21101 Set_SPARK_Pragma (Spec_Typ, N);
21102 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
21103 Set_SPARK_Aux_Pragma (Spec_Typ, N);
21104 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
21106 end Process_Overloadable;
21108 --------------------------
21109 -- Process_Private_Part --
21110 --------------------------
21112 procedure Process_Private_Part (Decl : Node_Id) is
21113 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21116 Check_Library_Level_Entity (Spec_Id);
21118 -- Verify the legality against:
21119 -- * The mode of the visible declarations
21121 Check_Pragma_Conformance
21122 (Context_Pragma => Empty,
21124 Entity_Pragma => SPARK_Pragma (Spec_Id));
21127 Set_SPARK_Aux_Pragma (Spec_Id, N);
21128 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
21129 end Process_Private_Part;
21131 ----------------------------
21132 -- Process_Statement_Part --
21133 ----------------------------
21135 procedure Process_Statement_Part (Decl : Node_Id) is
21136 Body_Id : constant Entity_Id := Defining_Entity (Decl);
21139 Check_Library_Level_Entity (Body_Id);
21141 -- Verify the legality against:
21142 -- * The mode of the body declarations
21144 Check_Pragma_Conformance
21145 (Context_Pragma => Empty,
21147 Entity_Pragma => SPARK_Pragma (Body_Id));
21150 Set_SPARK_Aux_Pragma (Body_Id, N);
21151 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
21152 end Process_Statement_Part;
21154 --------------------------
21155 -- Process_Visible_Part --
21156 --------------------------
21158 procedure Process_Visible_Part (Decl : Node_Id) is
21159 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21160 Obj_Id : Entity_Id;
21163 Check_Library_Level_Entity (Spec_Id);
21165 -- Verify the legality against:
21166 -- * The mode of the context
21168 Check_Pragma_Conformance
21169 (Context_Pragma => SPARK_Pragma (Spec_Id),
21171 Entity_Pragma => Empty);
21173 -- A task unit declared without a definition does not set the
21174 -- SPARK_Mode of the context because the task does not have any
21175 -- entries that could inherit the mode.
21177 if not Nkind_In (Decl, N_Single_Task_Declaration,
21178 N_Task_Type_Declaration)
21183 Set_SPARK_Pragma (Spec_Id, N);
21184 Set_SPARK_Pragma_Inherited (Spec_Id, False);
21185 Set_SPARK_Aux_Pragma (Spec_Id, N);
21186 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
21188 -- When the pragma applies to a single protected or task type,
21189 -- decorate the corresponding anonymous object as well.
21191 -- protected Anon_Prot_Typ is
21192 -- pragma SPARK_Mode ...;
21194 -- end Anon_Prot_Typ;
21196 -- Obj : Anon_Prot_Typ;
21198 if Is_Single_Concurrent_Type (Spec_Id) then
21199 Obj_Id := Anonymous_Object (Spec_Id);
21201 Set_SPARK_Pragma (Obj_Id, N);
21202 Set_SPARK_Pragma_Inherited (Obj_Id, False);
21204 end Process_Visible_Part;
21206 -----------------------
21207 -- Set_SPARK_Context --
21208 -----------------------
21210 procedure Set_SPARK_Context is
21212 SPARK_Mode := Mode_Id;
21213 SPARK_Mode_Pragma := N;
21214 end Set_SPARK_Context;
21222 -- Start of processing for Do_SPARK_Mode
21225 -- When a SPARK_Mode pragma appears inside an instantiation whose
21226 -- enclosing context has SPARK_Mode set to "off", the pragma has
21227 -- no semantic effect.
21229 if Ignore_Pragma_SPARK_Mode then
21230 Rewrite (N, Make_Null_Statement (Loc));
21236 Check_No_Identifiers;
21237 Check_At_Most_N_Arguments (1);
21239 -- Check the legality of the mode (no argument = ON)
21241 if Arg_Count = 1 then
21242 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21243 Mode := Chars (Get_Pragma_Arg (Arg1));
21248 Mode_Id := Get_SPARK_Mode_Type (Mode);
21249 Context := Parent (N);
21251 -- The pragma appears in a configuration file
21253 if No (Context) then
21254 Check_Valid_Configuration_Pragma;
21256 if Present (SPARK_Mode_Pragma) then
21257 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
21258 Error_Msg_N ("pragma% duplicates pragma declared#", N);
21264 -- The pragma acts as a configuration pragma in a compilation unit
21266 -- pragma SPARK_Mode ...;
21267 -- package Pack is ...;
21269 elsif Nkind (Context) = N_Compilation_Unit
21270 and then List_Containing (N) = Context_Items (Context)
21272 Check_Valid_Configuration_Pragma;
21275 -- Otherwise the placement of the pragma within the tree dictates
21276 -- its associated construct. Inspect the declarative list where
21277 -- the pragma resides to find a potential construct.
21281 while Present (Stmt) loop
21283 -- Skip prior pragmas, but check for duplicates. Note that
21284 -- this also takes care of pragmas generated for aspects.
21286 if Nkind (Stmt) = N_Pragma then
21287 if Pragma_Name (Stmt) = Pname then
21288 Error_Msg_Name_1 := Pname;
21289 Error_Msg_Sloc := Sloc (Stmt);
21290 Error_Msg_N ("pragma% duplicates pragma declared#", N);
21294 -- The pragma applies to an expression function that has
21295 -- already been rewritten into a subprogram declaration.
21297 -- function Expr_Func return ... is (...);
21298 -- pragma SPARK_Mode ...;
21300 elsif Nkind (Stmt) = N_Subprogram_Declaration
21301 and then Nkind (Original_Node (Stmt)) =
21302 N_Expression_Function
21304 Process_Overloadable (Stmt);
21307 -- The pragma applies to the anonymous object created for a
21308 -- single concurrent type.
21310 -- protected type Anon_Prot_Typ ...;
21311 -- Obj : Anon_Prot_Typ;
21312 -- pragma SPARK_Mode ...;
21314 elsif Nkind (Stmt) = N_Object_Declaration
21315 and then Is_Single_Concurrent_Object
21316 (Defining_Entity (Stmt))
21318 Process_Overloadable (Stmt);
21321 -- Skip internally generated code
21323 elsif not Comes_From_Source (Stmt) then
21326 -- The pragma applies to an entry or [generic] subprogram
21330 -- pragma SPARK_Mode ...;
21333 -- procedure Proc ...;
21334 -- pragma SPARK_Mode ...;
21336 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
21337 N_Subprogram_Declaration)
21338 or else (Nkind (Stmt) = N_Entry_Declaration
21339 and then Is_Protected_Type
21340 (Scope (Defining_Entity (Stmt))))
21342 Process_Overloadable (Stmt);
21345 -- Otherwise the pragma does not apply to a legal construct
21346 -- or it does not appear at the top of a declarative or a
21347 -- statement list. Issue an error and stop the analysis.
21357 -- The pragma applies to a package or a subprogram that acts as
21358 -- a compilation unit.
21360 -- procedure Proc ...;
21361 -- pragma SPARK_Mode ...;
21363 if Nkind (Context) = N_Compilation_Unit_Aux then
21364 Context := Unit (Parent (Context));
21367 -- The pragma appears at the top of entry, package, protected
21368 -- unit, subprogram or task unit body declarations.
21370 -- entry Ent when ... is
21371 -- pragma SPARK_Mode ...;
21373 -- package body Pack is
21374 -- pragma SPARK_Mode ...;
21376 -- procedure Proc ... is
21377 -- pragma SPARK_Mode;
21379 -- protected body Prot is
21380 -- pragma SPARK_Mode ...;
21382 if Nkind_In (Context, N_Entry_Body,
21388 Process_Body (Context);
21390 -- The pragma appears at the top of the visible or private
21391 -- declaration of a package spec, protected or task unit.
21394 -- pragma SPARK_Mode ...;
21396 -- pragma SPARK_Mode ...;
21398 -- protected [type] Prot is
21399 -- pragma SPARK_Mode ...;
21401 -- pragma SPARK_Mode ...;
21403 elsif Nkind_In (Context, N_Package_Specification,
21404 N_Protected_Definition,
21407 if List_Containing (N) = Visible_Declarations (Context) then
21408 Process_Visible_Part (Parent (Context));
21410 Process_Private_Part (Parent (Context));
21413 -- The pragma appears at the top of package body statements
21415 -- package body Pack is
21417 -- pragma SPARK_Mode;
21419 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21420 and then Nkind (Parent (Context)) = N_Package_Body
21422 Process_Statement_Part (Parent (Context));
21424 -- The pragma appeared as an aspect of a [generic] subprogram
21425 -- declaration that acts as a compilation unit.
21428 -- procedure Proc ...;
21429 -- pragma SPARK_Mode ...;
21431 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21432 N_Subprogram_Declaration)
21434 Process_Overloadable (Context);
21436 -- The pragma does not apply to a legal construct, issue error
21444 --------------------------------
21445 -- Static_Elaboration_Desired --
21446 --------------------------------
21448 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21450 when Pragma_Static_Elaboration_Desired =>
21452 Check_At_Most_N_Arguments (1);
21454 if Is_Compilation_Unit (Current_Scope)
21455 and then Ekind (Current_Scope) = E_Package
21457 Set_Static_Elaboration_Desired (Current_Scope, True);
21459 Error_Pragma ("pragma% must apply to a library-level package");
21466 -- pragma Storage_Size (EXPRESSION);
21468 when Pragma_Storage_Size => Storage_Size : declare
21469 P : constant Node_Id := Parent (N);
21473 Check_No_Identifiers;
21474 Check_Arg_Count (1);
21476 -- The expression must be analyzed in the special manner described
21477 -- in "Handling of Default Expressions" in sem.ads.
21479 Arg := Get_Pragma_Arg (Arg1);
21480 Preanalyze_Spec_Expression (Arg, Any_Integer);
21482 if not Is_OK_Static_Expression (Arg) then
21483 Check_Restriction (Static_Storage_Size, Arg);
21486 if Nkind (P) /= N_Task_Definition then
21491 if Has_Storage_Size_Pragma (P) then
21492 Error_Pragma ("duplicate pragma% not allowed");
21494 Set_Has_Storage_Size_Pragma (P, True);
21497 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
21505 -- pragma Storage_Unit (NUMERIC_LITERAL);
21507 -- Only permitted argument is System'Storage_Unit value
21509 when Pragma_Storage_Unit =>
21510 Check_No_Identifiers;
21511 Check_Arg_Count (1);
21512 Check_Arg_Is_Integer_Literal (Arg1);
21514 if Intval (Get_Pragma_Arg (Arg1)) /=
21515 UI_From_Int (Ttypes.System_Storage_Unit)
21517 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
21519 ("the only allowed argument for pragma% is ^", Arg1);
21522 --------------------
21523 -- Stream_Convert --
21524 --------------------
21526 -- pragma Stream_Convert (
21527 -- [Entity =>] type_LOCAL_NAME,
21528 -- [Read =>] function_NAME,
21529 -- [Write =>] function NAME);
21531 when Pragma_Stream_Convert => Stream_Convert : declare
21533 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
21534 -- Check that the given argument is the name of a local function
21535 -- of one argument that is not overloaded earlier in the current
21536 -- local scope. A check is also made that the argument is a
21537 -- function with one parameter.
21539 --------------------------------------
21540 -- Check_OK_Stream_Convert_Function --
21541 --------------------------------------
21543 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
21547 Check_Arg_Is_Local_Name (Arg);
21548 Ent := Entity (Get_Pragma_Arg (Arg));
21550 if Has_Homonym (Ent) then
21552 ("argument for pragma% may not be overloaded", Arg);
21555 if Ekind (Ent) /= E_Function
21556 or else No (First_Formal (Ent))
21557 or else Present (Next_Formal (First_Formal (Ent)))
21560 ("argument for pragma% must be function of one argument",
21563 end Check_OK_Stream_Convert_Function;
21565 -- Start of processing for Stream_Convert
21569 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
21570 Check_Arg_Count (3);
21571 Check_Optional_Identifier (Arg1, Name_Entity);
21572 Check_Optional_Identifier (Arg2, Name_Read);
21573 Check_Optional_Identifier (Arg3, Name_Write);
21574 Check_Arg_Is_Local_Name (Arg1);
21575 Check_OK_Stream_Convert_Function (Arg2);
21576 Check_OK_Stream_Convert_Function (Arg3);
21579 Typ : constant Entity_Id :=
21580 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
21581 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
21582 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
21585 Check_First_Subtype (Arg1);
21587 -- Check for too early or too late. Note that we don't enforce
21588 -- the rule about primitive operations in this case, since, as
21589 -- is the case for explicit stream attributes themselves, these
21590 -- restrictions are not appropriate. Note that the chaining of
21591 -- the pragma by Rep_Item_Too_Late is actually the critical
21592 -- processing done for this pragma.
21594 if Rep_Item_Too_Early (Typ, N)
21596 Rep_Item_Too_Late (Typ, N, FOnly => True)
21601 -- Return if previous error
21603 if Etype (Typ) = Any_Type
21605 Etype (Read) = Any_Type
21607 Etype (Write) = Any_Type
21614 if Underlying_Type (Etype (Read)) /= Typ then
21616 ("incorrect return type for function&", Arg2);
21619 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
21621 ("incorrect parameter type for function&", Arg3);
21624 if Underlying_Type (Etype (First_Formal (Read))) /=
21625 Underlying_Type (Etype (Write))
21628 ("result type of & does not match Read parameter type",
21632 end Stream_Convert;
21638 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21640 -- This is processed by the parser since some of the style checks
21641 -- take place during source scanning and parsing. This means that
21642 -- we don't need to issue error messages here.
21644 when Pragma_Style_Checks => Style_Checks : declare
21645 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21651 Check_No_Identifiers;
21653 -- Two argument form
21655 if Arg_Count = 2 then
21656 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21663 E_Id := Get_Pragma_Arg (Arg2);
21666 if not Is_Entity_Name (E_Id) then
21668 ("second argument of pragma% must be entity name",
21672 E := Entity (E_Id);
21674 if not Ignore_Style_Checks_Pragmas then
21679 Set_Suppress_Style_Checks
21680 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
21681 exit when No (Homonym (E));
21688 -- One argument form
21691 Check_Arg_Count (1);
21693 if Nkind (A) = N_String_Literal then
21697 Slen : constant Natural := Natural (String_Length (S));
21698 Options : String (1 .. Slen);
21704 C := Get_String_Char (S, Pos (J));
21705 exit when not In_Character_Range (C);
21706 Options (J) := Get_Character (C);
21708 -- If at end of string, set options. As per discussion
21709 -- above, no need to check for errors, since we issued
21710 -- them in the parser.
21713 if not Ignore_Style_Checks_Pragmas then
21714 Set_Style_Check_Options (Options);
21724 elsif Nkind (A) = N_Identifier then
21725 if Chars (A) = Name_All_Checks then
21726 if not Ignore_Style_Checks_Pragmas then
21728 Set_GNAT_Style_Check_Options;
21730 Set_Default_Style_Check_Options;
21734 elsif Chars (A) = Name_On then
21735 if not Ignore_Style_Checks_Pragmas then
21736 Style_Check := True;
21739 elsif Chars (A) = Name_Off then
21740 if not Ignore_Style_Checks_Pragmas then
21741 Style_Check := False;
21752 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21754 when Pragma_Subtitle =>
21756 Check_Arg_Count (1);
21757 Check_Optional_Identifier (Arg1, Name_Subtitle);
21758 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21765 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21767 when Pragma_Suppress =>
21768 Process_Suppress_Unsuppress (Suppress_Case => True);
21774 -- pragma Suppress_All;
21776 -- The only check made here is that the pragma has no arguments.
21777 -- There are no placement rules, and the processing required (setting
21778 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21779 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21780 -- then creates and inserts a pragma Suppress (All_Checks).
21782 when Pragma_Suppress_All =>
21784 Check_Arg_Count (0);
21786 -------------------------
21787 -- Suppress_Debug_Info --
21788 -------------------------
21790 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21792 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21793 Nam_Id : Entity_Id;
21797 Check_Arg_Count (1);
21798 Check_Optional_Identifier (Arg1, Name_Entity);
21799 Check_Arg_Is_Local_Name (Arg1);
21801 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21803 -- A pragma that applies to a Ghost entity becomes Ghost for the
21804 -- purposes of legality checks and removal of ignored Ghost code.
21806 Mark_Pragma_As_Ghost (N, Nam_Id);
21807 Set_Debug_Info_Off (Nam_Id);
21808 end Suppress_Debug_Info;
21810 ----------------------------------
21811 -- Suppress_Exception_Locations --
21812 ----------------------------------
21814 -- pragma Suppress_Exception_Locations;
21816 when Pragma_Suppress_Exception_Locations =>
21818 Check_Arg_Count (0);
21819 Check_Valid_Configuration_Pragma;
21820 Exception_Locations_Suppressed := True;
21822 -----------------------------
21823 -- Suppress_Initialization --
21824 -----------------------------
21826 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21828 when Pragma_Suppress_Initialization => Suppress_Init : declare
21834 Check_Arg_Count (1);
21835 Check_Optional_Identifier (Arg1, Name_Entity);
21836 Check_Arg_Is_Local_Name (Arg1);
21838 E_Id := Get_Pragma_Arg (Arg1);
21840 if Etype (E_Id) = Any_Type then
21844 E := Entity (E_Id);
21846 -- A pragma that applies to a Ghost entity becomes Ghost for the
21847 -- purposes of legality checks and removal of ignored Ghost code.
21849 Mark_Pragma_As_Ghost (N, E);
21851 if not Is_Type (E) and then Ekind (E) /= E_Variable then
21853 ("pragma% requires variable, type or subtype", Arg1);
21856 if Rep_Item_Too_Early (E, N)
21858 Rep_Item_Too_Late (E, N, FOnly => True)
21863 -- For incomplete/private type, set flag on full view
21865 if Is_Incomplete_Or_Private_Type (E) then
21866 if No (Full_View (Base_Type (E))) then
21868 ("argument of pragma% cannot be an incomplete type", Arg1);
21870 Set_Suppress_Initialization (Full_View (Base_Type (E)));
21873 -- For first subtype, set flag on base type
21875 elsif Is_First_Subtype (E) then
21876 Set_Suppress_Initialization (Base_Type (E));
21878 -- For other than first subtype, set flag on subtype or variable
21881 Set_Suppress_Initialization (E);
21889 -- pragma System_Name (DIRECT_NAME);
21891 -- Syntax check: one argument, which must be the identifier GNAT or
21892 -- the identifier GCC, no other identifiers are acceptable.
21894 when Pragma_System_Name =>
21896 Check_No_Identifiers;
21897 Check_Arg_Count (1);
21898 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21900 -----------------------------
21901 -- Task_Dispatching_Policy --
21902 -----------------------------
21904 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21906 when Pragma_Task_Dispatching_Policy => declare
21910 Check_Ada_83_Warning;
21911 Check_Arg_Count (1);
21912 Check_No_Identifiers;
21913 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21914 Check_Valid_Configuration_Pragma;
21915 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21916 DP := Fold_Upper (Name_Buffer (1));
21918 if Task_Dispatching_Policy /= ' '
21919 and then Task_Dispatching_Policy /= DP
21921 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21923 ("task dispatching policy incompatible with policy#");
21925 -- Set new policy, but always preserve System_Location since we
21926 -- like the error message with the run time name.
21929 Task_Dispatching_Policy := DP;
21931 if Task_Dispatching_Policy_Sloc /= System_Location then
21932 Task_Dispatching_Policy_Sloc := Loc;
21941 -- pragma Task_Info (EXPRESSION);
21943 when Pragma_Task_Info => Task_Info : declare
21944 P : constant Node_Id := Parent (N);
21950 if Warn_On_Obsolescent_Feature then
21952 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21953 & "instead?j?", N);
21956 if Nkind (P) /= N_Task_Definition then
21957 Error_Pragma ("pragma% must appear in task definition");
21960 Check_No_Identifiers;
21961 Check_Arg_Count (1);
21963 Analyze_And_Resolve
21964 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21966 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21970 Ent := Defining_Identifier (Parent (P));
21972 -- Check duplicate pragma before we chain the pragma in the Rep
21973 -- Item chain of Ent.
21976 (Ent, Name_Task_Info, Check_Parents => False)
21978 Error_Pragma ("duplicate pragma% not allowed");
21981 Record_Rep_Item (Ent, N);
21988 -- pragma Task_Name (string_EXPRESSION);
21990 when Pragma_Task_Name => Task_Name : declare
21991 P : constant Node_Id := Parent (N);
21996 Check_No_Identifiers;
21997 Check_Arg_Count (1);
21999 Arg := Get_Pragma_Arg (Arg1);
22001 -- The expression is used in the call to Create_Task, and must be
22002 -- expanded there, not in the context of the current spec. It must
22003 -- however be analyzed to capture global references, in case it
22004 -- appears in a generic context.
22006 Preanalyze_And_Resolve (Arg, Standard_String);
22008 if Nkind (P) /= N_Task_Definition then
22012 Ent := Defining_Identifier (Parent (P));
22014 -- Check duplicate pragma before we chain the pragma in the Rep
22015 -- Item chain of Ent.
22018 (Ent, Name_Task_Name, Check_Parents => False)
22020 Error_Pragma ("duplicate pragma% not allowed");
22023 Record_Rep_Item (Ent, N);
22030 -- pragma Task_Storage (
22031 -- [Task_Type =>] LOCAL_NAME,
22032 -- [Top_Guard =>] static_integer_EXPRESSION);
22034 when Pragma_Task_Storage => Task_Storage : declare
22035 Args : Args_List (1 .. 2);
22036 Names : constant Name_List (1 .. 2) := (
22040 Task_Type : Node_Id renames Args (1);
22041 Top_Guard : Node_Id renames Args (2);
22047 Gather_Associations (Names, Args);
22049 if No (Task_Type) then
22051 ("missing task_type argument for pragma%");
22054 Check_Arg_Is_Local_Name (Task_Type);
22056 Ent := Entity (Task_Type);
22058 if not Is_Task_Type (Ent) then
22060 ("argument for pragma% must be task type", Task_Type);
22063 if No (Top_Guard) then
22065 ("pragma% takes two arguments", Task_Type);
22067 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
22070 Check_First_Subtype (Task_Type);
22072 if Rep_Item_Too_Late (Ent, N) then
22081 -- pragma Test_Case
22082 -- ([Name =>] Static_String_EXPRESSION
22083 -- ,[Mode =>] MODE_TYPE
22084 -- [, Requires => Boolean_EXPRESSION]
22085 -- [, Ensures => Boolean_EXPRESSION]);
22087 -- MODE_TYPE ::= Nominal | Robustness
22089 -- Characteristics:
22091 -- * Analysis - The annotation undergoes initial checks to verify
22092 -- the legal placement and context. Secondary checks preanalyze the
22095 -- Analyze_Test_Case_In_Decl_Part
22097 -- * Expansion - None.
22099 -- * Template - The annotation utilizes the generic template of the
22100 -- related subprogram when it is:
22102 -- aspect on subprogram declaration
22104 -- The annotation must prepare its own template when it is:
22106 -- pragma on subprogram declaration
22108 -- * Globals - Capture of global references must occur after full
22111 -- * Instance - The annotation is instantiated automatically when
22112 -- the related generic subprogram is instantiated except for the
22113 -- "pragma on subprogram declaration" case. In that scenario the
22114 -- annotation must instantiate itself.
22116 when Pragma_Test_Case => Test_Case : declare
22117 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
22118 -- Ensure that the contract of subprogram Subp_Id does not contain
22119 -- another Test_Case pragma with the same Name as the current one.
22121 -------------------------
22122 -- Check_Distinct_Name --
22123 -------------------------
22125 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
22126 Items : constant Node_Id := Contract (Subp_Id);
22127 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
22131 -- Inspect all Test_Case pragma of the related subprogram
22132 -- looking for one with a duplicate "Name" argument.
22134 if Present (Items) then
22135 Prag := Contract_Test_Cases (Items);
22136 while Present (Prag) loop
22137 if Pragma_Name (Prag) = Name_Test_Case
22139 and then String_Equal
22140 (Name, Get_Name_From_CTC_Pragma (Prag))
22142 Error_Msg_Sloc := Sloc (Prag);
22143 Error_Pragma ("name for pragma % is already used #");
22146 Prag := Next_Pragma (Prag);
22149 end Check_Distinct_Name;
22153 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
22156 Subp_Decl : Node_Id;
22157 Subp_Id : Entity_Id;
22159 -- Start of processing for Test_Case
22163 Check_At_Least_N_Arguments (2);
22164 Check_At_Most_N_Arguments (4);
22166 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
22170 Check_Optional_Identifier (Arg1, Name_Name);
22171 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22175 Check_Optional_Identifier (Arg2, Name_Mode);
22176 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
22178 -- Arguments "Requires" and "Ensures"
22180 if Present (Arg3) then
22181 if Present (Arg4) then
22182 Check_Identifier (Arg3, Name_Requires);
22183 Check_Identifier (Arg4, Name_Ensures);
22185 Check_Identifier_Is_One_Of
22186 (Arg3, Name_Requires, Name_Ensures);
22190 -- Pragma Test_Case must be associated with a subprogram declared
22191 -- in a library-level package. First determine whether the current
22192 -- compilation unit is a legal context.
22194 if Nkind_In (Pack_Decl, N_Package_Declaration,
22195 N_Generic_Package_Declaration)
22199 -- Otherwise the placement is illegal
22203 ("pragma % must be specified within a package declaration");
22207 Subp_Decl := Find_Related_Declaration_Or_Body (N);
22209 -- Find the enclosing context
22211 Context := Parent (Subp_Decl);
22213 if Present (Context) then
22214 Context := Parent (Context);
22217 -- Verify the placement of the pragma
22219 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
22221 ("pragma % cannot be applied to abstract subprogram");
22224 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
22225 Error_Pragma ("pragma % cannot be applied to entry");
22228 -- The context is a [generic] subprogram declared at the top level
22229 -- of the [generic] package unit.
22231 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
22232 N_Subprogram_Declaration)
22233 and then Present (Context)
22234 and then Nkind_In (Context, N_Generic_Package_Declaration,
22235 N_Package_Declaration)
22239 -- Otherwise the placement is illegal
22243 ("pragma % must be applied to a library-level subprogram "
22248 Subp_Id := Defining_Entity (Subp_Decl);
22250 -- Chain the pragma on the contract for further processing by
22251 -- Analyze_Test_Case_In_Decl_Part.
22253 Add_Contract_Item (N, Subp_Id);
22255 -- A pragma that applies to a Ghost entity becomes Ghost for the
22256 -- purposes of legality checks and removal of ignored Ghost code.
22258 Mark_Pragma_As_Ghost (N, Subp_Id);
22260 -- Preanalyze the original aspect argument "Name" for ASIS or for
22261 -- a generic subprogram to properly capture global references.
22263 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
22264 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
22266 if Present (Asp_Arg) then
22268 -- The argument appears with an identifier in association
22271 if Nkind (Asp_Arg) = N_Component_Association then
22272 Asp_Arg := Expression (Asp_Arg);
22275 Check_Expr_Is_OK_Static_Expression
22276 (Asp_Arg, Standard_String);
22280 -- Ensure that the all Test_Case pragmas of the related subprogram
22281 -- have distinct names.
22283 Check_Distinct_Name (Subp_Id);
22285 -- Fully analyze the pragma when it appears inside an entry
22286 -- or subprogram body because it cannot benefit from forward
22289 if Nkind_In (Subp_Decl, N_Entry_Body,
22291 N_Subprogram_Body_Stub)
22293 -- The legality checks of pragma Test_Case are affected by the
22294 -- SPARK mode in effect and the volatility of the context.
22295 -- Analyze all pragmas in a specific order.
22297 Analyze_If_Present (Pragma_SPARK_Mode);
22298 Analyze_If_Present (Pragma_Volatile_Function);
22299 Analyze_Test_Case_In_Decl_Part (N);
22303 --------------------------
22304 -- Thread_Local_Storage --
22305 --------------------------
22307 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22309 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
22315 Check_Arg_Count (1);
22316 Check_Optional_Identifier (Arg1, Name_Entity);
22317 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22319 Id := Get_Pragma_Arg (Arg1);
22322 if not Is_Entity_Name (Id)
22323 or else Ekind (Entity (Id)) /= E_Variable
22325 Error_Pragma_Arg ("local variable name required", Arg1);
22330 -- A pragma that applies to a Ghost entity becomes Ghost for the
22331 -- purposes of legality checks and removal of ignored Ghost code.
22333 Mark_Pragma_As_Ghost (N, E);
22335 if Rep_Item_Too_Early (E, N)
22337 Rep_Item_Too_Late (E, N)
22342 Set_Has_Pragma_Thread_Local_Storage (E);
22343 Set_Has_Gigi_Rep_Item (E);
22344 end Thread_Local_Storage;
22350 -- pragma Time_Slice (static_duration_EXPRESSION);
22352 when Pragma_Time_Slice => Time_Slice : declare
22358 Check_Arg_Count (1);
22359 Check_No_Identifiers;
22360 Check_In_Main_Program;
22361 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22363 if not Error_Posted (Arg1) then
22365 while Present (Nod) loop
22366 if Nkind (Nod) = N_Pragma
22367 and then Pragma_Name (Nod) = Name_Time_Slice
22369 Error_Msg_Name_1 := Pname;
22370 Error_Msg_N ("duplicate pragma% not permitted", Nod);
22377 -- Process only if in main unit
22379 if Get_Source_Unit (Loc) = Main_Unit then
22380 Opt.Time_Slice_Set := True;
22381 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22383 if Val <= Ureal_0 then
22384 Opt.Time_Slice_Value := 0;
22386 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22387 Opt.Time_Slice_Value := 1_000_000_000;
22390 Opt.Time_Slice_Value :=
22391 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22400 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22402 -- TITLING_OPTION ::=
22403 -- [Title =>] STRING_LITERAL
22404 -- | [Subtitle =>] STRING_LITERAL
22406 when Pragma_Title => Title : declare
22407 Args : Args_List (1 .. 2);
22408 Names : constant Name_List (1 .. 2) := (
22414 Gather_Associations (Names, Args);
22417 for J in 1 .. 2 loop
22418 if Present (Args (J)) then
22419 Check_Arg_Is_OK_Static_Expression
22420 (Args (J), Standard_String);
22425 ----------------------------
22426 -- Type_Invariant[_Class] --
22427 ----------------------------
22429 -- pragma Type_Invariant[_Class]
22430 -- ([Entity =>] type_LOCAL_NAME,
22431 -- [Check =>] EXPRESSION);
22433 when Pragma_Type_Invariant |
22434 Pragma_Type_Invariant_Class =>
22435 Type_Invariant : declare
22436 I_Pragma : Node_Id;
22439 Check_Arg_Count (2);
22441 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22442 -- setting Class_Present for the Type_Invariant_Class case.
22444 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22445 I_Pragma := New_Copy (N);
22446 Set_Pragma_Identifier
22447 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22448 Rewrite (N, I_Pragma);
22449 Set_Analyzed (N, False);
22451 end Type_Invariant;
22453 ---------------------
22454 -- Unchecked_Union --
22455 ---------------------
22457 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22459 when Pragma_Unchecked_Union => Unchecked_Union : declare
22460 Assoc : constant Node_Id := Arg1;
22461 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22471 Check_No_Identifiers;
22472 Check_Arg_Count (1);
22473 Check_Arg_Is_Local_Name (Arg1);
22475 Find_Type (Type_Id);
22477 Typ := Entity (Type_Id);
22479 -- A pragma that applies to a Ghost entity becomes Ghost for the
22480 -- purposes of legality checks and removal of ignored Ghost code.
22482 Mark_Pragma_As_Ghost (N, Typ);
22485 or else Rep_Item_Too_Early (Typ, N)
22489 Typ := Underlying_Type (Typ);
22492 if Rep_Item_Too_Late (Typ, N) then
22496 Check_First_Subtype (Arg1);
22498 -- Note remaining cases are references to a type in the current
22499 -- declarative part. If we find an error, we post the error on
22500 -- the relevant type declaration at an appropriate point.
22502 if not Is_Record_Type (Typ) then
22503 Error_Msg_N ("unchecked union must be record type", Typ);
22506 elsif Is_Tagged_Type (Typ) then
22507 Error_Msg_N ("unchecked union must not be tagged", Typ);
22510 elsif not Has_Discriminants (Typ) then
22512 ("unchecked union must have one discriminant", Typ);
22515 -- Note: in previous versions of GNAT we used to check for limited
22516 -- types and give an error, but in fact the standard does allow
22517 -- Unchecked_Union on limited types, so this check was removed.
22519 -- Similarly, GNAT used to require that all discriminants have
22520 -- default values, but this is not mandated by the RM.
22522 -- Proceed with basic error checks completed
22525 Tdef := Type_Definition (Declaration_Node (Typ));
22526 Clist := Component_List (Tdef);
22528 -- Check presence of component list and variant part
22530 if No (Clist) or else No (Variant_Part (Clist)) then
22532 ("unchecked union must have variant part", Tdef);
22536 -- Check components
22538 Comp := First (Component_Items (Clist));
22539 while Present (Comp) loop
22540 Check_Component (Comp, Typ);
22544 -- Check variant part
22546 Vpart := Variant_Part (Clist);
22548 Variant := First (Variants (Vpart));
22549 while Present (Variant) loop
22550 Check_Variant (Variant, Typ);
22555 Set_Is_Unchecked_Union (Typ);
22556 Set_Convention (Typ, Convention_C);
22557 Set_Has_Unchecked_Union (Base_Type (Typ));
22558 Set_Is_Unchecked_Union (Base_Type (Typ));
22559 end Unchecked_Union;
22561 ----------------------------
22562 -- Unevaluated_Use_Of_Old --
22563 ----------------------------
22565 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22567 when Pragma_Unevaluated_Use_Of_Old =>
22569 Check_Arg_Count (1);
22570 Check_No_Identifiers;
22571 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22573 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22574 -- a declarative part or a package spec.
22576 if not Is_Configuration_Pragma then
22577 Check_Is_In_Decl_Part_Or_Package_Spec;
22580 -- Store proper setting of Uneval_Old
22582 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22583 Uneval_Old := Fold_Upper (Name_Buffer (1));
22585 ------------------------
22586 -- Unimplemented_Unit --
22587 ------------------------
22589 -- pragma Unimplemented_Unit;
22591 -- Note: this only gives an error if we are generating code, or if
22592 -- we are in a generic library unit (where the pragma appears in the
22593 -- body, not in the spec).
22595 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
22596 Cunitent : constant Entity_Id :=
22597 Cunit_Entity (Get_Source_Unit (Loc));
22598 Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
22602 Check_Arg_Count (0);
22604 if Operating_Mode = Generate_Code
22605 or else Ent_Kind = E_Generic_Function
22606 or else Ent_Kind = E_Generic_Procedure
22607 or else Ent_Kind = E_Generic_Package
22609 Get_Name_String (Chars (Cunitent));
22610 Set_Casing (Mixed_Case);
22611 Write_Str (Name_Buffer (1 .. Name_Len));
22612 Write_Str (" is not supported in this configuration");
22614 raise Unrecoverable_Error;
22616 end Unimplemented_Unit;
22618 ------------------------
22619 -- Universal_Aliasing --
22620 ------------------------
22622 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22624 when Pragma_Universal_Aliasing => Universal_Alias : declare
22629 Check_Arg_Count (1);
22630 Check_Optional_Identifier (Arg2, Name_Entity);
22631 Check_Arg_Is_Local_Name (Arg1);
22632 E_Id := Entity (Get_Pragma_Arg (Arg1));
22634 if E_Id = Any_Type then
22636 elsif No (E_Id) or else not Is_Type (E_Id) then
22637 Error_Pragma_Arg ("pragma% requires type", Arg1);
22640 -- A pragma that applies to a Ghost entity becomes Ghost for the
22641 -- purposes of legality checks and removal of ignored Ghost code.
22643 Mark_Pragma_As_Ghost (N, E_Id);
22644 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
22645 Record_Rep_Item (E_Id, N);
22646 end Universal_Alias;
22648 --------------------
22649 -- Universal_Data --
22650 --------------------
22652 -- pragma Universal_Data [(library_unit_NAME)];
22654 when Pragma_Universal_Data =>
22656 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
22662 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22664 when Pragma_Unmodified =>
22665 Analyze_Unmodified_Or_Unused;
22671 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22673 -- or when used in a context clause:
22675 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22677 when Pragma_Unreferenced =>
22678 Analyze_Unreferenced_Or_Unused;
22680 --------------------------
22681 -- Unreferenced_Objects --
22682 --------------------------
22684 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22686 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22688 Arg_Expr : Node_Id;
22689 Arg_Id : Entity_Id;
22691 Ghost_Error_Posted : Boolean := False;
22692 -- Flag set when an error concerning the illegal mix of Ghost and
22693 -- non-Ghost types is emitted.
22695 Ghost_Id : Entity_Id := Empty;
22696 -- The entity of the first Ghost type encountered while processing
22697 -- the arguments of the pragma.
22701 Check_At_Least_N_Arguments (1);
22704 while Present (Arg) loop
22705 Check_No_Identifier (Arg);
22706 Check_Arg_Is_Local_Name (Arg);
22707 Arg_Expr := Get_Pragma_Arg (Arg);
22709 if Is_Entity_Name (Arg_Expr) then
22710 Arg_Id := Entity (Arg_Expr);
22712 if Is_Type (Arg_Id) then
22713 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22715 -- A pragma that applies to a Ghost entity becomes Ghost
22716 -- for the purposes of legality checks and removal of
22717 -- ignored Ghost code.
22719 Mark_Pragma_As_Ghost (N, Arg_Id);
22721 -- Capture the entity of the first Ghost type being
22722 -- processed for error detection purposes.
22724 if Is_Ghost_Entity (Arg_Id) then
22725 if No (Ghost_Id) then
22726 Ghost_Id := Arg_Id;
22729 -- Otherwise the type is non-Ghost. It is illegal to mix
22730 -- references to Ghost and non-Ghost entities
22733 elsif Present (Ghost_Id)
22734 and then not Ghost_Error_Posted
22736 Ghost_Error_Posted := True;
22738 Error_Msg_Name_1 := Pname;
22740 ("pragma % cannot mention ghost and non-ghost types",
22743 Error_Msg_Sloc := Sloc (Ghost_Id);
22744 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22746 Error_Msg_Sloc := Sloc (Arg_Id);
22747 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22751 ("argument for pragma% must be type or subtype", Arg);
22755 ("argument for pragma% must be type or subtype", Arg);
22760 end Unreferenced_Objects;
22762 ------------------------------
22763 -- Unreserve_All_Interrupts --
22764 ------------------------------
22766 -- pragma Unreserve_All_Interrupts;
22768 when Pragma_Unreserve_All_Interrupts =>
22770 Check_Arg_Count (0);
22772 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22773 Unreserve_All_Interrupts := True;
22780 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22782 when Pragma_Unsuppress =>
22784 Process_Suppress_Unsuppress (Suppress_Case => False);
22790 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
22792 when Pragma_Unused =>
22793 Analyze_Unmodified_Or_Unused (Is_Unused => True);
22794 Analyze_Unreferenced_Or_Unused (Is_Unused => True);
22796 -------------------
22797 -- Use_VADS_Size --
22798 -------------------
22800 -- pragma Use_VADS_Size;
22802 when Pragma_Use_VADS_Size =>
22804 Check_Arg_Count (0);
22805 Check_Valid_Configuration_Pragma;
22806 Use_VADS_Size := True;
22808 ---------------------
22809 -- Validity_Checks --
22810 ---------------------
22812 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22814 when Pragma_Validity_Checks => Validity_Checks : declare
22815 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22821 Check_Arg_Count (1);
22822 Check_No_Identifiers;
22824 -- Pragma always active unless in CodePeer or GNATprove modes,
22825 -- which use a fixed configuration of validity checks.
22827 if not (CodePeer_Mode or GNATprove_Mode) then
22828 if Nkind (A) = N_String_Literal then
22832 Slen : constant Natural := Natural (String_Length (S));
22833 Options : String (1 .. Slen);
22837 -- Couldn't we use a for loop here over Options'Range???
22841 C := Get_String_Char (S, Pos (J));
22843 -- This is a weird test, it skips setting validity
22844 -- checks entirely if any element of S is out of
22845 -- range of Character, what is that about ???
22847 exit when not In_Character_Range (C);
22848 Options (J) := Get_Character (C);
22851 Set_Validity_Check_Options (Options);
22859 elsif Nkind (A) = N_Identifier then
22860 if Chars (A) = Name_All_Checks then
22861 Set_Validity_Check_Options ("a");
22862 elsif Chars (A) = Name_On then
22863 Validity_Checks_On := True;
22864 elsif Chars (A) = Name_Off then
22865 Validity_Checks_On := False;
22869 end Validity_Checks;
22875 -- pragma Volatile (LOCAL_NAME);
22877 when Pragma_Volatile =>
22878 Process_Atomic_Independent_Shared_Volatile;
22880 -------------------------
22881 -- Volatile_Components --
22882 -------------------------
22884 -- pragma Volatile_Components (array_LOCAL_NAME);
22886 -- Volatile is handled by the same circuit as Atomic_Components
22888 --------------------------
22889 -- Volatile_Full_Access --
22890 --------------------------
22892 -- pragma Volatile_Full_Access (LOCAL_NAME);
22894 when Pragma_Volatile_Full_Access =>
22896 Process_Atomic_Independent_Shared_Volatile;
22898 -----------------------
22899 -- Volatile_Function --
22900 -----------------------
22902 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22904 when Pragma_Volatile_Function => Volatile_Function : declare
22905 Over_Id : Entity_Id;
22906 Spec_Id : Entity_Id;
22907 Subp_Decl : Node_Id;
22911 Check_No_Identifiers;
22912 Check_At_Most_N_Arguments (1);
22915 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22917 -- Generic subprogram
22919 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22922 -- Body acts as spec
22924 elsif Nkind (Subp_Decl) = N_Subprogram_Body
22925 and then No (Corresponding_Spec (Subp_Decl))
22929 -- Body stub acts as spec
22931 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22932 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22938 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22946 Spec_Id := Unique_Defining_Entity (Subp_Decl);
22948 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22953 -- Chain the pragma on the contract for completeness
22955 Add_Contract_Item (N, Spec_Id);
22957 -- The legality checks of pragma Volatile_Function are affected by
22958 -- the SPARK mode in effect. Analyze all pragmas in a specific
22961 Analyze_If_Present (Pragma_SPARK_Mode);
22963 -- A pragma that applies to a Ghost entity becomes Ghost for the
22964 -- purposes of legality checks and removal of ignored Ghost code.
22966 Mark_Pragma_As_Ghost (N, Spec_Id);
22968 -- A volatile function cannot override a non-volatile function
22969 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22970 -- in New_Overloaded_Entity, however at that point the pragma has
22971 -- not been processed yet.
22973 Over_Id := Overridden_Operation (Spec_Id);
22975 if Present (Over_Id)
22976 and then not Is_Volatile_Function (Over_Id)
22979 ("incompatible volatile function values in effect", Spec_Id);
22981 Error_Msg_Sloc := Sloc (Over_Id);
22983 ("\& declared # with Volatile_Function value False",
22986 Error_Msg_Sloc := Sloc (Spec_Id);
22988 ("\overridden # with Volatile_Function value True",
22992 -- Analyze the Boolean expression (if any)
22994 if Present (Arg1) then
22995 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22997 end Volatile_Function;
22999 ----------------------
23000 -- Warning_As_Error --
23001 ----------------------
23003 -- pragma Warning_As_Error (static_string_EXPRESSION);
23005 when Pragma_Warning_As_Error =>
23007 Check_Arg_Count (1);
23008 Check_No_Identifiers;
23009 Check_Valid_Configuration_Pragma;
23011 if not Is_Static_String_Expression (Arg1) then
23013 ("argument of pragma% must be static string expression",
23016 -- OK static string expression
23019 Acquire_Warning_Match_String (Arg1);
23020 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
23021 Warnings_As_Errors (Warnings_As_Errors_Count) :=
23022 new String'(Name_Buffer (1 .. Name_Len));
23029 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23031 -- DETAILS ::= On | Off
23032 -- DETAILS ::= On | Off, local_NAME
23033 -- DETAILS ::= static_string_EXPRESSION
23034 -- DETAILS ::= On | Off, static_string_EXPRESSION
23036 -- TOOL_NAME ::= GNAT | GNATProve
23038 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23040 -- Note: If the first argument matches an allowed tool name, it is
23041 -- always considered to be a tool name, even if there is a string
23042 -- variable of that name.
23044 -- Note if the second argument of DETAILS is a local_NAME then the
23045 -- second form is always understood. If the intention is to use
23046 -- the fourth form, then you can write NAME & "" to force the
23047 -- intepretation as a static_string_EXPRESSION.
23049 when Pragma_Warnings => Warnings : declare
23050 Reason : String_Id;
23054 Check_At_Least_N_Arguments (1);
23056 -- See if last argument is labeled Reason. If so, make sure we
23057 -- have a string literal or a concatenation of string literals,
23058 -- and acquire the REASON string. Then remove the REASON argument
23059 -- by decreasing Num_Args by one; Remaining processing looks only
23060 -- at first Num_Args arguments).
23063 Last_Arg : constant Node_Id :=
23064 Last (Pragma_Argument_Associations (N));
23067 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23068 and then Chars (Last_Arg) = Name_Reason
23071 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23072 Reason := End_String;
23073 Arg_Count := Arg_Count - 1;
23075 -- Not allowed in compiler units (bootstrap issues)
23077 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23079 -- No REASON string, set null string as reason
23082 Reason := Null_String_Id;
23086 -- Now proceed with REASON taken care of and eliminated
23088 Check_No_Identifiers;
23090 -- If debug flag -gnatd.i is set, pragma is ignored
23092 if Debug_Flag_Dot_I then
23096 -- Process various forms of the pragma
23099 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23100 Shifted_Args : List_Id;
23103 -- See if first argument is a tool name, currently either
23104 -- GNAT or GNATprove. If so, either ignore the pragma if the
23105 -- tool used does not match, or continue as if no tool name
23106 -- was given otherwise, by shifting the arguments.
23108 if Nkind (Argx) = N_Identifier
23109 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23111 if Chars (Argx) = Name_Gnat then
23112 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23113 Rewrite (N, Make_Null_Statement (Loc));
23118 elsif Chars (Argx) = Name_Gnatprove then
23119 if not GNATprove_Mode then
23120 Rewrite (N, Make_Null_Statement (Loc));
23126 raise Program_Error;
23129 -- At this point, the pragma Warnings applies to the tool,
23130 -- so continue with shifted arguments.
23132 Arg_Count := Arg_Count - 1;
23134 if Arg_Count = 1 then
23135 Shifted_Args := New_List (New_Copy (Arg2));
23136 elsif Arg_Count = 2 then
23137 Shifted_Args := New_List (New_Copy (Arg2),
23139 elsif Arg_Count = 3 then
23140 Shifted_Args := New_List (New_Copy (Arg2),
23144 raise Program_Error;
23149 Chars => Name_Warnings,
23150 Pragma_Argument_Associations => Shifted_Args));
23155 -- One argument case
23157 if Arg_Count = 1 then
23159 -- On/Off one argument case was processed by parser
23161 if Nkind (Argx) = N_Identifier
23162 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23166 -- One argument case must be ON/OFF or static string expr
23168 elsif not Is_Static_String_Expression (Arg1) then
23170 ("argument of pragma% must be On/Off or static string "
23171 & "expression", Arg1);
23173 -- One argument string expression case
23177 Lit : constant Node_Id := Expr_Value_S (Argx);
23178 Str : constant String_Id := Strval (Lit);
23179 Len : constant Nat := String_Length (Str);
23187 while J <= Len loop
23188 C := Get_String_Char (Str, J);
23189 OK := In_Character_Range (C);
23192 Chr := Get_Character (C);
23194 -- Dash case: only -Wxxx is accepted
23201 C := Get_String_Char (Str, J);
23202 Chr := Get_Character (C);
23203 exit when Chr = 'W';
23208 elsif J < Len and then Chr = '.' then
23210 C := Get_String_Char (Str, J);
23211 Chr := Get_Character (C);
23213 if not Set_Dot_Warning_Switch (Chr) then
23215 ("invalid warning switch character "
23216 & '.' & Chr, Arg1);
23222 OK := Set_Warning_Switch (Chr);
23228 ("invalid warning switch character " & Chr,
23237 -- Two or more arguments (must be two)
23240 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23241 Check_Arg_Count (2);
23249 E_Id := Get_Pragma_Arg (Arg2);
23252 -- In the expansion of an inlined body, a reference to
23253 -- the formal may be wrapped in a conversion if the
23254 -- actual is a conversion. Retrieve the real entity name.
23256 if (In_Instance_Body or In_Inlined_Body)
23257 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23259 E_Id := Expression (E_Id);
23262 -- Entity name case
23264 if Is_Entity_Name (E_Id) then
23265 E := Entity (E_Id);
23272 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23275 -- For OFF case, make entry in warnings off
23276 -- pragma table for later processing. But we do
23277 -- not do that within an instance, since these
23278 -- warnings are about what is needed in the
23279 -- template, not an instance of it.
23281 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23282 and then Warn_On_Warnings_Off
23283 and then not In_Instance
23285 Warnings_Off_Pragmas.Append ((N, E, Reason));
23288 if Is_Enumeration_Type (E) then
23292 Lit := First_Literal (E);
23293 while Present (Lit) loop
23294 Set_Warnings_Off (Lit);
23295 Next_Literal (Lit);
23300 exit when No (Homonym (E));
23305 -- Error if not entity or static string expression case
23307 elsif not Is_Static_String_Expression (Arg2) then
23309 ("second argument of pragma% must be entity name "
23310 & "or static string expression", Arg2);
23312 -- Static string expression case
23315 Acquire_Warning_Match_String (Arg2);
23317 -- Note on configuration pragma case: If this is a
23318 -- configuration pragma, then for an OFF pragma, we
23319 -- just set Config True in the call, which is all
23320 -- that needs to be done. For the case of ON, this
23321 -- is normally an error, unless it is canceling the
23322 -- effect of a previous OFF pragma in the same file.
23323 -- In any other case, an error will be signalled (ON
23324 -- with no matching OFF).
23326 -- Note: We set Used if we are inside a generic to
23327 -- disable the test that the non-config case actually
23328 -- cancels a warning. That's because we can't be sure
23329 -- there isn't an instantiation in some other unit
23330 -- where a warning is suppressed.
23332 -- We could do a little better here by checking if the
23333 -- generic unit we are inside is public, but for now
23334 -- we don't bother with that refinement.
23336 if Chars (Argx) = Name_Off then
23337 Set_Specific_Warning_Off
23338 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23339 Config => Is_Configuration_Pragma,
23340 Used => Inside_A_Generic or else In_Instance);
23342 elsif Chars (Argx) = Name_On then
23343 Set_Specific_Warning_On
23344 (Loc, Name_Buffer (1 .. Name_Len), Err);
23348 ("??pragma Warnings On with no matching "
23349 & "Warnings Off", Loc);
23358 -------------------
23359 -- Weak_External --
23360 -------------------
23362 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23364 when Pragma_Weak_External => Weak_External : declare
23369 Check_Arg_Count (1);
23370 Check_Optional_Identifier (Arg1, Name_Entity);
23371 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23372 Ent := Entity (Get_Pragma_Arg (Arg1));
23374 if Rep_Item_Too_Early (Ent, N) then
23377 Ent := Underlying_Type (Ent);
23380 -- The only processing required is to link this item on to the
23381 -- list of rep items for the given entity. This is accomplished
23382 -- by the call to Rep_Item_Too_Late (when no error is detected
23383 -- and False is returned).
23385 if Rep_Item_Too_Late (Ent, N) then
23388 Set_Has_Gigi_Rep_Item (Ent);
23392 -----------------------------
23393 -- Wide_Character_Encoding --
23394 -----------------------------
23396 -- pragma Wide_Character_Encoding (IDENTIFIER);
23398 when Pragma_Wide_Character_Encoding =>
23401 -- Nothing to do, handled in parser. Note that we do not enforce
23402 -- configuration pragma placement, this pragma can appear at any
23403 -- place in the source, allowing mixed encodings within a single
23408 --------------------
23409 -- Unknown_Pragma --
23410 --------------------
23412 -- Should be impossible, since the case of an unknown pragma is
23413 -- separately processed before the case statement is entered.
23415 when Unknown_Pragma =>
23416 raise Program_Error;
23419 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23420 -- until AI is formally approved.
23422 -- Check_Order_Dependence;
23425 when Pragma_Exit => null;
23426 end Analyze_Pragma;
23428 ---------------------------------------------
23429 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23430 ---------------------------------------------
23432 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23434 Freeze_Id : Entity_Id := Empty)
23436 Disp_Typ : Entity_Id;
23437 -- The dispatching type of the subprogram subject to the pre- or
23440 function Check_References (Nod : Node_Id) return Traverse_Result;
23441 -- Check that expression Nod does not mention non-primitives of the
23442 -- type, global objects of the type, or other illegalities described
23443 -- and implied by AI12-0113.
23445 ----------------------
23446 -- Check_References --
23447 ----------------------
23449 function Check_References (Nod : Node_Id) return Traverse_Result is
23451 if Nkind (Nod) = N_Function_Call
23452 and then Is_Entity_Name (Name (Nod))
23455 Func : constant Entity_Id := Entity (Name (Nod));
23459 -- An operation of the type must be a primitive
23461 if No (Find_Dispatching_Type (Func)) then
23462 Form := First_Formal (Func);
23463 while Present (Form) loop
23464 if Etype (Form) = Disp_Typ then
23466 ("operation in class-wide condition must be "
23467 & "primitive of &", Nod, Disp_Typ);
23470 Next_Formal (Form);
23473 -- A return object of the type is illegal as well
23475 if Etype (Func) = Disp_Typ
23476 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23479 ("operation in class-wide condition must be primitive "
23480 & "of &", Nod, Disp_Typ);
23485 elsif Is_Entity_Name (Nod)
23487 (Etype (Nod) = Disp_Typ
23488 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23489 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23492 ("object in class-wide condition must be formal of type &",
23495 elsif Nkind (Nod) = N_Explicit_Dereference
23496 and then (Etype (Nod) = Disp_Typ
23497 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23498 and then (not Is_Entity_Name (Prefix (Nod))
23499 or else not Is_Formal (Entity (Prefix (Nod))))
23502 ("operation in class-wide condition must be primitive of &",
23507 end Check_References;
23509 procedure Check_Class_Wide_Condition is
23510 new Traverse_Proc (Check_References);
23514 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23515 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23516 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23518 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23521 Restore_Scope : Boolean := False;
23523 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23526 -- Do not analyze the pragma multiple times
23528 if Is_Analyzed_Pragma (N) then
23532 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23533 -- analysis of the pragma, the Ghost mode at point of declaration and
23534 -- point of analysis may not necessarily be the same. Use the mode in
23535 -- effect at the point of declaration.
23537 Set_Ghost_Mode (N);
23539 -- Ensure that the subprogram and its formals are visible when analyzing
23540 -- the expression of the pragma.
23542 if not In_Open_Scopes (Spec_Id) then
23543 Restore_Scope := True;
23544 Push_Scope (Spec_Id);
23546 if Is_Generic_Subprogram (Spec_Id) then
23547 Install_Generic_Formals (Spec_Id);
23549 Install_Formals (Spec_Id);
23553 Errors := Serious_Errors_Detected;
23554 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23556 -- Emit a clarification message when the expression contains at least
23557 -- one undefined reference, possibly due to contract "freezing".
23559 if Errors /= Serious_Errors_Detected
23560 and then Present (Freeze_Id)
23561 and then Has_Undefined_Reference (Expr)
23563 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23566 if Class_Present (N) then
23568 -- Verify that a class-wide condition is legal, i.e. the operation is
23569 -- a primitive of a tagged type. Note that a generic subprogram is
23570 -- not a primitive operation.
23572 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23574 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23575 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23577 if From_Aspect_Specification (N) then
23579 ("aspect % can only be specified for a primitive operation "
23580 & "of a tagged type", Corresponding_Aspect (N));
23582 -- The pragma is a source construct
23586 ("pragma % can only be specified for a primitive operation "
23587 & "of a tagged type", N);
23590 -- Remaining semantic checks require a full tree traversal
23593 Check_Class_Wide_Condition (Expr);
23598 if Restore_Scope then
23602 -- Currently it is not possible to inline pre/postconditions on a
23603 -- subprogram subject to pragma Inline_Always.
23605 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23606 Ghost_Mode := Save_Ghost_Mode;
23608 Set_Is_Analyzed_Pragma (N);
23609 end Analyze_Pre_Post_Condition_In_Decl_Part;
23611 ------------------------------------------
23612 -- Analyze_Refined_Depends_In_Decl_Part --
23613 ------------------------------------------
23615 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23616 Body_Inputs : Elist_Id := No_Elist;
23617 Body_Outputs : Elist_Id := No_Elist;
23618 -- The inputs and outputs of the subprogram body synthesized from pragma
23619 -- Refined_Depends.
23621 Dependencies : List_Id := No_List;
23623 -- The corresponding Depends pragma along with its clauses
23625 Matched_Items : Elist_Id := No_Elist;
23626 -- A list containing the entities of all successfully matched items
23627 -- found in pragma Depends.
23629 Refinements : List_Id := No_List;
23630 -- The clauses of pragma Refined_Depends
23632 Spec_Id : Entity_Id;
23633 -- The entity of the subprogram subject to pragma Refined_Depends
23635 Spec_Inputs : Elist_Id := No_Elist;
23636 Spec_Outputs : Elist_Id := No_Elist;
23637 -- The inputs and outputs of the subprogram spec synthesized from pragma
23640 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23641 -- Try to match a single dependency clause Dep_Clause against one or
23642 -- more refinement clauses found in list Refinements. Each successful
23643 -- match eliminates at least one refinement clause from Refinements.
23645 procedure Check_Output_States;
23646 -- Determine whether pragma Depends contains an output state with a
23647 -- visible refinement and if so, ensure that pragma Refined_Depends
23648 -- mentions all its constituents as outputs.
23650 procedure Normalize_Clauses (Clauses : List_Id);
23651 -- Given a list of dependence or refinement clauses Clauses, normalize
23652 -- each clause by creating multiple dependencies with exactly one input
23655 procedure Report_Extra_Clauses;
23656 -- Emit an error for each extra clause found in list Refinements
23658 -----------------------------
23659 -- Check_Dependency_Clause --
23660 -----------------------------
23662 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23663 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23664 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23666 function Is_In_Out_State_Clause return Boolean;
23667 -- Determine whether dependence clause Dep_Clause denotes an abstract
23668 -- state that depends on itself (State => State).
23670 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23671 -- Determine whether item Item denotes an abstract state with visible
23672 -- null refinement.
23674 procedure Match_Items
23675 (Dep_Item : Node_Id;
23676 Ref_Item : Node_Id;
23677 Matched : out Boolean);
23678 -- Try to match dependence item Dep_Item against refinement item
23679 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23680 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23681 -- the following conformance scenarios is in effect:
23682 -- 1) Both items denote null
23683 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23684 -- 3) Both items denote attribute 'Result
23685 -- 4) Both items denote the same object
23686 -- 5) Both items denote the same formal parameter
23687 -- 6) Both items denote the same current instance of a type
23688 -- 7) Both items denote the same discriminant
23689 -- 8) Dep_Item is an abstract state with visible null refinement
23690 -- and Ref_Item denotes null.
23691 -- 9) Dep_Item is an abstract state with visible null refinement
23692 -- and Ref_Item is Empty (special case).
23693 -- 10) Dep_Item is an abstract state with visible non-null
23694 -- refinement and Ref_Item denotes one of its constituents.
23695 -- 11) Dep_Item is an abstract state without a visible refinement
23696 -- and Ref_Item denotes the same state.
23697 -- When scenario 10 is in effect, the entity of the abstract state
23698 -- denoted by Dep_Item is added to list Refined_States.
23700 procedure Record_Item (Item_Id : Entity_Id);
23701 -- Store the entity of an item denoted by Item_Id in Matched_Items
23703 ----------------------------
23704 -- Is_In_Out_State_Clause --
23705 ----------------------------
23707 function Is_In_Out_State_Clause return Boolean is
23708 Dep_Input_Id : Entity_Id;
23709 Dep_Output_Id : Entity_Id;
23712 -- Detect the following clause:
23715 if Is_Entity_Name (Dep_Input)
23716 and then Is_Entity_Name (Dep_Output)
23718 -- Handle abstract views generated for limited with clauses
23720 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
23721 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23724 Ekind (Dep_Input_Id) = E_Abstract_State
23725 and then Dep_Input_Id = Dep_Output_Id;
23729 end Is_In_Out_State_Clause;
23731 ---------------------------
23732 -- Is_Null_Refined_State --
23733 ---------------------------
23735 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23736 Item_Id : Entity_Id;
23739 if Is_Entity_Name (Item) then
23741 -- Handle abstract views generated for limited with clauses
23743 Item_Id := Available_View (Entity_Of (Item));
23746 Ekind (Item_Id) = E_Abstract_State
23747 and then Has_Null_Visible_Refinement (Item_Id);
23751 end Is_Null_Refined_State;
23757 procedure Match_Items
23758 (Dep_Item : Node_Id;
23759 Ref_Item : Node_Id;
23760 Matched : out Boolean)
23762 Dep_Item_Id : Entity_Id;
23763 Ref_Item_Id : Entity_Id;
23766 -- Assume that the two items do not match
23770 -- A null matches null or Empty (special case)
23772 if Nkind (Dep_Item) = N_Null
23773 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23777 -- Attribute 'Result matches attribute 'Result
23779 elsif Is_Attribute_Result (Dep_Item)
23780 and then Is_Attribute_Result (Dep_Item)
23784 -- Abstract states, current instances of concurrent types,
23785 -- discriminants, formal parameters and objects.
23787 elsif Is_Entity_Name (Dep_Item) then
23789 -- Handle abstract views generated for limited with clauses
23791 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23793 if Ekind (Dep_Item_Id) = E_Abstract_State then
23795 -- An abstract state with visible null refinement matches
23796 -- null or Empty (special case).
23798 if Has_Null_Visible_Refinement (Dep_Item_Id)
23799 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23801 Record_Item (Dep_Item_Id);
23804 -- An abstract state with visible non-null refinement
23805 -- matches one of its constituents.
23807 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
23808 if Is_Entity_Name (Ref_Item) then
23809 Ref_Item_Id := Entity_Of (Ref_Item);
23811 if Ekind_In (Ref_Item_Id, E_Abstract_State,
23814 and then Present (Encapsulating_State (Ref_Item_Id))
23815 and then Encapsulating_State (Ref_Item_Id) =
23818 Record_Item (Dep_Item_Id);
23823 -- An abstract state without a visible refinement matches
23826 elsif Is_Entity_Name (Ref_Item)
23827 and then Entity_Of (Ref_Item) = Dep_Item_Id
23829 Record_Item (Dep_Item_Id);
23833 -- A current instance of a concurrent type, discriminant,
23834 -- formal parameter or an object matches itself.
23836 elsif Is_Entity_Name (Ref_Item)
23837 and then Entity_Of (Ref_Item) = Dep_Item_Id
23839 Record_Item (Dep_Item_Id);
23849 procedure Record_Item (Item_Id : Entity_Id) is
23851 if not Contains (Matched_Items, Item_Id) then
23852 Append_New_Elmt (Item_Id, Matched_Items);
23858 Clause_Matched : Boolean := False;
23859 Dummy : Boolean := False;
23860 Inputs_Match : Boolean;
23861 Next_Ref_Clause : Node_Id;
23862 Outputs_Match : Boolean;
23863 Ref_Clause : Node_Id;
23864 Ref_Input : Node_Id;
23865 Ref_Output : Node_Id;
23867 -- Start of processing for Check_Dependency_Clause
23870 -- Do not perform this check in an instance because it was already
23871 -- performed successfully in the generic template.
23873 if Is_Generic_Instance (Spec_Id) then
23877 -- Examine all refinement clauses and compare them against the
23878 -- dependence clause.
23880 Ref_Clause := First (Refinements);
23881 while Present (Ref_Clause) loop
23882 Next_Ref_Clause := Next (Ref_Clause);
23884 -- Obtain the attributes of the current refinement clause
23886 Ref_Input := Expression (Ref_Clause);
23887 Ref_Output := First (Choices (Ref_Clause));
23889 -- The current refinement clause matches the dependence clause
23890 -- when both outputs match and both inputs match. See routine
23891 -- Match_Items for all possible conformance scenarios.
23893 -- Depends Dep_Output => Dep_Input
23897 -- Refined_Depends Ref_Output => Ref_Input
23900 (Dep_Item => Dep_Input,
23901 Ref_Item => Ref_Input,
23902 Matched => Inputs_Match);
23905 (Dep_Item => Dep_Output,
23906 Ref_Item => Ref_Output,
23907 Matched => Outputs_Match);
23909 -- An In_Out state clause may be matched against a refinement with
23910 -- a null input or null output as long as the non-null side of the
23911 -- relation contains a valid constituent of the In_Out_State.
23913 if Is_In_Out_State_Clause then
23915 -- Depends => (State => State)
23916 -- Refined_Depends => (null => Constit) -- OK
23919 and then not Outputs_Match
23920 and then Nkind (Ref_Output) = N_Null
23922 Outputs_Match := True;
23925 -- Depends => (State => State)
23926 -- Refined_Depends => (Constit => null) -- OK
23928 if not Inputs_Match
23929 and then Outputs_Match
23930 and then Nkind (Ref_Input) = N_Null
23932 Inputs_Match := True;
23936 -- The current refinement clause is legally constructed following
23937 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23938 -- the pool of candidates. The seach continues because a single
23939 -- dependence clause may have multiple matching refinements.
23941 if Inputs_Match and Outputs_Match then
23942 Clause_Matched := True;
23943 Remove (Ref_Clause);
23946 Ref_Clause := Next_Ref_Clause;
23949 -- Depending on the order or composition of refinement clauses, an
23950 -- In_Out state clause may not be directly refinable.
23952 -- Depends => ((Output, State) => (Input, State))
23953 -- Refined_State => (State => (Constit_1, Constit_2))
23954 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23956 -- Matching normalized clause (State => State) fails because there is
23957 -- no direct refinement capable of satisfying this relation. Another
23958 -- similar case arises when clauses (Constit_1 => Input) and (Output
23959 -- => Constit_2) are matched first, leaving no candidates for clause
23960 -- (State => State). Both scenarios are legal as long as one of the
23961 -- previous clauses mentioned a valid constituent of State.
23963 if not Clause_Matched
23964 and then Is_In_Out_State_Clause
23966 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23968 Clause_Matched := True;
23971 -- A clause where the input is an abstract state with visible null
23972 -- refinement is implicitly matched when the output has already been
23973 -- matched in a previous clause.
23975 -- Depends => (Output => State) -- implicitly OK
23976 -- Refined_State => (State => null)
23977 -- Refined_Depends => (Output => ...)
23979 if not Clause_Matched
23980 and then Is_Null_Refined_State (Dep_Input)
23981 and then Is_Entity_Name (Dep_Output)
23983 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23985 Clause_Matched := True;
23988 -- A clause where the output is an abstract state with visible null
23989 -- refinement is implicitly matched when the input has already been
23990 -- matched in a previous clause.
23992 -- Depends => (State => Input) -- implicitly OK
23993 -- Refined_State => (State => null)
23994 -- Refined_Depends => (... => Input)
23996 if not Clause_Matched
23997 and then Is_Null_Refined_State (Dep_Output)
23998 and then Is_Entity_Name (Dep_Input)
24000 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
24002 Clause_Matched := True;
24005 -- At this point either all refinement clauses have been examined or
24006 -- pragma Refined_Depends contains a solitary null. Only an abstract
24007 -- state with null refinement can possibly match these cases.
24009 -- Depends => (State => null)
24010 -- Refined_State => (State => null)
24011 -- Refined_Depends => null -- OK
24013 if not Clause_Matched then
24015 (Dep_Item => Dep_Input,
24017 Matched => Inputs_Match);
24020 (Dep_Item => Dep_Output,
24022 Matched => Outputs_Match);
24024 Clause_Matched := Inputs_Match and Outputs_Match;
24027 -- If the contents of Refined_Depends are legal, then the current
24028 -- dependence clause should be satisfied either by an explicit match
24029 -- or by one of the special cases.
24031 if not Clause_Matched then
24033 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
24034 & "matching refinement in body"), Dep_Clause, Spec_Id);
24036 end Check_Dependency_Clause;
24038 -------------------------
24039 -- Check_Output_States --
24040 -------------------------
24042 procedure Check_Output_States is
24043 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24044 -- Determine whether all constituents of state State_Id with visible
24045 -- refinement are used as outputs in pragma Refined_Depends. Emit an
24046 -- error if this is not the case.
24048 -----------------------------
24049 -- Check_Constituent_Usage --
24050 -----------------------------
24052 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24053 Constits : constant Elist_Id :=
24054 Refinement_Constituents (State_Id);
24055 Constit_Elmt : Elmt_Id;
24056 Constit_Id : Entity_Id;
24057 Posted : Boolean := False;
24060 if Present (Constits) then
24061 Constit_Elmt := First_Elmt (Constits);
24062 while Present (Constit_Elmt) loop
24063 Constit_Id := Node (Constit_Elmt);
24065 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24067 if Present (Body_Inputs)
24068 and then Appears_In (Body_Inputs, Constit_Id)
24070 Error_Msg_Name_1 := Chars (State_Id);
24072 ("constituent & of state % must act as output in "
24073 & "dependence refinement", N, Constit_Id);
24075 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24077 elsif No (Body_Outputs)
24078 or else not Appears_In (Body_Outputs, Constit_Id)
24083 ("output state & must be replaced by all its "
24084 & "constituents in dependence refinement",
24089 ("\constituent & is missing in output list",
24093 Next_Elmt (Constit_Elmt);
24096 end Check_Constituent_Usage;
24101 Item_Elmt : Elmt_Id;
24102 Item_Id : Entity_Id;
24104 -- Start of processing for Check_Output_States
24107 -- Do not perform this check in an instance because it was already
24108 -- performed successfully in the generic template.
24110 if Is_Generic_Instance (Spec_Id) then
24113 -- Inspect the outputs of pragma Depends looking for a state with a
24114 -- visible refinement.
24116 elsif Present (Spec_Outputs) then
24117 Item_Elmt := First_Elmt (Spec_Outputs);
24118 while Present (Item_Elmt) loop
24119 Item := Node (Item_Elmt);
24121 -- Deal with the mixed nature of the input and output lists
24123 if Nkind (Item) = N_Defining_Identifier then
24126 Item_Id := Available_View (Entity_Of (Item));
24129 if Ekind (Item_Id) = E_Abstract_State then
24131 -- The state acts as an input-output, skip it
24133 if Present (Spec_Inputs)
24134 and then Appears_In (Spec_Inputs, Item_Id)
24138 -- Ensure that all of the constituents are utilized as
24139 -- outputs in pragma Refined_Depends.
24141 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24142 Check_Constituent_Usage (Item_Id);
24146 Next_Elmt (Item_Elmt);
24149 end Check_Output_States;
24151 -----------------------
24152 -- Normalize_Clauses --
24153 -----------------------
24155 procedure Normalize_Clauses (Clauses : List_Id) is
24156 procedure Normalize_Inputs (Clause : Node_Id);
24157 -- Normalize clause Clause by creating multiple clauses for each
24158 -- input item of Clause. It is assumed that Clause has exactly one
24159 -- output. The transformation is as follows:
24161 -- Output => (Input_1, Input_2) -- original
24163 -- Output => Input_1 -- normalizations
24164 -- Output => Input_2
24166 procedure Normalize_Outputs (Clause : Node_Id);
24167 -- Normalize clause Clause by creating multiple clause for each
24168 -- output item of Clause. The transformation is as follows:
24170 -- (Output_1, Output_2) => Input -- original
24172 -- Output_1 => Input -- normalization
24173 -- Output_2 => Input
24175 ----------------------
24176 -- Normalize_Inputs --
24177 ----------------------
24179 procedure Normalize_Inputs (Clause : Node_Id) is
24180 Inputs : constant Node_Id := Expression (Clause);
24181 Loc : constant Source_Ptr := Sloc (Clause);
24182 Output : constant List_Id := Choices (Clause);
24183 Last_Input : Node_Id;
24185 New_Clause : Node_Id;
24186 Next_Input : Node_Id;
24189 -- Normalization is performed only when the original clause has
24190 -- more than one input. Multiple inputs appear as an aggregate.
24192 if Nkind (Inputs) = N_Aggregate then
24193 Last_Input := Last (Expressions (Inputs));
24195 -- Create a new clause for each input
24197 Input := First (Expressions (Inputs));
24198 while Present (Input) loop
24199 Next_Input := Next (Input);
24201 -- Unhook the current input from the original input list
24202 -- because it will be relocated to a new clause.
24206 -- Special processing for the last input. At this point the
24207 -- original aggregate has been stripped down to one element.
24208 -- Replace the aggregate by the element itself.
24210 if Input = Last_Input then
24211 Rewrite (Inputs, Input);
24213 -- Generate a clause of the form:
24218 Make_Component_Association (Loc,
24219 Choices => New_Copy_List_Tree (Output),
24220 Expression => Input);
24222 -- The new clause contains replicated content that has
24223 -- already been analyzed, mark the clause as analyzed.
24225 Set_Analyzed (New_Clause);
24226 Insert_After (Clause, New_Clause);
24229 Input := Next_Input;
24232 end Normalize_Inputs;
24234 -----------------------
24235 -- Normalize_Outputs --
24236 -----------------------
24238 procedure Normalize_Outputs (Clause : Node_Id) is
24239 Inputs : constant Node_Id := Expression (Clause);
24240 Loc : constant Source_Ptr := Sloc (Clause);
24241 Outputs : constant Node_Id := First (Choices (Clause));
24242 Last_Output : Node_Id;
24243 New_Clause : Node_Id;
24244 Next_Output : Node_Id;
24248 -- Multiple outputs appear as an aggregate. Nothing to do when
24249 -- the clause has exactly one output.
24251 if Nkind (Outputs) = N_Aggregate then
24252 Last_Output := Last (Expressions (Outputs));
24254 -- Create a clause for each output. Note that each time a new
24255 -- clause is created, the original output list slowly shrinks
24256 -- until there is one item left.
24258 Output := First (Expressions (Outputs));
24259 while Present (Output) loop
24260 Next_Output := Next (Output);
24262 -- Unhook the output from the original output list as it
24263 -- will be relocated to a new clause.
24267 -- Special processing for the last output. At this point
24268 -- the original aggregate has been stripped down to one
24269 -- element. Replace the aggregate by the element itself.
24271 if Output = Last_Output then
24272 Rewrite (Outputs, Output);
24275 -- Generate a clause of the form:
24276 -- (Output => Inputs)
24279 Make_Component_Association (Loc,
24280 Choices => New_List (Output),
24281 Expression => New_Copy_Tree (Inputs));
24283 -- The new clause contains replicated content that has
24284 -- already been analyzed. There is not need to reanalyze
24287 Set_Analyzed (New_Clause);
24288 Insert_After (Clause, New_Clause);
24291 Output := Next_Output;
24294 end Normalize_Outputs;
24300 -- Start of processing for Normalize_Clauses
24303 Clause := First (Clauses);
24304 while Present (Clause) loop
24305 Normalize_Outputs (Clause);
24309 Clause := First (Clauses);
24310 while Present (Clause) loop
24311 Normalize_Inputs (Clause);
24314 end Normalize_Clauses;
24316 --------------------------
24317 -- Report_Extra_Clauses --
24318 --------------------------
24320 procedure Report_Extra_Clauses is
24324 -- Do not perform this check in an instance because it was already
24325 -- performed successfully in the generic template.
24327 if Is_Generic_Instance (Spec_Id) then
24330 elsif Present (Refinements) then
24331 Clause := First (Refinements);
24332 while Present (Clause) loop
24334 -- Do not complain about a null input refinement, since a null
24335 -- input legitimately matches anything.
24337 if Nkind (Clause) = N_Component_Association
24338 and then Nkind (Expression (Clause)) = N_Null
24344 ("unmatched or extra clause in dependence refinement",
24351 end Report_Extra_Clauses;
24355 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24356 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24357 Errors : constant Nat := Serious_Errors_Detected;
24363 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24366 -- Do not analyze the pragma multiple times
24368 if Is_Analyzed_Pragma (N) then
24372 Spec_Id := Unique_Defining_Entity (Body_Decl);
24374 -- Use the anonymous object as the proper spec when Refined_Depends
24375 -- applies to the body of a single task type. The object carries the
24376 -- proper Chars as well as all non-refined versions of pragmas.
24378 if Is_Single_Concurrent_Type (Spec_Id) then
24379 Spec_Id := Anonymous_Object (Spec_Id);
24382 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
24384 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24385 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24387 if No (Depends) then
24389 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24390 & "& lacks aspect or pragma Depends"), N, Spec_Id);
24394 Deps := Expression (Get_Argument (Depends, Spec_Id));
24396 -- A null dependency relation renders the refinement useless because it
24397 -- cannot possibly mention abstract states with visible refinement. Note
24398 -- that the inverse is not true as states may be refined to null
24399 -- (SPARK RM 7.2.5(2)).
24401 if Nkind (Deps) = N_Null then
24403 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24404 & "depend on abstract state with visible refinement"), N, Spec_Id);
24408 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24409 -- This ensures that the categorization of all refined dependency items
24410 -- is consistent with their role.
24412 Analyze_Depends_In_Decl_Part (N);
24414 -- Do not match dependencies against refinements if Refined_Depends is
24415 -- illegal to avoid emitting misleading error.
24417 if Serious_Errors_Detected = Errors then
24419 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24420 -- the inputs and outputs of the subprogram spec and body to verify
24421 -- the use of states with visible refinement and their constituents.
24423 if No (Get_Pragma (Spec_Id, Pragma_Global))
24424 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
24426 Collect_Subprogram_Inputs_Outputs
24427 (Subp_Id => Spec_Id,
24428 Synthesize => True,
24429 Subp_Inputs => Spec_Inputs,
24430 Subp_Outputs => Spec_Outputs,
24431 Global_Seen => Dummy);
24433 Collect_Subprogram_Inputs_Outputs
24434 (Subp_Id => Body_Id,
24435 Synthesize => True,
24436 Subp_Inputs => Body_Inputs,
24437 Subp_Outputs => Body_Outputs,
24438 Global_Seen => Dummy);
24440 -- For an output state with a visible refinement, ensure that all
24441 -- constituents appear as outputs in the dependency refinement.
24443 Check_Output_States;
24446 -- Matching is disabled in ASIS because clauses are not normalized as
24447 -- this is a tree altering activity similar to expansion.
24453 -- Multiple dependency clauses appear as component associations of an
24454 -- aggregate. Note that the clauses are copied because the algorithm
24455 -- modifies them and this should not be visible in Depends.
24457 pragma Assert (Nkind (Deps) = N_Aggregate);
24458 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
24459 Normalize_Clauses (Dependencies);
24461 Refs := Expression (Get_Argument (N, Spec_Id));
24463 if Nkind (Refs) = N_Null then
24464 Refinements := No_List;
24466 -- Multiple dependency clauses appear as component associations of an
24467 -- aggregate. Note that the clauses are copied because the algorithm
24468 -- modifies them and this should not be visible in Refined_Depends.
24470 else pragma Assert (Nkind (Refs) = N_Aggregate);
24471 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
24472 Normalize_Clauses (Refinements);
24475 -- At this point the clauses of pragmas Depends and Refined_Depends
24476 -- have been normalized into simple dependencies between one output
24477 -- and one input. Examine all clauses of pragma Depends looking for
24478 -- matching clauses in pragma Refined_Depends.
24480 Clause := First (Dependencies);
24481 while Present (Clause) loop
24482 Check_Dependency_Clause (Clause);
24486 if Serious_Errors_Detected = Errors then
24487 Report_Extra_Clauses;
24492 Set_Is_Analyzed_Pragma (N);
24493 end Analyze_Refined_Depends_In_Decl_Part;
24495 -----------------------------------------
24496 -- Analyze_Refined_Global_In_Decl_Part --
24497 -----------------------------------------
24499 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24501 -- The corresponding Global pragma
24503 Has_In_State : Boolean := False;
24504 Has_In_Out_State : Boolean := False;
24505 Has_Out_State : Boolean := False;
24506 Has_Proof_In_State : Boolean := False;
24507 -- These flags are set when the corresponding Global pragma has a state
24508 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24511 Has_Null_State : Boolean := False;
24512 -- This flag is set when the corresponding Global pragma has at least
24513 -- one state with a null refinement.
24515 In_Constits : Elist_Id := No_Elist;
24516 In_Out_Constits : Elist_Id := No_Elist;
24517 Out_Constits : Elist_Id := No_Elist;
24518 Proof_In_Constits : Elist_Id := No_Elist;
24519 -- These lists contain the entities of all Input, In_Out, Output and
24520 -- Proof_In constituents that appear in Refined_Global and participate
24521 -- in state refinement.
24523 In_Items : Elist_Id := No_Elist;
24524 In_Out_Items : Elist_Id := No_Elist;
24525 Out_Items : Elist_Id := No_Elist;
24526 Proof_In_Items : Elist_Id := No_Elist;
24527 -- These list contain the entities of all Input, In_Out, Output and
24528 -- Proof_In items defined in the corresponding Global pragma.
24530 Spec_Id : Entity_Id;
24531 -- The entity of the subprogram subject to pragma Refined_Global
24533 States : Elist_Id := No_Elist;
24534 -- A list of all states with visible refinement found in pragma Global
24536 procedure Check_In_Out_States;
24537 -- Determine whether the corresponding Global pragma mentions In_Out
24538 -- states with visible refinement and if so, ensure that one of the
24539 -- following completions apply to the constituents of the state:
24540 -- 1) there is at least one constituent of mode In_Out
24541 -- 2) there is at least one Input and one Output constituent
24542 -- 3) not all constituents are present and one of them is of mode
24544 -- This routine may remove elements from In_Constits, In_Out_Constits,
24545 -- Out_Constits and Proof_In_Constits.
24547 procedure Check_Input_States;
24548 -- Determine whether the corresponding Global pragma mentions Input
24549 -- states with visible refinement and if so, ensure that at least one of
24550 -- its constituents appears as an Input item in Refined_Global.
24551 -- This routine may remove elements from In_Constits, In_Out_Constits,
24552 -- Out_Constits and Proof_In_Constits.
24554 procedure Check_Output_States;
24555 -- Determine whether the corresponding Global pragma mentions Output
24556 -- states with visible refinement and if so, ensure that all of its
24557 -- constituents appear as Output items in Refined_Global.
24558 -- This routine may remove elements from In_Constits, In_Out_Constits,
24559 -- Out_Constits and Proof_In_Constits.
24561 procedure Check_Proof_In_States;
24562 -- Determine whether the corresponding Global pragma mentions Proof_In
24563 -- states with visible refinement and if so, ensure that at least one of
24564 -- its constituents appears as a Proof_In item in Refined_Global.
24565 -- This routine may remove elements from In_Constits, In_Out_Constits,
24566 -- Out_Constits and Proof_In_Constits.
24568 procedure Check_Refined_Global_List
24570 Global_Mode : Name_Id := Name_Input);
24571 -- Verify the legality of a single global list declaration. Global_Mode
24572 -- denotes the current mode in effect.
24574 procedure Collect_Global_Items
24576 Mode : Name_Id := Name_Input);
24577 -- Gather all input, in out, output and Proof_In items from node List
24578 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24579 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24580 -- and Has_Proof_In_State are set when there is at least one abstract
24581 -- state with visible refinement available in the corresponding mode.
24582 -- Flag Has_Null_State is set when at least state has a null refinement.
24583 -- Mode enotes the current global mode in effect.
24585 function Present_Then_Remove
24587 Item : Entity_Id) return Boolean;
24588 -- Search List for a particular entity Item. If Item has been found,
24589 -- remove it from List. This routine is used to strip lists In_Constits,
24590 -- In_Out_Constits and Out_Constits of valid constituents.
24592 procedure Report_Extra_Constituents;
24593 -- Emit an error for each constituent found in lists In_Constits,
24594 -- In_Out_Constits and Out_Constits.
24596 -------------------------
24597 -- Check_In_Out_States --
24598 -------------------------
24600 procedure Check_In_Out_States is
24601 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24602 -- Determine whether one of the following coverage scenarios is in
24604 -- 1) there is at least one constituent of mode In_Out or Output
24605 -- 2) there is at least one pair of constituents with modes Input
24606 -- and Output, or Proof_In and Output.
24607 -- 3) there is at least one constituent of mode Output and not all
24608 -- constituents are present.
24609 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24611 -----------------------------
24612 -- Check_Constituent_Usage --
24613 -----------------------------
24615 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24616 Constits : constant Elist_Id :=
24617 Refinement_Constituents (State_Id);
24618 Constit_Elmt : Elmt_Id;
24619 Constit_Id : Entity_Id;
24620 Has_Missing : Boolean := False;
24621 In_Out_Seen : Boolean := False;
24622 Input_Seen : Boolean := False;
24623 Output_Seen : Boolean := False;
24624 Proof_In_Seen : Boolean := False;
24627 -- Process all the constituents of the state and note their modes
24628 -- within the global refinement.
24630 if Present (Constits) then
24631 Constit_Elmt := First_Elmt (Constits);
24632 while Present (Constit_Elmt) loop
24633 Constit_Id := Node (Constit_Elmt);
24635 if Present_Then_Remove (In_Constits, Constit_Id) then
24636 Input_Seen := True;
24638 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24639 In_Out_Seen := True;
24641 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24642 Output_Seen := True;
24644 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24646 Proof_In_Seen := True;
24649 Has_Missing := True;
24652 Next_Elmt (Constit_Elmt);
24656 -- An In_Out constituent is a valid completion
24658 if In_Out_Seen then
24661 -- A pair of one Input/Proof_In and one Output constituent is a
24662 -- valid completion.
24664 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
24667 elsif Output_Seen then
24669 -- A single Output constituent is a valid completion only when
24670 -- some of the other constituents are missing.
24672 if Has_Missing then
24675 -- Otherwise all constituents are of mode Output
24679 ("global refinement of state & must include at least one "
24680 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24684 -- The state lacks a completion
24686 elsif not Input_Seen
24687 and not In_Out_Seen
24688 and not Output_Seen
24689 and not Proof_In_Seen
24692 ("missing global refinement of state &", N, State_Id);
24694 -- Otherwise the state has a malformed completion where at least
24695 -- one of the constituents has a different mode.
24699 ("global refinement of state & redefines the mode of its "
24700 & "constituents", N, State_Id);
24702 end Check_Constituent_Usage;
24706 Item_Elmt : Elmt_Id;
24707 Item_Id : Entity_Id;
24709 -- Start of processing for Check_In_Out_States
24712 -- Do not perform this check in an instance because it was already
24713 -- performed successfully in the generic template.
24715 if Is_Generic_Instance (Spec_Id) then
24718 -- Inspect the In_Out items of the corresponding Global pragma
24719 -- looking for a state with a visible refinement.
24721 elsif Has_In_Out_State and then Present (In_Out_Items) then
24722 Item_Elmt := First_Elmt (In_Out_Items);
24723 while Present (Item_Elmt) loop
24724 Item_Id := Node (Item_Elmt);
24726 -- Ensure that one of the three coverage variants is satisfied
24728 if Ekind (Item_Id) = E_Abstract_State
24729 and then Has_Non_Null_Visible_Refinement (Item_Id)
24731 Check_Constituent_Usage (Item_Id);
24734 Next_Elmt (Item_Elmt);
24737 end Check_In_Out_States;
24739 ------------------------
24740 -- Check_Input_States --
24741 ------------------------
24743 procedure Check_Input_States is
24744 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24745 -- Determine whether at least one constituent of state State_Id with
24746 -- visible refinement is used and has mode Input. Ensure that the
24747 -- remaining constituents do not have In_Out or Output modes. Emit an
24748 -- error if this is not the case (SPARK RM 7.2.4(5)).
24750 -----------------------------
24751 -- Check_Constituent_Usage --
24752 -----------------------------
24754 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24755 Constits : constant Elist_Id :=
24756 Refinement_Constituents (State_Id);
24757 Constit_Elmt : Elmt_Id;
24758 Constit_Id : Entity_Id;
24759 In_Seen : Boolean := False;
24762 if Present (Constits) then
24763 Constit_Elmt := First_Elmt (Constits);
24764 while Present (Constit_Elmt) loop
24765 Constit_Id := Node (Constit_Elmt);
24767 -- At least one of the constituents appears as an Input
24769 if Present_Then_Remove (In_Constits, Constit_Id) then
24772 -- A Proof_In constituent can refine an Input state as long
24773 -- as there is at least one Input constituent present.
24775 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24779 -- The constituent appears in the global refinement, but has
24780 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24782 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24783 or else Present_Then_Remove (Out_Constits, Constit_Id)
24785 Error_Msg_Name_1 := Chars (State_Id);
24787 ("constituent & of state % must have mode `Input` in "
24788 & "global refinement", N, Constit_Id);
24791 Next_Elmt (Constit_Elmt);
24795 -- Not one of the constituents appeared as Input
24797 if not In_Seen then
24799 ("global refinement of state & must include at least one "
24800 & "constituent of mode `Input`", N, State_Id);
24802 end Check_Constituent_Usage;
24806 Item_Elmt : Elmt_Id;
24807 Item_Id : Entity_Id;
24809 -- Start of processing for Check_Input_States
24812 -- Do not perform this check in an instance because it was already
24813 -- performed successfully in the generic template.
24815 if Is_Generic_Instance (Spec_Id) then
24818 -- Inspect the Input items of the corresponding Global pragma looking
24819 -- for a state with a visible refinement.
24821 elsif Has_In_State and then Present (In_Items) then
24822 Item_Elmt := First_Elmt (In_Items);
24823 while Present (Item_Elmt) loop
24824 Item_Id := Node (Item_Elmt);
24826 -- Ensure that at least one of the constituents is utilized and
24827 -- is of mode Input.
24829 if Ekind (Item_Id) = E_Abstract_State
24830 and then Has_Non_Null_Visible_Refinement (Item_Id)
24832 Check_Constituent_Usage (Item_Id);
24835 Next_Elmt (Item_Elmt);
24838 end Check_Input_States;
24840 -------------------------
24841 -- Check_Output_States --
24842 -------------------------
24844 procedure Check_Output_States is
24845 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24846 -- Determine whether all constituents of state State_Id with visible
24847 -- refinement are used and have mode Output. Emit an error if this is
24848 -- not the case (SPARK RM 7.2.4(5)).
24850 -----------------------------
24851 -- Check_Constituent_Usage --
24852 -----------------------------
24854 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24855 Constits : constant Elist_Id :=
24856 Refinement_Constituents (State_Id);
24857 Constit_Elmt : Elmt_Id;
24858 Constit_Id : Entity_Id;
24859 Posted : Boolean := False;
24862 if Present (Constits) then
24863 Constit_Elmt := First_Elmt (Constits);
24864 while Present (Constit_Elmt) loop
24865 Constit_Id := Node (Constit_Elmt);
24867 if Present_Then_Remove (Out_Constits, Constit_Id) then
24870 -- The constituent appears in the global refinement, but has
24871 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24873 elsif Present_Then_Remove (In_Constits, Constit_Id)
24874 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24875 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24877 Error_Msg_Name_1 := Chars (State_Id);
24879 ("constituent & of state % must have mode `Output` in "
24880 & "global refinement", N, Constit_Id);
24882 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24888 ("`Output` state & must be replaced by all its "
24889 & "constituents in global refinement", N, State_Id);
24893 ("\constituent & is missing in output list",
24897 Next_Elmt (Constit_Elmt);
24900 end Check_Constituent_Usage;
24904 Item_Elmt : Elmt_Id;
24905 Item_Id : Entity_Id;
24907 -- Start of processing for Check_Output_States
24910 -- Do not perform this check in an instance because it was already
24911 -- performed successfully in the generic template.
24913 if Is_Generic_Instance (Spec_Id) then
24916 -- Inspect the Output items of the corresponding Global pragma
24917 -- looking for a state with a visible refinement.
24919 elsif Has_Out_State and then Present (Out_Items) then
24920 Item_Elmt := First_Elmt (Out_Items);
24921 while Present (Item_Elmt) loop
24922 Item_Id := Node (Item_Elmt);
24924 -- Ensure that all of the constituents are utilized and they
24925 -- have mode Output.
24927 if Ekind (Item_Id) = E_Abstract_State
24928 and then Has_Non_Null_Visible_Refinement (Item_Id)
24930 Check_Constituent_Usage (Item_Id);
24933 Next_Elmt (Item_Elmt);
24936 end Check_Output_States;
24938 ---------------------------
24939 -- Check_Proof_In_States --
24940 ---------------------------
24942 procedure Check_Proof_In_States is
24943 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24944 -- Determine whether at least one constituent of state State_Id with
24945 -- visible refinement is used and has mode Proof_In. Ensure that the
24946 -- remaining constituents do not have Input, In_Out or Output modes.
24947 -- Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24949 -----------------------------
24950 -- Check_Constituent_Usage --
24951 -----------------------------
24953 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24954 Constits : constant Elist_Id :=
24955 Refinement_Constituents (State_Id);
24956 Constit_Elmt : Elmt_Id;
24957 Constit_Id : Entity_Id;
24958 Proof_In_Seen : Boolean := False;
24961 if Present (Constits) then
24962 Constit_Elmt := First_Elmt (Constits);
24963 while Present (Constit_Elmt) loop
24964 Constit_Id := Node (Constit_Elmt);
24966 -- At least one of the constituents appears as Proof_In
24968 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24969 Proof_In_Seen := True;
24971 -- The constituent appears in the global refinement, but has
24972 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24974 elsif Present_Then_Remove (In_Constits, Constit_Id)
24975 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24976 or else Present_Then_Remove (Out_Constits, Constit_Id)
24978 Error_Msg_Name_1 := Chars (State_Id);
24980 ("constituent & of state % must have mode `Proof_In` "
24981 & "in global refinement", N, Constit_Id);
24984 Next_Elmt (Constit_Elmt);
24988 -- Not one of the constituents appeared as Proof_In
24990 if not Proof_In_Seen then
24992 ("global refinement of state & must include at least one "
24993 & "constituent of mode `Proof_In`", N, State_Id);
24995 end Check_Constituent_Usage;
24999 Item_Elmt : Elmt_Id;
25000 Item_Id : Entity_Id;
25002 -- Start of processing for Check_Proof_In_States
25005 -- Do not perform this check in an instance because it was already
25006 -- performed successfully in the generic template.
25008 if Is_Generic_Instance (Spec_Id) then
25011 -- Inspect the Proof_In items of the corresponding Global pragma
25012 -- looking for a state with a visible refinement.
25014 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
25015 Item_Elmt := First_Elmt (Proof_In_Items);
25016 while Present (Item_Elmt) loop
25017 Item_Id := Node (Item_Elmt);
25019 -- Ensure that at least one of the constituents is utilized and
25020 -- is of mode Proof_In
25022 if Ekind (Item_Id) = E_Abstract_State
25023 and then Has_Non_Null_Visible_Refinement (Item_Id)
25025 Check_Constituent_Usage (Item_Id);
25028 Next_Elmt (Item_Elmt);
25031 end Check_Proof_In_States;
25033 -------------------------------
25034 -- Check_Refined_Global_List --
25035 -------------------------------
25037 procedure Check_Refined_Global_List
25039 Global_Mode : Name_Id := Name_Input)
25041 procedure Check_Refined_Global_Item
25043 Global_Mode : Name_Id);
25044 -- Verify the legality of a single global item declaration. Parameter
25045 -- Global_Mode denotes the current mode in effect.
25047 -------------------------------
25048 -- Check_Refined_Global_Item --
25049 -------------------------------
25051 procedure Check_Refined_Global_Item
25053 Global_Mode : Name_Id)
25055 Item_Id : constant Entity_Id := Entity_Of (Item);
25057 procedure Inconsistent_Mode_Error (Expect : Name_Id);
25058 -- Issue a common error message for all mode mismatches. Expect
25059 -- denotes the expected mode.
25061 -----------------------------
25062 -- Inconsistent_Mode_Error --
25063 -----------------------------
25065 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
25068 ("global item & has inconsistent modes", Item, Item_Id);
25070 Error_Msg_Name_1 := Global_Mode;
25071 Error_Msg_Name_2 := Expect;
25072 SPARK_Msg_N ("\expected mode %, found mode %", Item);
25073 end Inconsistent_Mode_Error;
25075 -- Start of processing for Check_Refined_Global_Item
25078 -- When the state or object acts as a constituent of another
25079 -- state with a visible refinement, collect it for the state
25080 -- completeness checks performed later on. Note that the item
25081 -- acts as a constituent only when the encapsulating state is
25082 -- present in pragma Global.
25084 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
25085 and then Present (Encapsulating_State (Item_Id))
25086 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
25087 and then Contains (States, Encapsulating_State (Item_Id))
25089 if Global_Mode = Name_Input then
25090 Append_New_Elmt (Item_Id, In_Constits);
25092 elsif Global_Mode = Name_In_Out then
25093 Append_New_Elmt (Item_Id, In_Out_Constits);
25095 elsif Global_Mode = Name_Output then
25096 Append_New_Elmt (Item_Id, Out_Constits);
25098 elsif Global_Mode = Name_Proof_In then
25099 Append_New_Elmt (Item_Id, Proof_In_Constits);
25102 -- When not a constituent, ensure that both occurrences of the
25103 -- item in pragmas Global and Refined_Global match.
25105 elsif Contains (In_Items, Item_Id) then
25106 if Global_Mode /= Name_Input then
25107 Inconsistent_Mode_Error (Name_Input);
25110 elsif Contains (In_Out_Items, Item_Id) then
25111 if Global_Mode /= Name_In_Out then
25112 Inconsistent_Mode_Error (Name_In_Out);
25115 elsif Contains (Out_Items, Item_Id) then
25116 if Global_Mode /= Name_Output then
25117 Inconsistent_Mode_Error (Name_Output);
25120 elsif Contains (Proof_In_Items, Item_Id) then
25123 -- The item does not appear in the corresponding Global pragma,
25124 -- it must be an extra (SPARK RM 7.2.4(3)).
25127 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
25129 end Check_Refined_Global_Item;
25135 -- Start of processing for Check_Refined_Global_List
25138 -- Do not perform this check in an instance because it was already
25139 -- performed successfully in the generic template.
25141 if Is_Generic_Instance (Spec_Id) then
25144 elsif Nkind (List) = N_Null then
25147 -- Single global item declaration
25149 elsif Nkind_In (List, N_Expanded_Name,
25151 N_Selected_Component)
25153 Check_Refined_Global_Item (List, Global_Mode);
25155 -- Simple global list or moded global list declaration
25157 elsif Nkind (List) = N_Aggregate then
25159 -- The declaration of a simple global list appear as a collection
25162 if Present (Expressions (List)) then
25163 Item := First (Expressions (List));
25164 while Present (Item) loop
25165 Check_Refined_Global_Item (Item, Global_Mode);
25169 -- The declaration of a moded global list appears as a collection
25170 -- of component associations where individual choices denote
25173 elsif Present (Component_Associations (List)) then
25174 Item := First (Component_Associations (List));
25175 while Present (Item) loop
25176 Check_Refined_Global_List
25177 (List => Expression (Item),
25178 Global_Mode => Chars (First (Choices (Item))));
25186 raise Program_Error;
25192 raise Program_Error;
25194 end Check_Refined_Global_List;
25196 --------------------------
25197 -- Collect_Global_Items --
25198 --------------------------
25200 procedure Collect_Global_Items
25202 Mode : Name_Id := Name_Input)
25204 procedure Collect_Global_Item
25206 Item_Mode : Name_Id);
25207 -- Add a single item to the appropriate list. Item_Mode denotes the
25208 -- current mode in effect.
25210 -------------------------
25211 -- Collect_Global_Item --
25212 -------------------------
25214 procedure Collect_Global_Item
25216 Item_Mode : Name_Id)
25218 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25219 -- The above handles abstract views of variables and states built
25220 -- for limited with clauses.
25223 -- Signal that the global list contains at least one abstract
25224 -- state with a visible refinement. Note that the refinement may
25225 -- be null in which case there are no constituents.
25227 if Ekind (Item_Id) = E_Abstract_State then
25228 if Has_Null_Visible_Refinement (Item_Id) then
25229 Has_Null_State := True;
25231 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
25232 Append_New_Elmt (Item_Id, States);
25234 if Item_Mode = Name_Input then
25235 Has_In_State := True;
25236 elsif Item_Mode = Name_In_Out then
25237 Has_In_Out_State := True;
25238 elsif Item_Mode = Name_Output then
25239 Has_Out_State := True;
25240 elsif Item_Mode = Name_Proof_In then
25241 Has_Proof_In_State := True;
25246 -- Add the item to the proper list
25248 if Item_Mode = Name_Input then
25249 Append_New_Elmt (Item_Id, In_Items);
25250 elsif Item_Mode = Name_In_Out then
25251 Append_New_Elmt (Item_Id, In_Out_Items);
25252 elsif Item_Mode = Name_Output then
25253 Append_New_Elmt (Item_Id, Out_Items);
25254 elsif Item_Mode = Name_Proof_In then
25255 Append_New_Elmt (Item_Id, Proof_In_Items);
25257 end Collect_Global_Item;
25263 -- Start of processing for Collect_Global_Items
25266 if Nkind (List) = N_Null then
25269 -- Single global item declaration
25271 elsif Nkind_In (List, N_Expanded_Name,
25273 N_Selected_Component)
25275 Collect_Global_Item (List, Mode);
25277 -- Single global list or moded global list declaration
25279 elsif Nkind (List) = N_Aggregate then
25281 -- The declaration of a simple global list appear as a collection
25284 if Present (Expressions (List)) then
25285 Item := First (Expressions (List));
25286 while Present (Item) loop
25287 Collect_Global_Item (Item, Mode);
25291 -- The declaration of a moded global list appears as a collection
25292 -- of component associations where individual choices denote mode.
25294 elsif Present (Component_Associations (List)) then
25295 Item := First (Component_Associations (List));
25296 while Present (Item) loop
25297 Collect_Global_Items
25298 (List => Expression (Item),
25299 Mode => Chars (First (Choices (Item))));
25307 raise Program_Error;
25310 -- To accomodate partial decoration of disabled SPARK features, this
25311 -- routine may be called with illegal input. If this is the case, do
25312 -- not raise Program_Error.
25317 end Collect_Global_Items;
25319 -------------------------
25320 -- Present_Then_Remove --
25321 -------------------------
25323 function Present_Then_Remove
25325 Item : Entity_Id) return Boolean
25330 if Present (List) then
25331 Elmt := First_Elmt (List);
25332 while Present (Elmt) loop
25333 if Node (Elmt) = Item then
25334 Remove_Elmt (List, Elmt);
25343 end Present_Then_Remove;
25345 -------------------------------
25346 -- Report_Extra_Constituents --
25347 -------------------------------
25349 procedure Report_Extra_Constituents is
25350 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
25351 -- Emit an error for every element of List
25353 ---------------------------------------
25354 -- Report_Extra_Constituents_In_List --
25355 ---------------------------------------
25357 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
25358 Constit_Elmt : Elmt_Id;
25361 if Present (List) then
25362 Constit_Elmt := First_Elmt (List);
25363 while Present (Constit_Elmt) loop
25364 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
25365 Next_Elmt (Constit_Elmt);
25368 end Report_Extra_Constituents_In_List;
25370 -- Start of processing for Report_Extra_Constituents
25373 -- Do not perform this check in an instance because it was already
25374 -- performed successfully in the generic template.
25376 if Is_Generic_Instance (Spec_Id) then
25380 Report_Extra_Constituents_In_List (In_Constits);
25381 Report_Extra_Constituents_In_List (In_Out_Constits);
25382 Report_Extra_Constituents_In_List (Out_Constits);
25383 Report_Extra_Constituents_In_List (Proof_In_Constits);
25385 end Report_Extra_Constituents;
25389 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25390 Errors : constant Nat := Serious_Errors_Detected;
25393 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25396 -- Do not analyze the pragma multiple times
25398 if Is_Analyzed_Pragma (N) then
25402 Spec_Id := Unique_Defining_Entity (Body_Decl);
25404 -- Use the anonymous object as the proper spec when Refined_Global
25405 -- applies to the body of a single task type. The object carries the
25406 -- proper Chars as well as all non-refined versions of pragmas.
25408 if Is_Single_Concurrent_Type (Spec_Id) then
25409 Spec_Id := Anonymous_Object (Spec_Id);
25412 Global := Get_Pragma (Spec_Id, Pragma_Global);
25413 Items := Expression (Get_Argument (N, Spec_Id));
25415 -- The subprogram declaration lacks pragma Global. This renders
25416 -- Refined_Global useless as there is nothing to refine.
25418 if No (Global) then
25420 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25421 & "& lacks aspect or pragma Global"), N, Spec_Id);
25425 -- Extract all relevant items from the corresponding Global pragma
25427 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
25429 -- Package and subprogram bodies are instantiated individually in
25430 -- a separate compiler pass. Due to this mode of instantiation, the
25431 -- refinement of a state may no longer be visible when a subprogram
25432 -- body contract is instantiated. Since the generic template is legal,
25433 -- do not perform this check in the instance to circumvent this oddity.
25435 if Is_Generic_Instance (Spec_Id) then
25438 -- Non-instance case
25441 -- The corresponding Global pragma must mention at least one state
25442 -- witha visible refinement at the point Refined_Global is processed.
25443 -- States with null refinements need Refined_Global pragma
25444 -- (SPARK RM 7.2.4(2)).
25446 if not Has_In_State
25447 and then not Has_In_Out_State
25448 and then not Has_Out_State
25449 and then not Has_Proof_In_State
25450 and then not Has_Null_State
25453 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25454 & "depend on abstract state with visible refinement"),
25458 -- The global refinement of inputs and outputs cannot be null when
25459 -- the corresponding Global pragma contains at least one item except
25460 -- in the case where we have states with null refinements.
25462 elsif Nkind (Items) = N_Null
25464 (Present (In_Items)
25465 or else Present (In_Out_Items)
25466 or else Present (Out_Items)
25467 or else Present (Proof_In_Items))
25468 and then not Has_Null_State
25471 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
25472 & "global items"), N, Spec_Id);
25477 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25478 -- This ensures that the categorization of all refined global items is
25479 -- consistent with their role.
25481 Analyze_Global_In_Decl_Part (N);
25483 -- Perform all refinement checks with respect to completeness and mode
25486 if Serious_Errors_Detected = Errors then
25487 Check_Refined_Global_List (Items);
25490 -- For Input states with visible refinement, at least one constituent
25491 -- must be used as an Input in the global refinement.
25493 if Serious_Errors_Detected = Errors then
25494 Check_Input_States;
25497 -- Verify all possible completion variants for In_Out states with
25498 -- visible refinement.
25500 if Serious_Errors_Detected = Errors then
25501 Check_In_Out_States;
25504 -- For Output states with visible refinement, all constituents must be
25505 -- used as Outputs in the global refinement.
25507 if Serious_Errors_Detected = Errors then
25508 Check_Output_States;
25511 -- For Proof_In states with visible refinement, at least one constituent
25512 -- must be used as Proof_In in the global refinement.
25514 if Serious_Errors_Detected = Errors then
25515 Check_Proof_In_States;
25518 -- Emit errors for all constituents that belong to other states with
25519 -- visible refinement that do not appear in Global.
25521 if Serious_Errors_Detected = Errors then
25522 Report_Extra_Constituents;
25526 Set_Is_Analyzed_Pragma (N);
25527 end Analyze_Refined_Global_In_Decl_Part;
25529 ----------------------------------------
25530 -- Analyze_Refined_State_In_Decl_Part --
25531 ----------------------------------------
25533 procedure Analyze_Refined_State_In_Decl_Part
25535 Freeze_Id : Entity_Id := Empty)
25537 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
25538 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25539 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
25541 Available_States : Elist_Id := No_Elist;
25542 -- A list of all abstract states defined in the package declaration that
25543 -- are available for refinement. The list is used to report unrefined
25546 Body_States : Elist_Id := No_Elist;
25547 -- A list of all hidden states that appear in the body of the related
25548 -- package. The list is used to report unused hidden states.
25550 Constituents_Seen : Elist_Id := No_Elist;
25551 -- A list that contains all constituents processed so far. The list is
25552 -- used to detect multiple uses of the same constituent.
25554 Freeze_Posted : Boolean := False;
25555 -- A flag that controls the output of a freezing-related error (see use
25558 Refined_States_Seen : Elist_Id := No_Elist;
25559 -- A list that contains all refined states processed so far. The list is
25560 -- used to detect duplicate refinements.
25562 procedure Analyze_Refinement_Clause (Clause : Node_Id);
25563 -- Perform full analysis of a single refinement clause
25565 procedure Report_Unrefined_States (States : Elist_Id);
25566 -- Emit errors for all unrefined abstract states found in list States
25568 -------------------------------
25569 -- Analyze_Refinement_Clause --
25570 -------------------------------
25572 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25573 AR_Constit : Entity_Id := Empty;
25574 AW_Constit : Entity_Id := Empty;
25575 ER_Constit : Entity_Id := Empty;
25576 EW_Constit : Entity_Id := Empty;
25577 -- The entities of external constituents that contain one of the
25578 -- following enabled properties: Async_Readers, Async_Writers,
25579 -- Effective_Reads and Effective_Writes.
25581 External_Constit_Seen : Boolean := False;
25582 -- Flag used to mark when at least one external constituent is part
25583 -- of the state refinement.
25585 Non_Null_Seen : Boolean := False;
25586 Null_Seen : Boolean := False;
25587 -- Flags used to detect multiple uses of null in a single clause or a
25588 -- mixture of null and non-null constituents.
25590 Part_Of_Constits : Elist_Id := No_Elist;
25591 -- A list of all candidate constituents subject to indicator Part_Of
25592 -- where the encapsulating state is the current state.
25595 State_Id : Entity_Id;
25596 -- The current state being refined
25598 procedure Analyze_Constituent (Constit : Node_Id);
25599 -- Perform full analysis of a single constituent
25601 procedure Check_External_Property
25602 (Prop_Nam : Name_Id;
25604 Constit : Entity_Id);
25605 -- Determine whether a property denoted by name Prop_Nam is present
25606 -- in the refined state. Emit an error if this is not the case. Flag
25607 -- Enabled should be set when the property applies to the refined
25608 -- state. Constit denotes the constituent (if any) which introduces
25609 -- the property in the refinement.
25611 procedure Match_State;
25612 -- Determine whether the state being refined appears in list
25613 -- Available_States. Emit an error when attempting to re-refine the
25614 -- state or when the state is not defined in the package declaration,
25615 -- otherwise remove the state from Available_States.
25617 procedure Report_Unused_Constituents (Constits : Elist_Id);
25618 -- Emit errors for all unused Part_Of constituents in list Constits
25620 -------------------------
25621 -- Analyze_Constituent --
25622 -------------------------
25624 procedure Analyze_Constituent (Constit : Node_Id) is
25625 procedure Match_Constituent (Constit_Id : Entity_Id);
25626 -- Determine whether constituent Constit denoted by its entity
25627 -- Constit_Id appears in Body_States. Emit an error when the
25628 -- constituent is not a valid hidden state of the related package
25629 -- or when it is used more than once. Otherwise remove the
25630 -- constituent from Body_States.
25632 -----------------------
25633 -- Match_Constituent --
25634 -----------------------
25636 procedure Match_Constituent (Constit_Id : Entity_Id) is
25637 procedure Collect_Constituent;
25638 -- Verify the legality of constituent Constit_Id and add it to
25639 -- the refinements of State_Id.
25641 -------------------------
25642 -- Collect_Constituent --
25643 -------------------------
25645 procedure Collect_Constituent is
25646 Constits : Elist_Id;
25649 -- The Ghost policy in effect at the point of abstract state
25650 -- declaration and constituent must match (SPARK RM 6.9(15))
25652 Check_Ghost_Refinement
25653 (State, State_Id, Constit, Constit_Id);
25655 -- A synchronized state must be refined by a synchronized
25656 -- object or another synchronized state (SPARK RM 9.6).
25658 if Is_Synchronized_State (State_Id)
25659 and then not Is_Synchronized_Object (Constit_Id)
25660 and then not Is_Synchronized_State (Constit_Id)
25663 ("constituent of synchronized state & must be "
25664 & "synchronized", Constit, State_Id);
25667 -- Add the constituent to the list of processed items to aid
25668 -- with the detection of duplicates.
25670 Append_New_Elmt (Constit_Id, Constituents_Seen);
25672 -- Collect the constituent in the list of refinement items
25673 -- and establish a relation between the refined state and
25676 Constits := Refinement_Constituents (State_Id);
25678 if No (Constits) then
25679 Constits := New_Elmt_List;
25680 Set_Refinement_Constituents (State_Id, Constits);
25683 Append_Elmt (Constit_Id, Constits);
25684 Set_Encapsulating_State (Constit_Id, State_Id);
25686 -- The state has at least one legal constituent, mark the
25687 -- start of the refinement region. The region ends when the
25688 -- body declarations end (see routine Analyze_Declarations).
25690 Set_Has_Visible_Refinement (State_Id);
25692 -- When the constituent is external, save its relevant
25693 -- property for further checks.
25695 if Async_Readers_Enabled (Constit_Id) then
25696 AR_Constit := Constit_Id;
25697 External_Constit_Seen := True;
25700 if Async_Writers_Enabled (Constit_Id) then
25701 AW_Constit := Constit_Id;
25702 External_Constit_Seen := True;
25705 if Effective_Reads_Enabled (Constit_Id) then
25706 ER_Constit := Constit_Id;
25707 External_Constit_Seen := True;
25710 if Effective_Writes_Enabled (Constit_Id) then
25711 EW_Constit := Constit_Id;
25712 External_Constit_Seen := True;
25714 end Collect_Constituent;
25718 State_Elmt : Elmt_Id;
25720 -- Start of processing for Match_Constituent
25723 -- Detect a duplicate use of a constituent
25725 if Contains (Constituents_Seen, Constit_Id) then
25727 ("duplicate use of constituent &", Constit, Constit_Id);
25731 -- The constituent is subject to a Part_Of indicator
25733 if Present (Encapsulating_State (Constit_Id)) then
25734 if Encapsulating_State (Constit_Id) = State_Id then
25735 Remove (Part_Of_Constits, Constit_Id);
25736 Collect_Constituent;
25738 -- The constituent is part of another state and is used
25739 -- incorrectly in the refinement of the current state.
25742 Error_Msg_Name_1 := Chars (State_Id);
25744 ("& cannot act as constituent of state %",
25745 Constit, Constit_Id);
25747 ("\Part_Of indicator specifies encapsulator &",
25748 Constit, Encapsulating_State (Constit_Id));
25751 -- The only other source of legal constituents is the body
25752 -- state space of the related package.
25755 if Present (Body_States) then
25756 State_Elmt := First_Elmt (Body_States);
25757 while Present (State_Elmt) loop
25759 -- Consume a valid constituent to signal that it has
25760 -- been encountered.
25762 if Node (State_Elmt) = Constit_Id then
25763 Remove_Elmt (Body_States, State_Elmt);
25764 Collect_Constituent;
25768 Next_Elmt (State_Elmt);
25772 -- Constants are part of the hidden state of a package, but
25773 -- the compiler cannot determine whether they have variable
25774 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25775 -- hidden state. Accept the constant quietly even if it is
25776 -- a visible state or lacks a Part_Of indicator.
25778 if Ekind (Constit_Id) = E_Constant then
25779 Collect_Constituent;
25781 -- If we get here, then the constituent is not a hidden
25782 -- state of the related package and may not be used in a
25783 -- refinement (SPARK RM 7.2.2(9)).
25786 Error_Msg_Name_1 := Chars (Spec_Id);
25788 ("cannot use & in refinement, constituent is not a "
25789 & "hidden state of package %", Constit, Constit_Id);
25792 end Match_Constituent;
25796 Constit_Id : Entity_Id;
25797 Constits : Elist_Id;
25799 -- Start of processing for Analyze_Constituent
25802 -- Detect multiple uses of null in a single refinement clause or a
25803 -- mixture of null and non-null constituents.
25805 if Nkind (Constit) = N_Null then
25808 ("multiple null constituents not allowed", Constit);
25810 elsif Non_Null_Seen then
25812 ("cannot mix null and non-null constituents", Constit);
25817 -- Collect the constituent in the list of refinement items
25819 Constits := Refinement_Constituents (State_Id);
25821 if No (Constits) then
25822 Constits := New_Elmt_List;
25823 Set_Refinement_Constituents (State_Id, Constits);
25826 Append_Elmt (Constit, Constits);
25828 -- The state has at least one legal constituent, mark the
25829 -- start of the refinement region. The region ends when the
25830 -- body declarations end (see Analyze_Declarations).
25832 Set_Has_Visible_Refinement (State_Id);
25835 -- Non-null constituents
25838 Non_Null_Seen := True;
25842 ("cannot mix null and non-null constituents", Constit);
25846 Resolve_State (Constit);
25848 -- Ensure that the constituent denotes a valid state or a
25849 -- whole object (SPARK RM 7.2.2(5)).
25851 if Is_Entity_Name (Constit) then
25852 Constit_Id := Entity_Of (Constit);
25854 -- When a constituent is declared after a subprogram body
25855 -- that caused "freezing" of the related contract where
25856 -- pragma Refined_State resides, the constituent appears
25857 -- undefined and carries Any_Id as its entity.
25859 -- package body Pack
25860 -- with Refined_State => (State => Constit)
25863 -- with Refined_Global => (Input => Constit)
25871 if Constit_Id = Any_Id then
25872 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25874 -- Emit a specialized info message when the contract of
25875 -- the related package body was "frozen" by another body.
25876 -- Note that it is not possible to precisely identify why
25877 -- the constituent is undefined because it is not visible
25878 -- when pragma Refined_State is analyzed. This message is
25879 -- a reasonable approximation.
25881 if Present (Freeze_Id) and then not Freeze_Posted then
25882 Freeze_Posted := True;
25884 Error_Msg_Name_1 := Chars (Body_Id);
25885 Error_Msg_Sloc := Sloc (Freeze_Id);
25887 ("body & declared # freezes the contract of %",
25890 ("\all constituents must be declared before body #",
25893 -- A misplaced constituent is a critical error because
25894 -- pragma Refined_Depends or Refined_Global depends on
25895 -- the proper link between a state and a constituent.
25896 -- Stop the compilation, as this leads to a multitude
25897 -- of misleading cascaded errors.
25899 raise Program_Error;
25902 -- The constituent is a valid state or object
25904 elsif Ekind_In (Constit_Id, E_Abstract_State,
25908 Match_Constituent (Constit_Id);
25910 -- The variable may eventually become a constituent of a
25911 -- single protected/task type. Record the reference now
25912 -- and verify its legality when analyzing the contract of
25913 -- the variable (SPARK RM 9.3).
25915 if Ekind (Constit_Id) = E_Variable then
25916 Record_Possible_Part_Of_Reference
25917 (Var_Id => Constit_Id,
25921 -- Otherwise the constituent is illegal
25925 ("constituent & must denote object or state",
25926 Constit, Constit_Id);
25929 -- The constituent is illegal
25932 SPARK_Msg_N ("malformed constituent", Constit);
25935 end Analyze_Constituent;
25937 -----------------------------
25938 -- Check_External_Property --
25939 -----------------------------
25941 procedure Check_External_Property
25942 (Prop_Nam : Name_Id;
25944 Constit : Entity_Id)
25947 -- The property is missing in the declaration of the state, but
25948 -- a constituent is introducing it in the state refinement
25949 -- (SPARK RM 7.2.8(2)).
25951 if not Enabled and then Present (Constit) then
25952 Error_Msg_Name_1 := Prop_Nam;
25953 Error_Msg_Name_2 := Chars (State_Id);
25955 ("constituent & introduces external property % in refinement "
25956 & "of state %", State, Constit);
25958 Error_Msg_Sloc := Sloc (State_Id);
25960 ("\property is missing in abstract state declaration #",
25963 end Check_External_Property;
25969 procedure Match_State is
25970 State_Elmt : Elmt_Id;
25973 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25975 if Contains (Refined_States_Seen, State_Id) then
25977 ("duplicate refinement of state &", State, State_Id);
25981 -- Inspect the abstract states defined in the package declaration
25982 -- looking for a match.
25984 State_Elmt := First_Elmt (Available_States);
25985 while Present (State_Elmt) loop
25987 -- A valid abstract state is being refined in the body. Add
25988 -- the state to the list of processed refined states to aid
25989 -- with the detection of duplicate refinements. Remove the
25990 -- state from Available_States to signal that it has already
25993 if Node (State_Elmt) = State_Id then
25994 Append_New_Elmt (State_Id, Refined_States_Seen);
25995 Remove_Elmt (Available_States, State_Elmt);
25999 Next_Elmt (State_Elmt);
26002 -- If we get here, we are refining a state that is not defined in
26003 -- the package declaration.
26005 Error_Msg_Name_1 := Chars (Spec_Id);
26007 ("cannot refine state, & is not defined in package %",
26011 --------------------------------
26012 -- Report_Unused_Constituents --
26013 --------------------------------
26015 procedure Report_Unused_Constituents (Constits : Elist_Id) is
26016 Constit_Elmt : Elmt_Id;
26017 Constit_Id : Entity_Id;
26018 Posted : Boolean := False;
26021 if Present (Constits) then
26022 Constit_Elmt := First_Elmt (Constits);
26023 while Present (Constit_Elmt) loop
26024 Constit_Id := Node (Constit_Elmt);
26026 -- Generate an error message of the form:
26028 -- state ... has unused Part_Of constituents
26029 -- abstract state ... defined at ...
26030 -- constant ... defined at ...
26031 -- variable ... defined at ...
26036 ("state & has unused Part_Of constituents",
26040 Error_Msg_Sloc := Sloc (Constit_Id);
26042 if Ekind (Constit_Id) = E_Abstract_State then
26044 ("\abstract state & defined #", State, Constit_Id);
26046 elsif Ekind (Constit_Id) = E_Constant then
26048 ("\constant & defined #", State, Constit_Id);
26051 pragma Assert (Ekind (Constit_Id) = E_Variable);
26052 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
26055 Next_Elmt (Constit_Elmt);
26058 end Report_Unused_Constituents;
26060 -- Local declarations
26062 Body_Ref : Node_Id;
26063 Body_Ref_Elmt : Elmt_Id;
26065 Extra_State : Node_Id;
26067 -- Start of processing for Analyze_Refinement_Clause
26070 -- A refinement clause appears as a component association where the
26071 -- sole choice is the state and the expressions are the constituents.
26072 -- This is a syntax error, always report.
26074 if Nkind (Clause) /= N_Component_Association then
26075 Error_Msg_N ("malformed state refinement clause", Clause);
26079 -- Analyze the state name of a refinement clause
26081 State := First (Choices (Clause));
26084 Resolve_State (State);
26086 -- Ensure that the state name denotes a valid abstract state that is
26087 -- defined in the spec of the related package.
26089 if Is_Entity_Name (State) then
26090 State_Id := Entity_Of (State);
26092 -- When the abstract state is undefined, it appears as Any_Id. Do
26093 -- not continue with the analysis of the clause.
26095 if State_Id = Any_Id then
26098 -- Catch any attempts to re-refine a state or refine a state that
26099 -- is not defined in the package declaration.
26101 elsif Ekind (State_Id) = E_Abstract_State then
26105 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
26109 -- References to a state with visible refinement are illegal.
26110 -- When nested packages are involved, detecting such references is
26111 -- tricky because pragma Refined_State is analyzed later than the
26112 -- offending pragma Depends or Global. References that occur in
26113 -- such nested context are stored in a list. Emit errors for all
26114 -- references found in Body_References (SPARK RM 6.1.4(8)).
26116 if Present (Body_References (State_Id)) then
26117 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
26118 while Present (Body_Ref_Elmt) loop
26119 Body_Ref := Node (Body_Ref_Elmt);
26121 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
26122 Error_Msg_Sloc := Sloc (State);
26123 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
26125 Next_Elmt (Body_Ref_Elmt);
26129 -- The state name is illegal. This is a syntax error, always report.
26132 Error_Msg_N ("malformed state name in refinement clause", State);
26136 -- A refinement clause may only refine one state at a time
26138 Extra_State := Next (State);
26140 if Present (Extra_State) then
26142 ("refinement clause cannot cover multiple states", Extra_State);
26145 -- Replicate the Part_Of constituents of the refined state because
26146 -- the algorithm will consume items.
26148 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
26150 -- Analyze all constituents of the refinement. Multiple constituents
26151 -- appear as an aggregate.
26153 Constit := Expression (Clause);
26155 if Nkind (Constit) = N_Aggregate then
26156 if Present (Component_Associations (Constit)) then
26158 ("constituents of refinement clause must appear in "
26159 & "positional form", Constit);
26161 else pragma Assert (Present (Expressions (Constit)));
26162 Constit := First (Expressions (Constit));
26163 while Present (Constit) loop
26164 Analyze_Constituent (Constit);
26169 -- Various forms of a single constituent. Note that these may include
26170 -- malformed constituents.
26173 Analyze_Constituent (Constit);
26176 -- Verify that external constituents do not introduce new external
26177 -- property in the state refinement (SPARK RM 7.2.8(2)).
26179 if Is_External_State (State_Id) then
26180 Check_External_Property
26181 (Prop_Nam => Name_Async_Readers,
26182 Enabled => Async_Readers_Enabled (State_Id),
26183 Constit => AR_Constit);
26185 Check_External_Property
26186 (Prop_Nam => Name_Async_Writers,
26187 Enabled => Async_Writers_Enabled (State_Id),
26188 Constit => AW_Constit);
26190 Check_External_Property
26191 (Prop_Nam => Name_Effective_Reads,
26192 Enabled => Effective_Reads_Enabled (State_Id),
26193 Constit => ER_Constit);
26195 Check_External_Property
26196 (Prop_Nam => Name_Effective_Writes,
26197 Enabled => Effective_Writes_Enabled (State_Id),
26198 Constit => EW_Constit);
26200 -- When a refined state is not external, it should not have external
26201 -- constituents (SPARK RM 7.2.8(1)).
26203 elsif External_Constit_Seen then
26205 ("non-external state & cannot contain external constituents in "
26206 & "refinement", State, State_Id);
26209 -- Ensure that all Part_Of candidate constituents have been mentioned
26210 -- in the refinement clause.
26212 Report_Unused_Constituents (Part_Of_Constits);
26213 end Analyze_Refinement_Clause;
26215 -----------------------------
26216 -- Report_Unrefined_States --
26217 -----------------------------
26219 procedure Report_Unrefined_States (States : Elist_Id) is
26220 State_Elmt : Elmt_Id;
26223 if Present (States) then
26224 State_Elmt := First_Elmt (States);
26225 while Present (State_Elmt) loop
26227 ("abstract state & must be refined", Node (State_Elmt));
26229 Next_Elmt (State_Elmt);
26232 end Report_Unrefined_States;
26234 -- Local declarations
26236 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26239 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26242 -- Do not analyze the pragma multiple times
26244 if Is_Analyzed_Pragma (N) then
26248 -- Replicate the abstract states declared by the package because the
26249 -- matching algorithm will consume states.
26251 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
26253 -- Gather all abstract states and objects declared in the visible
26254 -- state space of the package body. These items must be utilized as
26255 -- constituents in a state refinement.
26257 Body_States := Collect_Body_States (Body_Id);
26259 -- Multiple non-null state refinements appear as an aggregate
26261 if Nkind (Clauses) = N_Aggregate then
26262 if Present (Expressions (Clauses)) then
26264 ("state refinements must appear as component associations",
26267 else pragma Assert (Present (Component_Associations (Clauses)));
26268 Clause := First (Component_Associations (Clauses));
26269 while Present (Clause) loop
26270 Analyze_Refinement_Clause (Clause);
26275 -- Various forms of a single state refinement. Note that these may
26276 -- include malformed refinements.
26279 Analyze_Refinement_Clause (Clauses);
26282 -- List all abstract states that were left unrefined
26284 Report_Unrefined_States (Available_States);
26286 Set_Is_Analyzed_Pragma (N);
26287 end Analyze_Refined_State_In_Decl_Part;
26289 ------------------------------------
26290 -- Analyze_Test_Case_In_Decl_Part --
26291 ------------------------------------
26293 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
26294 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26295 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26297 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
26298 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26299 -- denoted by Arg_Nam.
26301 ------------------------------
26302 -- Preanalyze_Test_Case_Arg --
26303 ------------------------------
26305 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
26309 -- Preanalyze the original aspect argument for ASIS or for a generic
26310 -- subprogram to properly capture global references.
26312 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
26316 Arg_Nam => Arg_Nam,
26317 From_Aspect => True);
26319 if Present (Arg) then
26320 Preanalyze_Assert_Expression
26321 (Expression (Arg), Standard_Boolean);
26325 Arg := Test_Case_Arg (N, Arg_Nam);
26327 if Present (Arg) then
26328 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
26330 end Preanalyze_Test_Case_Arg;
26334 Restore_Scope : Boolean := False;
26336 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26339 -- Do not analyze the pragma multiple times
26341 if Is_Analyzed_Pragma (N) then
26345 -- Ensure that the formal parameters are visible when analyzing all
26346 -- clauses. This falls out of the general rule of aspects pertaining
26347 -- to subprogram declarations.
26349 if not In_Open_Scopes (Spec_Id) then
26350 Restore_Scope := True;
26351 Push_Scope (Spec_Id);
26353 if Is_Generic_Subprogram (Spec_Id) then
26354 Install_Generic_Formals (Spec_Id);
26356 Install_Formals (Spec_Id);
26360 Preanalyze_Test_Case_Arg (Name_Requires);
26361 Preanalyze_Test_Case_Arg (Name_Ensures);
26363 if Restore_Scope then
26367 -- Currently it is not possible to inline pre/postconditions on a
26368 -- subprogram subject to pragma Inline_Always.
26370 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26372 Set_Is_Analyzed_Pragma (N);
26373 end Analyze_Test_Case_In_Decl_Part;
26379 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
26384 if Present (List) then
26385 Elmt := First_Elmt (List);
26386 while Present (Elmt) loop
26387 if Nkind (Node (Elmt)) = N_Defining_Identifier then
26390 Id := Entity_Of (Node (Elmt));
26393 if Id = Item_Id then
26404 ---------------------------------
26405 -- Build_Class_Wide_Expression --
26406 ---------------------------------
26408 procedure Build_Class_Wide_Expression
26411 Par_Subp : Entity_Id;
26412 Adjust_Sloc : Boolean)
26414 function Replace_Entity (N : Node_Id) return Traverse_Result;
26415 -- Replace reference to formal of inherited operation or to primitive
26416 -- operation of root type, with corresponding entity for derived type,
26417 -- when constructing the class-wide condition of an overriding
26420 --------------------
26421 -- Replace_Entity --
26422 --------------------
26424 function Replace_Entity (N : Node_Id) return Traverse_Result is
26428 if Adjust_Sloc then
26429 Adjust_Inherited_Pragma_Sloc (N);
26432 if Nkind (N) = N_Identifier
26433 and then Present (Entity (N))
26435 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
26437 (Nkind (Parent (N)) /= N_Attribute_Reference
26438 or else Attribute_Name (Parent (N)) /= Name_Class)
26440 -- The replacement does not apply to dispatching calls within the
26441 -- condition, but only to calls whose static tag is that of the
26444 if Is_Subprogram (Entity (N))
26445 and then Nkind (Parent (N)) = N_Function_Call
26446 and then Present (Controlling_Argument (Parent (N)))
26451 -- Determine whether entity has a renaming
26453 New_E := Primitives_Mapping.Get (Entity (N));
26455 if Present (New_E) then
26456 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
26459 -- Check that there are no calls left to abstract operations if
26460 -- the current subprogram is not abstract.
26462 if Nkind (Parent (N)) = N_Function_Call
26463 and then N = Name (Parent (N))
26465 if not Is_Abstract_Subprogram (Subp)
26466 and then Is_Abstract_Subprogram (Entity (N))
26468 Error_Msg_Sloc := Sloc (Current_Scope);
26470 ("cannot call abstract subprogram in inherited condition "
26471 & "for&#", N, Current_Scope);
26473 -- In SPARK mode, reject an inherited condition for an
26474 -- inherited operation if it contains a call to an overriding
26475 -- operation, because this implies that the pre/postcondition
26476 -- of the inherited operation have changed silently.
26478 elsif SPARK_Mode = On
26479 and then Warn_On_Suspicious_Contract
26480 and then Present (Alias (Subp))
26481 and then Present (New_E)
26482 and then Comes_From_Source (New_E)
26485 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
26487 Error_Msg_Sloc := Sloc (New_E);
26488 Error_Msg_Node_2 := Subp;
26490 ("\overriding of&# forces overriding of&",
26491 Parent (Subp), New_E);
26495 -- Update type of function call node, which should be the same as
26496 -- the function's return type.
26498 if Is_Subprogram (Entity (N))
26499 and then Nkind (Parent (N)) = N_Function_Call
26501 Set_Etype (Parent (N), Etype (Entity (N)));
26504 -- The whole expression will be reanalyzed
26506 elsif Nkind (N) in N_Has_Etype then
26507 Set_Analyzed (N, False);
26511 end Replace_Entity;
26513 procedure Replace_Condition_Entities is
26514 new Traverse_Proc (Replace_Entity);
26518 Par_Formal : Entity_Id;
26519 Subp_Formal : Entity_Id;
26521 -- Start of processing for Build_Class_Wide_Expression
26524 -- Add mapping from old formals to new formals
26526 Par_Formal := First_Formal (Par_Subp);
26527 Subp_Formal := First_Formal (Subp);
26529 while Present (Par_Formal) and then Present (Subp_Formal) loop
26530 Primitives_Mapping.Set (Par_Formal, Subp_Formal);
26531 Next_Formal (Par_Formal);
26532 Next_Formal (Subp_Formal);
26535 Replace_Condition_Entities (Prag);
26536 end Build_Class_Wide_Expression;
26538 -----------------------------------
26539 -- Build_Pragma_Check_Equivalent --
26540 -----------------------------------
26542 function Build_Pragma_Check_Equivalent
26544 Subp_Id : Entity_Id := Empty;
26545 Inher_Id : Entity_Id := Empty;
26546 Keep_Pragma_Id : Boolean := False) return Node_Id
26548 function Suppress_Reference (N : Node_Id) return Traverse_Result;
26549 -- Detect whether node N references a formal parameter subject to
26550 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26551 -- to False to suppress the generation of a reference when analyzing
26554 ------------------------
26555 -- Suppress_Reference --
26556 ------------------------
26558 function Suppress_Reference (N : Node_Id) return Traverse_Result is
26559 Formal : Entity_Id;
26562 if Is_Entity_Name (N) and then Present (Entity (N)) then
26563 Formal := Entity (N);
26565 -- The formal parameter is subject to pragma Unreferenced. Prevent
26566 -- the generation of references by resetting the Comes_From_Source
26569 if Is_Formal (Formal)
26570 and then Has_Pragma_Unreferenced (Formal)
26572 Set_Comes_From_Source (N, False);
26577 end Suppress_Reference;
26579 procedure Suppress_References is
26580 new Traverse_Proc (Suppress_Reference);
26584 Loc : constant Source_Ptr := Sloc (Prag);
26585 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26586 Check_Prag : Node_Id;
26590 -- Start of processing for Build_Pragma_Check_Equivalent
26593 -- When the pre- or postcondition is inherited, map the formals of the
26594 -- inherited subprogram to those of the current subprogram. In addition,
26595 -- map primitive operations of the parent type into the corresponding
26596 -- primitive operations of the descendant.
26598 if Present (Inher_Id) then
26599 pragma Assert (Present (Subp_Id));
26601 Update_Primitives_Mapping (Inher_Id, Subp_Id);
26603 -- Use generic machinery to copy inherited pragma, as if it were an
26604 -- instantiation, resetting source locations appropriately, so that
26605 -- expressions inside the inherited pragma use chained locations.
26606 -- This is used in particular in GNATprove to locate precisely
26607 -- messages on a given inherited pragma.
26609 Set_Copied_Sloc_For_Inherited_Pragma
26610 (Unit_Declaration_Node (Subp_Id), Inher_Id);
26611 Check_Prag := New_Copy_Tree (Source => Prag);
26613 -- Build the inherited class-wide condition
26615 Build_Class_Wide_Expression
26616 (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True);
26618 -- If not an inherited condition simply copy the original pragma
26621 Check_Prag := New_Copy_Tree (Source => Prag);
26624 -- Mark the pragma as being internally generated and reset the Analyzed
26627 Set_Analyzed (Check_Prag, False);
26628 Set_Comes_From_Source (Check_Prag, False);
26630 -- The tree of the original pragma may contain references to the
26631 -- formal parameters of the related subprogram. At the same time
26632 -- the corresponding body may mark the formals as unreferenced:
26634 -- procedure Proc (Formal : ...)
26635 -- with Pre => Formal ...;
26637 -- procedure Proc (Formal : ...) is
26638 -- pragma Unreferenced (Formal);
26641 -- This creates problems because all pragma Check equivalents are
26642 -- analyzed at the end of the body declarations. Since all source
26643 -- references have already been accounted for, reset any references
26644 -- to such formals in the generated pragma Check equivalent.
26646 Suppress_References (Check_Prag);
26648 if Present (Corresponding_Aspect (Prag)) then
26649 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
26654 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
26655 -- the copied pragma in the newly created pragma, convert the copy into
26656 -- pragma Check by correcting the name and adding a check_kind argument.
26658 if not Keep_Pragma_Id then
26659 Set_Class_Present (Check_Prag, False);
26661 Set_Pragma_Identifier
26662 (Check_Prag, Make_Identifier (Loc, Name_Check));
26664 Prepend_To (Pragma_Argument_Associations (Check_Prag),
26665 Make_Pragma_Argument_Association (Loc,
26666 Expression => Make_Identifier (Loc, Nam)));
26669 -- Update the error message when the pragma is inherited
26671 if Present (Inher_Id) then
26672 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
26674 if Chars (Msg_Arg) = Name_Message then
26675 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
26677 -- Insert "inherited" to improve the error message
26679 if Name_Buffer (1 .. 8) = "failed p" then
26680 Insert_Str_In_Name_Buffer ("inherited ", 8);
26681 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
26687 end Build_Pragma_Check_Equivalent;
26689 -----------------------------
26690 -- Check_Applicable_Policy --
26691 -----------------------------
26693 procedure Check_Applicable_Policy (N : Node_Id) is
26697 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
26700 -- No effect if not valid assertion kind name
26702 if not Is_Valid_Assertion_Kind (Ename) then
26706 -- Loop through entries in check policy list
26708 PP := Opt.Check_Policy_List;
26709 while Present (PP) loop
26711 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26712 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26716 or else Pnm = Name_Assertion
26717 or else (Pnm = Name_Statement_Assertions
26718 and then Nam_In (Ename, Name_Assert,
26719 Name_Assert_And_Cut,
26721 Name_Loop_Invariant,
26722 Name_Loop_Variant))
26724 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
26727 when Name_Off | Name_Ignore =>
26728 Set_Is_Ignored (N, True);
26729 Set_Is_Checked (N, False);
26731 when Name_On | Name_Check =>
26732 Set_Is_Checked (N, True);
26733 Set_Is_Ignored (N, False);
26735 when Name_Disable =>
26736 Set_Is_Ignored (N, True);
26737 Set_Is_Checked (N, False);
26738 Set_Is_Disabled (N, True);
26740 -- That should be exhaustive, the null here is a defence
26741 -- against a malformed tree from previous errors.
26750 PP := Next_Pragma (PP);
26754 -- If there are no specific entries that matched, then we let the
26755 -- setting of assertions govern. Note that this provides the needed
26756 -- compatibility with the RM for the cases of assertion, invariant,
26757 -- precondition, predicate, and postcondition.
26759 if Assertions_Enabled then
26760 Set_Is_Checked (N, True);
26761 Set_Is_Ignored (N, False);
26763 Set_Is_Checked (N, False);
26764 Set_Is_Ignored (N, True);
26766 end Check_Applicable_Policy;
26768 -------------------------------
26769 -- Check_External_Properties --
26770 -------------------------------
26772 procedure Check_External_Properties
26780 -- All properties enabled
26782 if AR and AW and ER and EW then
26785 -- Async_Readers + Effective_Writes
26786 -- Async_Readers + Async_Writers + Effective_Writes
26788 elsif AR and EW and not ER then
26791 -- Async_Writers + Effective_Reads
26792 -- Async_Readers + Async_Writers + Effective_Reads
26794 elsif AW and ER and not EW then
26797 -- Async_Readers + Async_Writers
26799 elsif AR and AW and not ER and not EW then
26804 elsif AR and not AW and not ER and not EW then
26809 elsif AW and not AR and not ER and not EW then
26814 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26817 end Check_External_Properties;
26823 function Check_Kind (Nam : Name_Id) return Name_Id is
26827 -- Loop through entries in check policy list
26829 PP := Opt.Check_Policy_List;
26830 while Present (PP) loop
26832 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26833 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26837 or else (Pnm = Name_Assertion
26838 and then Is_Valid_Assertion_Kind (Nam))
26839 or else (Pnm = Name_Statement_Assertions
26840 and then Nam_In (Nam, Name_Assert,
26841 Name_Assert_And_Cut,
26843 Name_Loop_Invariant,
26844 Name_Loop_Variant))
26846 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26847 when Name_On | Name_Check =>
26849 when Name_Off | Name_Ignore =>
26850 return Name_Ignore;
26851 when Name_Disable =>
26852 return Name_Disable;
26854 raise Program_Error;
26858 PP := Next_Pragma (PP);
26863 -- If there are no specific entries that matched, then we let the
26864 -- setting of assertions govern. Note that this provides the needed
26865 -- compatibility with the RM for the cases of assertion, invariant,
26866 -- precondition, predicate, and postcondition.
26868 if Assertions_Enabled then
26871 return Name_Ignore;
26875 ---------------------------
26876 -- Check_Missing_Part_Of --
26877 ---------------------------
26879 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26880 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26881 -- Determine whether a package denoted by Pack_Id declares at least one
26884 -----------------------
26885 -- Has_Visible_State --
26886 -----------------------
26888 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26889 Item_Id : Entity_Id;
26892 -- Traverse the entity chain of the package trying to find at least
26893 -- one visible abstract state, variable or a package [instantiation]
26894 -- that declares a visible state.
26896 Item_Id := First_Entity (Pack_Id);
26897 while Present (Item_Id)
26898 and then not In_Private_Part (Item_Id)
26900 -- Do not consider internally generated items
26902 if not Comes_From_Source (Item_Id) then
26905 -- A visible state has been found
26907 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26910 -- Recursively peek into nested packages and instantiations
26912 elsif Ekind (Item_Id) = E_Package
26913 and then Has_Visible_State (Item_Id)
26918 Next_Entity (Item_Id);
26922 end Has_Visible_State;
26926 Pack_Id : Entity_Id;
26927 Placement : State_Space_Kind;
26929 -- Start of processing for Check_Missing_Part_Of
26932 -- Do not consider abstract states, variables or package instantiations
26933 -- coming from an instance as those always inherit the Part_Of indicator
26934 -- of the instance itself.
26936 if In_Instance then
26939 -- Do not consider internally generated entities as these can never
26940 -- have a Part_Of indicator.
26942 elsif not Comes_From_Source (Item_Id) then
26945 -- Perform these checks only when SPARK_Mode is enabled as they will
26946 -- interfere with standard Ada rules and produce false positives.
26948 elsif SPARK_Mode /= On then
26951 -- Do not consider constants, because the compiler cannot accurately
26952 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26953 -- act as a hidden state of a package.
26955 elsif Ekind (Item_Id) = E_Constant then
26959 -- Find where the abstract state, variable or package instantiation
26960 -- lives with respect to the state space.
26962 Find_Placement_In_State_Space
26963 (Item_Id => Item_Id,
26964 Placement => Placement,
26965 Pack_Id => Pack_Id);
26967 -- Items that appear in a non-package construct (subprogram, block, etc)
26968 -- do not require a Part_Of indicator because they can never act as a
26971 if Placement = Not_In_Package then
26974 -- An item declared in the body state space of a package always act as a
26975 -- constituent and does not need explicit Part_Of indicator.
26977 elsif Placement = Body_State_Space then
26980 -- In general an item declared in the visible state space of a package
26981 -- does not require a Part_Of indicator. The only exception is when the
26982 -- related package is a private child unit in which case Part_Of must
26983 -- denote a state in the parent unit or in one of its descendants.
26985 elsif Placement = Visible_State_Space then
26986 if Is_Child_Unit (Pack_Id)
26987 and then Is_Private_Descendant (Pack_Id)
26989 -- A package instantiation does not need a Part_Of indicator when
26990 -- the related generic template has no visible state.
26992 if Ekind (Item_Id) = E_Package
26993 and then Is_Generic_Instance (Item_Id)
26994 and then not Has_Visible_State (Item_Id)
26998 -- All other cases require Part_Of
27002 ("indicator Part_Of is required in this context "
27003 & "(SPARK RM 7.2.6(3))", Item_Id);
27004 Error_Msg_Name_1 := Chars (Pack_Id);
27006 ("\& is declared in the visible part of private child "
27007 & "unit %", Item_Id);
27011 -- When the item appears in the private state space of a packge, it must
27012 -- be a part of some state declared by the said package.
27014 else pragma Assert (Placement = Private_State_Space);
27016 -- The related package does not declare a state, the item cannot act
27017 -- as a Part_Of constituent.
27019 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
27022 -- A package instantiation does not need a Part_Of indicator when the
27023 -- related generic template has no visible state.
27025 elsif Ekind (Pack_Id) = E_Package
27026 and then Is_Generic_Instance (Pack_Id)
27027 and then not Has_Visible_State (Pack_Id)
27031 -- All other cases require Part_Of
27035 ("indicator Part_Of is required in this context "
27036 & "(SPARK RM 7.2.6(2))", Item_Id);
27037 Error_Msg_Name_1 := Chars (Pack_Id);
27039 ("\& is declared in the private part of package %", Item_Id);
27042 end Check_Missing_Part_Of;
27044 ---------------------------------------------------
27045 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27046 ---------------------------------------------------
27048 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27050 Spec_Id : Entity_Id)
27053 if Warn_On_Redundant_Constructs
27054 and then Has_Pragma_Inline_Always (Spec_Id)
27056 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27058 if From_Aspect_Specification (Prag) then
27060 ("aspect % not enforced on inlined subprogram &?r?",
27061 Corresponding_Aspect (Prag), Spec_Id);
27064 ("pragma % not enforced on inlined subprogram &?r?",
27068 end Check_Postcondition_Use_In_Inlined_Subprogram;
27070 -------------------------------------
27071 -- Check_State_And_Constituent_Use --
27072 -------------------------------------
27074 procedure Check_State_And_Constituent_Use
27075 (States : Elist_Id;
27076 Constits : Elist_Id;
27079 function Find_Encapsulating_State
27080 (Constit_Id : Entity_Id) return Entity_Id;
27081 -- Given the entity of a constituent, try to find a corresponding
27082 -- encapsulating state that appears in the same context. The routine
27083 -- returns Empty is no such state is found.
27085 ------------------------------
27086 -- Find_Encapsulating_State --
27087 ------------------------------
27089 function Find_Encapsulating_State
27090 (Constit_Id : Entity_Id) return Entity_Id
27092 State_Id : Entity_Id;
27095 -- Since a constituent may be part of a larger constituent set, climb
27096 -- the encapsulating state chain looking for a state that appears in
27097 -- the same context.
27099 State_Id := Encapsulating_State (Constit_Id);
27100 while Present (State_Id) loop
27101 if Contains (States, State_Id) then
27105 State_Id := Encapsulating_State (State_Id);
27109 end Find_Encapsulating_State;
27113 Constit_Elmt : Elmt_Id;
27114 Constit_Id : Entity_Id;
27115 State_Id : Entity_Id;
27117 -- Start of processing for Check_State_And_Constituent_Use
27120 -- Nothing to do if there are no states or constituents
27122 if No (States) or else No (Constits) then
27126 -- Inspect the list of constituents and try to determine whether its
27127 -- encapsulating state is in list States.
27129 Constit_Elmt := First_Elmt (Constits);
27130 while Present (Constit_Elmt) loop
27131 Constit_Id := Node (Constit_Elmt);
27133 -- Determine whether the constituent is part of an encapsulating
27134 -- state that appears in the same context and if this is the case,
27135 -- emit an error (SPARK RM 7.2.6(7)).
27137 State_Id := Find_Encapsulating_State (Constit_Id);
27139 if Present (State_Id) then
27140 Error_Msg_Name_1 := Chars (Constit_Id);
27142 ("cannot mention state & and its constituent % in the same "
27143 & "context", Context, State_Id);
27147 Next_Elmt (Constit_Elmt);
27149 end Check_State_And_Constituent_Use;
27151 ---------------------------------------------
27152 -- Collect_Inherited_Class_Wide_Conditions --
27153 ---------------------------------------------
27155 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27156 Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
27157 Prags : constant Node_Id := Contract (Parent_Subp);
27158 In_Spec_Expr : Boolean;
27159 Installed : Boolean;
27161 New_Prag : Node_Id;
27164 Installed := False;
27166 -- Iterate over the contract of the overridden subprogram to find all
27167 -- inherited class-wide pre- and postconditions.
27169 if Present (Prags) then
27170 Prag := Pre_Post_Conditions (Prags);
27172 while Present (Prag) loop
27173 if Nam_In (Pragma_Name (Prag), Name_Precondition,
27174 Name_Postcondition)
27175 and then Class_Present (Prag)
27177 -- The generated pragma must be analyzed in the context of
27178 -- the subprogram, to make its formals visible. In addition,
27179 -- we must inhibit freezing and full analysis because the
27180 -- controlling type of the subprogram is not frozen yet, and
27181 -- may have further primitives.
27183 if not Installed then
27186 Install_Formals (Subp);
27187 In_Spec_Expr := In_Spec_Expression;
27188 In_Spec_Expression := True;
27192 Build_Pragma_Check_Equivalent
27193 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
27195 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
27196 Preanalyze (New_Prag);
27198 -- Prevent further analysis in subsequent processing of the
27199 -- current list of declarations
27201 Set_Analyzed (New_Prag);
27204 Prag := Next_Pragma (Prag);
27208 In_Spec_Expression := In_Spec_Expr;
27212 end Collect_Inherited_Class_Wide_Conditions;
27214 ---------------------------------------
27215 -- Collect_Subprogram_Inputs_Outputs --
27216 ---------------------------------------
27218 procedure Collect_Subprogram_Inputs_Outputs
27219 (Subp_Id : Entity_Id;
27220 Synthesize : Boolean := False;
27221 Subp_Inputs : in out Elist_Id;
27222 Subp_Outputs : in out Elist_Id;
27223 Global_Seen : out Boolean)
27225 procedure Collect_Dependency_Clause (Clause : Node_Id);
27226 -- Collect all relevant items from a dependency clause
27228 procedure Collect_Global_List
27230 Mode : Name_Id := Name_Input);
27231 -- Collect all relevant items from a global list
27233 -------------------------------
27234 -- Collect_Dependency_Clause --
27235 -------------------------------
27237 procedure Collect_Dependency_Clause (Clause : Node_Id) is
27238 procedure Collect_Dependency_Item
27240 Is_Input : Boolean);
27241 -- Add an item to the proper subprogram input or output collection
27243 -----------------------------
27244 -- Collect_Dependency_Item --
27245 -----------------------------
27247 procedure Collect_Dependency_Item
27249 Is_Input : Boolean)
27254 -- Nothing to collect when the item is null
27256 if Nkind (Item) = N_Null then
27259 -- Ditto for attribute 'Result
27261 elsif Is_Attribute_Result (Item) then
27264 -- Multiple items appear as an aggregate
27266 elsif Nkind (Item) = N_Aggregate then
27267 Extra := First (Expressions (Item));
27268 while Present (Extra) loop
27269 Collect_Dependency_Item (Extra, Is_Input);
27273 -- Otherwise this is a solitary item
27277 Append_New_Elmt (Item, Subp_Inputs);
27279 Append_New_Elmt (Item, Subp_Outputs);
27282 end Collect_Dependency_Item;
27284 -- Start of processing for Collect_Dependency_Clause
27287 if Nkind (Clause) = N_Null then
27290 -- A dependency cause appears as component association
27292 elsif Nkind (Clause) = N_Component_Association then
27293 Collect_Dependency_Item
27294 (Item => Expression (Clause),
27297 Collect_Dependency_Item
27298 (Item => First (Choices (Clause)),
27299 Is_Input => False);
27301 -- To accomodate partial decoration of disabled SPARK features, this
27302 -- routine may be called with illegal input. If this is the case, do
27303 -- not raise Program_Error.
27308 end Collect_Dependency_Clause;
27310 -------------------------
27311 -- Collect_Global_List --
27312 -------------------------
27314 procedure Collect_Global_List
27316 Mode : Name_Id := Name_Input)
27318 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
27319 -- Add an item to the proper subprogram input or output collection
27321 -------------------------
27322 -- Collect_Global_Item --
27323 -------------------------
27325 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
27327 if Nam_In (Mode, Name_In_Out, Name_Input) then
27328 Append_New_Elmt (Item, Subp_Inputs);
27331 if Nam_In (Mode, Name_In_Out, Name_Output) then
27332 Append_New_Elmt (Item, Subp_Outputs);
27334 end Collect_Global_Item;
27341 -- Start of processing for Collect_Global_List
27344 if Nkind (List) = N_Null then
27347 -- Single global item declaration
27349 elsif Nkind_In (List, N_Expanded_Name,
27351 N_Selected_Component)
27353 Collect_Global_Item (List, Mode);
27355 -- Simple global list or moded global list declaration
27357 elsif Nkind (List) = N_Aggregate then
27358 if Present (Expressions (List)) then
27359 Item := First (Expressions (List));
27360 while Present (Item) loop
27361 Collect_Global_Item (Item, Mode);
27366 Assoc := First (Component_Associations (List));
27367 while Present (Assoc) loop
27368 Collect_Global_List
27369 (List => Expression (Assoc),
27370 Mode => Chars (First (Choices (Assoc))));
27375 -- To accomodate partial decoration of disabled SPARK features, this
27376 -- routine may be called with illegal input. If this is the case, do
27377 -- not raise Program_Error.
27382 end Collect_Global_List;
27389 Formal : Entity_Id;
27391 Spec_Id : Entity_Id;
27392 Subp_Decl : Node_Id;
27395 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27398 Global_Seen := False;
27400 -- Process all formal parameters of entries, [generic] subprograms, and
27403 if Ekind_In (Subp_Id, E_Entry,
27406 E_Generic_Function,
27407 E_Generic_Procedure,
27411 Subp_Decl := Unit_Declaration_Node (Subp_Id);
27412 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27414 -- Process all [generic] formal parameters
27416 Formal := First_Entity (Spec_Id);
27417 while Present (Formal) loop
27418 if Ekind_In (Formal, E_Generic_In_Parameter,
27419 E_In_Out_Parameter,
27422 Append_New_Elmt (Formal, Subp_Inputs);
27425 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
27426 E_In_Out_Parameter,
27429 Append_New_Elmt (Formal, Subp_Outputs);
27431 -- Out parameters can act as inputs when the related type is
27432 -- tagged, unconstrained array, unconstrained record, or record
27433 -- with unconstrained components.
27435 if Ekind (Formal) = E_Out_Parameter
27436 and then Is_Unconstrained_Or_Tagged_Item (Formal)
27438 Append_New_Elmt (Formal, Subp_Inputs);
27442 Next_Entity (Formal);
27445 -- Otherwise the input denotes a task type, a task body, or the
27446 -- anonymous object created for a single task type.
27448 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
27449 or else Is_Single_Task_Object (Subp_Id)
27451 Subp_Decl := Declaration_Node (Subp_Id);
27452 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27455 -- When processing an entry, subprogram or task body, look for pragmas
27456 -- Refined_Depends and Refined_Global as they specify the inputs and
27459 if Is_Entry_Body (Subp_Id)
27460 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
27462 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
27463 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
27465 -- Subprogram declaration or stand alone body case, look for pragmas
27466 -- Depends and Global
27469 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27470 Global := Get_Pragma (Spec_Id, Pragma_Global);
27473 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27474 -- because it provides finer granularity of inputs and outputs.
27476 if Present (Global) then
27477 Global_Seen := True;
27478 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
27480 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27481 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27482 -- the inputs and outputs from [Refined_]Depends.
27484 elsif Synthesize and then Present (Depends) then
27485 Clauses := Expression (Get_Argument (Depends, Spec_Id));
27487 -- Multiple dependency clauses appear as an aggregate
27489 if Nkind (Clauses) = N_Aggregate then
27490 Clause := First (Component_Associations (Clauses));
27491 while Present (Clause) loop
27492 Collect_Dependency_Clause (Clause);
27496 -- Otherwise this is a single dependency clause
27499 Collect_Dependency_Clause (Clauses);
27503 -- The current instance of a protected type acts as a formal parameter
27504 -- of mode IN for functions and IN OUT for entries and procedures
27505 -- (SPARK RM 6.1.4).
27507 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
27508 Typ := Scope (Spec_Id);
27510 -- Use the anonymous object when the type is single protected
27512 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27513 Typ := Anonymous_Object (Typ);
27516 Append_New_Elmt (Typ, Subp_Inputs);
27518 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
27519 Append_New_Elmt (Typ, Subp_Outputs);
27522 -- The current instance of a task type acts as a formal parameter of
27523 -- mode IN OUT (SPARK RM 6.1.4).
27525 elsif Ekind (Spec_Id) = E_Task_Type then
27528 -- Use the anonymous object when the type is single task
27530 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27531 Typ := Anonymous_Object (Typ);
27534 Append_New_Elmt (Typ, Subp_Inputs);
27535 Append_New_Elmt (Typ, Subp_Outputs);
27537 elsif Is_Single_Task_Object (Spec_Id) then
27538 Append_New_Elmt (Spec_Id, Subp_Inputs);
27539 Append_New_Elmt (Spec_Id, Subp_Outputs);
27541 end Collect_Subprogram_Inputs_Outputs;
27543 ---------------------------
27544 -- Contract_Freeze_Error --
27545 ---------------------------
27547 procedure Contract_Freeze_Error
27548 (Contract_Id : Entity_Id;
27549 Freeze_Id : Entity_Id)
27552 Error_Msg_Name_1 := Chars (Contract_Id);
27553 Error_Msg_Sloc := Sloc (Freeze_Id);
27556 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
27558 ("\all contractual items must be declared before body #", Contract_Id);
27559 end Contract_Freeze_Error;
27561 ---------------------------------
27562 -- Delay_Config_Pragma_Analyze --
27563 ---------------------------------
27565 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
27567 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
27568 Name_Priority_Specific_Dispatching);
27569 end Delay_Config_Pragma_Analyze;
27571 -----------------------
27572 -- Duplication_Error --
27573 -----------------------
27575 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
27576 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
27577 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
27580 Error_Msg_Sloc := Sloc (Prev);
27581 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27583 -- Emit a precise message to distinguish between source pragmas and
27584 -- pragmas generated from aspects. The ordering of the two pragmas is
27588 -- Prag -- duplicate
27590 -- No error is emitted when both pragmas come from aspects because this
27591 -- is already detected by the general aspect analysis mechanism.
27593 if Prag_From_Asp and Prev_From_Asp then
27595 elsif Prag_From_Asp then
27596 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
27597 elsif Prev_From_Asp then
27598 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
27600 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
27602 end Duplication_Error;
27608 function Entity_Hash (E : Entity_Id) return Num_Primitives is
27610 return Num_Primitives (E mod 511);
27613 --------------------------
27614 -- Find_Related_Context --
27615 --------------------------
27617 function Find_Related_Context
27619 Do_Checks : Boolean := False) return Node_Id
27624 Stmt := Prev (Prag);
27625 while Present (Stmt) loop
27627 -- Skip prior pragmas, but check for duplicates
27629 if Nkind (Stmt) = N_Pragma then
27630 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
27636 -- Skip internally generated code
27638 elsif not Comes_From_Source (Stmt) then
27640 -- The anonymous object created for a single concurrent type is a
27641 -- suitable context.
27643 if Nkind (Stmt) = N_Object_Declaration
27644 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27649 -- Return the current source construct
27659 end Find_Related_Context;
27661 --------------------------------------
27662 -- Find_Related_Declaration_Or_Body --
27663 --------------------------------------
27665 function Find_Related_Declaration_Or_Body
27667 Do_Checks : Boolean := False) return Node_Id
27669 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
27671 procedure Expression_Function_Error;
27672 -- Emit an error concerning pragma Prag that illegaly applies to an
27673 -- expression function.
27675 -------------------------------
27676 -- Expression_Function_Error --
27677 -------------------------------
27679 procedure Expression_Function_Error is
27681 Error_Msg_Name_1 := Prag_Nam;
27683 -- Emit a precise message to distinguish between source pragmas and
27684 -- pragmas generated from aspects.
27686 if From_Aspect_Specification (Prag) then
27688 ("aspect % cannot apply to a stand alone expression function",
27692 ("pragma % cannot apply to a stand alone expression function",
27695 end Expression_Function_Error;
27699 Context : constant Node_Id := Parent (Prag);
27702 Look_For_Body : constant Boolean :=
27703 Nam_In (Prag_Nam, Name_Refined_Depends,
27704 Name_Refined_Global,
27705 Name_Refined_Post);
27706 -- Refinement pragmas must be associated with a subprogram body [stub]
27708 -- Start of processing for Find_Related_Declaration_Or_Body
27711 Stmt := Prev (Prag);
27712 while Present (Stmt) loop
27714 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27715 -- by splitting a complex pre/postcondition are not considered to
27718 if Nkind (Stmt) = N_Pragma then
27720 and then not Split_PPC (Stmt)
27721 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
27728 -- Emit an error when a refinement pragma appears on an expression
27729 -- function without a completion.
27732 and then Look_For_Body
27733 and then Nkind (Stmt) = N_Subprogram_Declaration
27734 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
27735 and then not Has_Completion (Defining_Entity (Stmt))
27737 Expression_Function_Error;
27740 -- The refinement pragma applies to a subprogram body stub
27742 elsif Look_For_Body
27743 and then Nkind (Stmt) = N_Subprogram_Body_Stub
27747 -- Skip internally generated code
27749 elsif not Comes_From_Source (Stmt) then
27751 -- The anonymous object created for a single concurrent type is a
27752 -- suitable context.
27754 if Nkind (Stmt) = N_Object_Declaration
27755 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27759 elsif Nkind (Stmt) = N_Subprogram_Declaration then
27761 -- The subprogram declaration is an internally generated spec
27762 -- for an expression function.
27764 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27767 -- The subprogram is actually an instance housed within an
27768 -- anonymous wrapper package.
27770 elsif Present (Generic_Parent (Specification (Stmt))) then
27775 -- Return the current construct which is either a subprogram body,
27776 -- a subprogram declaration or is illegal.
27785 -- If we fall through, then the pragma was either the first declaration
27786 -- or it was preceded by other pragmas and no source constructs.
27788 -- The pragma is associated with a library-level subprogram
27790 if Nkind (Context) = N_Compilation_Unit_Aux then
27791 return Unit (Parent (Context));
27793 -- The pragma appears inside the declarations of an entry body
27795 elsif Nkind (Context) = N_Entry_Body then
27798 -- The pragma appears inside the statements of a subprogram body. This
27799 -- placement is the result of subprogram contract expansion.
27801 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
27802 return Parent (Context);
27804 -- The pragma appears inside the declarative part of a subprogram body
27806 elsif Nkind (Context) = N_Subprogram_Body then
27809 -- The pragma appears inside the declarative part of a task body
27811 elsif Nkind (Context) = N_Task_Body then
27814 -- The pragma is a byproduct of aspect expansion, return the related
27815 -- context of the original aspect. This case has a lower priority as
27816 -- the above circuitry pinpoints precisely the related context.
27818 elsif Present (Corresponding_Aspect (Prag)) then
27819 return Parent (Corresponding_Aspect (Prag));
27821 -- No candidate subprogram [body] found
27826 end Find_Related_Declaration_Or_Body;
27828 ----------------------------------
27829 -- Find_Related_Package_Or_Body --
27830 ----------------------------------
27832 function Find_Related_Package_Or_Body
27834 Do_Checks : Boolean := False) return Node_Id
27836 Context : constant Node_Id := Parent (Prag);
27837 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27841 Stmt := Prev (Prag);
27842 while Present (Stmt) loop
27844 -- Skip prior pragmas, but check for duplicates
27846 if Nkind (Stmt) = N_Pragma then
27847 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
27853 -- Skip internally generated code
27855 elsif not Comes_From_Source (Stmt) then
27856 if Nkind (Stmt) = N_Subprogram_Declaration then
27858 -- The subprogram declaration is an internally generated spec
27859 -- for an expression function.
27861 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27864 -- The subprogram is actually an instance housed within an
27865 -- anonymous wrapper package.
27867 elsif Present (Generic_Parent (Specification (Stmt))) then
27872 -- Return the current source construct which is illegal
27881 -- If we fall through, then the pragma was either the first declaration
27882 -- or it was preceded by other pragmas and no source constructs.
27884 -- The pragma is associated with a package. The immediate context in
27885 -- this case is the specification of the package.
27887 if Nkind (Context) = N_Package_Specification then
27888 return Parent (Context);
27890 -- The pragma appears in the declarations of a package body
27892 elsif Nkind (Context) = N_Package_Body then
27895 -- The pragma appears in the statements of a package body
27897 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
27898 and then Nkind (Parent (Context)) = N_Package_Body
27900 return Parent (Context);
27902 -- The pragma is a byproduct of aspect expansion, return the related
27903 -- context of the original aspect. This case has a lower priority as
27904 -- the above circuitry pinpoints precisely the related context.
27906 elsif Present (Corresponding_Aspect (Prag)) then
27907 return Parent (Corresponding_Aspect (Prag));
27909 -- No candidate packge [body] found
27914 end Find_Related_Package_Or_Body;
27920 function Get_Argument
27922 Context_Id : Entity_Id := Empty) return Node_Id
27924 Args : constant List_Id := Pragma_Argument_Associations (Prag);
27927 -- Use the expression of the original aspect when compiling for ASIS or
27928 -- when analyzing the template of a generic unit. In both cases the
27929 -- aspect's tree must be decorated to allow for ASIS queries or to save
27930 -- the global references in the generic context.
27932 if From_Aspect_Specification (Prag)
27933 and then (ASIS_Mode or else (Present (Context_Id)
27934 and then Is_Generic_Unit (Context_Id)))
27936 return Corresponding_Aspect (Prag);
27938 -- Otherwise use the expression of the pragma
27940 elsif Present (Args) then
27941 return First (Args);
27948 -------------------------
27949 -- Get_Base_Subprogram --
27950 -------------------------
27952 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27953 Result : Entity_Id;
27956 -- Follow subprogram renaming chain
27960 if Is_Subprogram (Result)
27962 Nkind (Parent (Declaration_Node (Result))) =
27963 N_Subprogram_Renaming_Declaration
27964 and then Present (Alias (Result))
27966 Result := Alias (Result);
27970 end Get_Base_Subprogram;
27972 -----------------------
27973 -- Get_SPARK_Mode_Type --
27974 -----------------------
27976 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27978 if N = Name_On then
27980 elsif N = Name_Off then
27983 -- Any other argument is illegal
27986 raise Program_Error;
27988 end Get_SPARK_Mode_Type;
27990 ------------------------------------
27991 -- Get_SPARK_Mode_From_Annotation --
27992 ------------------------------------
27994 function Get_SPARK_Mode_From_Annotation
27995 (N : Node_Id) return SPARK_Mode_Type
28000 if Nkind (N) = N_Aspect_Specification then
28001 Mode := Expression (N);
28003 else pragma Assert (Nkind (N) = N_Pragma);
28004 Mode := First (Pragma_Argument_Associations (N));
28006 if Present (Mode) then
28007 Mode := Get_Pragma_Arg (Mode);
28011 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28013 if Present (Mode) then
28014 if Nkind (Mode) = N_Identifier then
28015 return Get_SPARK_Mode_Type (Chars (Mode));
28017 -- In case of a malformed aspect or pragma, return the default None
28023 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28028 end Get_SPARK_Mode_From_Annotation;
28030 ---------------------------
28031 -- Has_Extra_Parentheses --
28032 ---------------------------
28034 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28038 -- The aggregate should not have an expression list because a clause
28039 -- is always interpreted as a component association. The only way an
28040 -- expression list can sneak in is by adding extra parentheses around
28041 -- the individual clauses:
28043 -- Depends (Output => Input) -- proper form
28044 -- Depends ((Output => Input)) -- extra parentheses
28046 -- Since the extra parentheses are not allowed by the syntax of the
28047 -- pragma, flag them now to avoid emitting misleading errors down the
28050 if Nkind (Clause) = N_Aggregate
28051 and then Present (Expressions (Clause))
28053 Expr := First (Expressions (Clause));
28054 while Present (Expr) loop
28056 -- A dependency clause surrounded by extra parentheses appears
28057 -- as an aggregate of component associations with an optional
28058 -- Paren_Count set.
28060 if Nkind (Expr) = N_Aggregate
28061 and then Present (Component_Associations (Expr))
28064 ("dependency clause contains extra parentheses", Expr);
28066 -- Otherwise the expression is a malformed construct
28069 SPARK_Msg_N ("malformed dependency clause", Expr);
28079 end Has_Extra_Parentheses;
28085 procedure Initialize is
28096 Dummy := Dummy + 1;
28099 -----------------------------
28100 -- Is_Config_Static_String --
28101 -----------------------------
28103 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28105 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28106 -- This is an internal recursive function that is just like the outer
28107 -- function except that it adds the string to the name buffer rather
28108 -- than placing the string in the name buffer.
28110 ------------------------------
28111 -- Add_Config_Static_String --
28112 ------------------------------
28114 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28121 if Nkind (N) = N_Op_Concat then
28122 if Add_Config_Static_String (Left_Opnd (N)) then
28123 N := Right_Opnd (N);
28129 if Nkind (N) /= N_String_Literal then
28130 Error_Msg_N ("string literal expected for pragma argument", N);
28134 for J in 1 .. String_Length (Strval (N)) loop
28135 C := Get_String_Char (Strval (N), J);
28137 if not In_Character_Range (C) then
28139 ("string literal contains invalid wide character",
28140 Sloc (N) + 1 + Source_Ptr (J));
28144 Add_Char_To_Name_Buffer (Get_Character (C));
28149 end Add_Config_Static_String;
28151 -- Start of processing for Is_Config_Static_String
28156 return Add_Config_Static_String (Arg);
28157 end Is_Config_Static_String;
28159 ---------------------
28160 -- Is_CCT_Instance --
28161 ---------------------
28163 function Is_CCT_Instance
28164 (Ref_Id : Entity_Id;
28165 Context_Id : Entity_Id) return Boolean
28171 -- When the reference denotes a single protected type, the context is
28172 -- either a protected subprogram or its body.
28174 if Is_Single_Protected_Object (Ref_Id) then
28175 Typ := Scope (Context_Id);
28178 Ekind (Typ) = E_Protected_Type
28179 and then Present (Anonymous_Object (Typ))
28180 and then Anonymous_Object (Typ) = Ref_Id;
28182 -- When the reference denotes a single task type, the context is either
28183 -- the same type or if inside the body, the anonymous task type.
28185 elsif Is_Single_Task_Object (Ref_Id) then
28186 if Ekind (Context_Id) = E_Task_Type then
28188 Present (Anonymous_Object (Context_Id))
28189 and then Anonymous_Object (Context_Id) = Ref_Id;
28191 return Ref_Id = Context_Id;
28194 -- Otherwise the reference denotes a protected or a task type. Climb the
28195 -- scope chain looking for an enclosing concurrent type that matches the
28196 -- referenced entity.
28199 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
28201 S := Current_Scope;
28202 while Present (S) and then S /= Standard_Standard loop
28203 if Ekind_In (S, E_Protected_Type, E_Task_Type)
28204 and then S = Ref_Id
28214 end Is_CCT_Instance;
28216 -------------------------------
28217 -- Is_Elaboration_SPARK_Mode --
28218 -------------------------------
28220 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
28223 (Nkind (N) = N_Pragma
28224 and then Pragma_Name (N) = Name_SPARK_Mode
28225 and then Is_List_Member (N));
28227 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28228 -- appears in the statement part of the body.
28231 Present (Parent (N))
28232 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
28233 and then List_Containing (N) = Statements (Parent (N))
28234 and then Present (Parent (Parent (N)))
28235 and then Nkind (Parent (Parent (N))) = N_Package_Body;
28236 end Is_Elaboration_SPARK_Mode;
28238 -----------------------
28239 -- Is_Enabled_Pragma --
28240 -----------------------
28242 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
28246 if Present (Prag) then
28247 Arg := First (Pragma_Argument_Associations (Prag));
28249 if Present (Arg) then
28250 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
28252 -- The lack of a Boolean argument automatically enables the pragma
28258 -- The pragma is missing, therefore it is not enabled
28263 end Is_Enabled_Pragma;
28265 -----------------------------------------
28266 -- Is_Non_Significant_Pragma_Reference --
28267 -----------------------------------------
28269 -- This function makes use of the following static table which indicates
28270 -- whether appearance of some name in a given pragma is to be considered
28271 -- as a reference for the purposes of warnings about unreferenced objects.
28273 -- -1 indicates that appearence in any argument is significant
28274 -- 0 indicates that appearance in any argument is not significant
28275 -- +n indicates that appearance as argument n is significant, but all
28276 -- other arguments are not significant
28277 -- 9n arguments from n on are significant, before n insignificant
28279 Sig_Flags : constant array (Pragma_Id) of Int :=
28280 (Pragma_Abort_Defer => -1,
28281 Pragma_Abstract_State => -1,
28282 Pragma_Ada_83 => -1,
28283 Pragma_Ada_95 => -1,
28284 Pragma_Ada_05 => -1,
28285 Pragma_Ada_2005 => -1,
28286 Pragma_Ada_12 => -1,
28287 Pragma_Ada_2012 => -1,
28288 Pragma_All_Calls_Remote => -1,
28289 Pragma_Allow_Integer_Address => -1,
28290 Pragma_Annotate => 93,
28291 Pragma_Assert => -1,
28292 Pragma_Assert_And_Cut => -1,
28293 Pragma_Assertion_Policy => 0,
28294 Pragma_Assume => -1,
28295 Pragma_Assume_No_Invalid_Values => 0,
28296 Pragma_Async_Readers => 0,
28297 Pragma_Async_Writers => 0,
28298 Pragma_Asynchronous => 0,
28299 Pragma_Atomic => 0,
28300 Pragma_Atomic_Components => 0,
28301 Pragma_Attach_Handler => -1,
28302 Pragma_Attribute_Definition => 92,
28303 Pragma_Check => -1,
28304 Pragma_Check_Float_Overflow => 0,
28305 Pragma_Check_Name => 0,
28306 Pragma_Check_Policy => 0,
28307 Pragma_CPP_Class => 0,
28308 Pragma_CPP_Constructor => 0,
28309 Pragma_CPP_Virtual => 0,
28310 Pragma_CPP_Vtable => 0,
28312 Pragma_C_Pass_By_Copy => 0,
28313 Pragma_Comment => -1,
28314 Pragma_Common_Object => 0,
28315 Pragma_Compile_Time_Error => -1,
28316 Pragma_Compile_Time_Warning => -1,
28317 Pragma_Compiler_Unit => -1,
28318 Pragma_Compiler_Unit_Warning => -1,
28319 Pragma_Complete_Representation => 0,
28320 Pragma_Complex_Representation => 0,
28321 Pragma_Component_Alignment => 0,
28322 Pragma_Constant_After_Elaboration => 0,
28323 Pragma_Contract_Cases => -1,
28324 Pragma_Controlled => 0,
28325 Pragma_Convention => 0,
28326 Pragma_Convention_Identifier => 0,
28327 Pragma_Debug => -1,
28328 Pragma_Debug_Policy => 0,
28329 Pragma_Detect_Blocking => 0,
28330 Pragma_Default_Initial_Condition => -1,
28331 Pragma_Default_Scalar_Storage_Order => 0,
28332 Pragma_Default_Storage_Pool => 0,
28333 Pragma_Depends => -1,
28334 Pragma_Disable_Atomic_Synchronization => 0,
28335 Pragma_Discard_Names => 0,
28336 Pragma_Dispatching_Domain => -1,
28337 Pragma_Effective_Reads => 0,
28338 Pragma_Effective_Writes => 0,
28339 Pragma_Elaborate => 0,
28340 Pragma_Elaborate_All => 0,
28341 Pragma_Elaborate_Body => 0,
28342 Pragma_Elaboration_Checks => 0,
28343 Pragma_Eliminate => 0,
28344 Pragma_Enable_Atomic_Synchronization => 0,
28345 Pragma_Export => -1,
28346 Pragma_Export_Function => -1,
28347 Pragma_Export_Object => -1,
28348 Pragma_Export_Procedure => -1,
28349 Pragma_Export_Value => -1,
28350 Pragma_Export_Valued_Procedure => -1,
28351 Pragma_Extend_System => -1,
28352 Pragma_Extensions_Allowed => 0,
28353 Pragma_Extensions_Visible => 0,
28354 Pragma_External => -1,
28355 Pragma_Favor_Top_Level => 0,
28356 Pragma_External_Name_Casing => 0,
28357 Pragma_Fast_Math => 0,
28358 Pragma_Finalize_Storage_Only => 0,
28360 Pragma_Global => -1,
28361 Pragma_Ident => -1,
28362 Pragma_Ignore_Pragma => 0,
28363 Pragma_Implementation_Defined => -1,
28364 Pragma_Implemented => -1,
28365 Pragma_Implicit_Packing => 0,
28366 Pragma_Import => 93,
28367 Pragma_Import_Function => 0,
28368 Pragma_Import_Object => 0,
28369 Pragma_Import_Procedure => 0,
28370 Pragma_Import_Valued_Procedure => 0,
28371 Pragma_Independent => 0,
28372 Pragma_Independent_Components => 0,
28373 Pragma_Initial_Condition => -1,
28374 Pragma_Initialize_Scalars => 0,
28375 Pragma_Initializes => -1,
28376 Pragma_Inline => 0,
28377 Pragma_Inline_Always => 0,
28378 Pragma_Inline_Generic => 0,
28379 Pragma_Inspection_Point => -1,
28380 Pragma_Interface => 92,
28381 Pragma_Interface_Name => 0,
28382 Pragma_Interrupt_Handler => -1,
28383 Pragma_Interrupt_Priority => -1,
28384 Pragma_Interrupt_State => -1,
28385 Pragma_Invariant => -1,
28386 Pragma_Keep_Names => 0,
28387 Pragma_License => 0,
28388 Pragma_Link_With => -1,
28389 Pragma_Linker_Alias => -1,
28390 Pragma_Linker_Constructor => -1,
28391 Pragma_Linker_Destructor => -1,
28392 Pragma_Linker_Options => -1,
28393 Pragma_Linker_Section => 0,
28395 Pragma_Lock_Free => 0,
28396 Pragma_Locking_Policy => 0,
28397 Pragma_Loop_Invariant => -1,
28398 Pragma_Loop_Optimize => 0,
28399 Pragma_Loop_Variant => -1,
28400 Pragma_Machine_Attribute => -1,
28402 Pragma_Main_Storage => -1,
28403 Pragma_Memory_Size => 0,
28404 Pragma_No_Return => 0,
28405 Pragma_No_Body => 0,
28406 Pragma_No_Elaboration_Code_All => 0,
28407 Pragma_No_Inline => 0,
28408 Pragma_No_Run_Time => -1,
28409 Pragma_No_Strict_Aliasing => -1,
28410 Pragma_No_Tagged_Streams => 0,
28411 Pragma_Normalize_Scalars => 0,
28412 Pragma_Obsolescent => 0,
28413 Pragma_Optimize => 0,
28414 Pragma_Optimize_Alignment => 0,
28415 Pragma_Overflow_Mode => 0,
28416 Pragma_Overriding_Renamings => 0,
28417 Pragma_Ordered => 0,
28420 Pragma_Part_Of => 0,
28421 Pragma_Partition_Elaboration_Policy => 0,
28422 Pragma_Passive => 0,
28423 Pragma_Persistent_BSS => 0,
28424 Pragma_Polling => 0,
28425 Pragma_Prefix_Exception_Messages => 0,
28427 Pragma_Postcondition => -1,
28428 Pragma_Post_Class => -1,
28430 Pragma_Precondition => -1,
28431 Pragma_Predicate => -1,
28432 Pragma_Predicate_Failure => -1,
28433 Pragma_Preelaborable_Initialization => -1,
28434 Pragma_Preelaborate => 0,
28435 Pragma_Pre_Class => -1,
28436 Pragma_Priority => -1,
28437 Pragma_Priority_Specific_Dispatching => 0,
28438 Pragma_Profile => 0,
28439 Pragma_Profile_Warnings => 0,
28440 Pragma_Propagate_Exceptions => 0,
28441 Pragma_Provide_Shift_Operators => 0,
28442 Pragma_Psect_Object => 0,
28444 Pragma_Pure_Function => 0,
28445 Pragma_Queuing_Policy => 0,
28446 Pragma_Rational => 0,
28447 Pragma_Ravenscar => 0,
28448 Pragma_Refined_Depends => -1,
28449 Pragma_Refined_Global => -1,
28450 Pragma_Refined_Post => -1,
28451 Pragma_Refined_State => -1,
28452 Pragma_Relative_Deadline => 0,
28453 Pragma_Remote_Access_Type => -1,
28454 Pragma_Remote_Call_Interface => -1,
28455 Pragma_Remote_Types => -1,
28456 Pragma_Restricted_Run_Time => 0,
28457 Pragma_Restriction_Warnings => 0,
28458 Pragma_Restrictions => 0,
28459 Pragma_Reviewable => -1,
28460 Pragma_Short_Circuit_And_Or => 0,
28461 Pragma_Share_Generic => 0,
28462 Pragma_Shared => 0,
28463 Pragma_Shared_Passive => 0,
28464 Pragma_Short_Descriptors => 0,
28465 Pragma_Simple_Storage_Pool_Type => 0,
28466 Pragma_Source_File_Name => 0,
28467 Pragma_Source_File_Name_Project => 0,
28468 Pragma_Source_Reference => 0,
28469 Pragma_SPARK_Mode => 0,
28470 Pragma_Storage_Size => -1,
28471 Pragma_Storage_Unit => 0,
28472 Pragma_Static_Elaboration_Desired => 0,
28473 Pragma_Stream_Convert => 0,
28474 Pragma_Style_Checks => 0,
28475 Pragma_Subtitle => 0,
28476 Pragma_Suppress => 0,
28477 Pragma_Suppress_Exception_Locations => 0,
28478 Pragma_Suppress_All => 0,
28479 Pragma_Suppress_Debug_Info => 0,
28480 Pragma_Suppress_Initialization => 0,
28481 Pragma_System_Name => 0,
28482 Pragma_Task_Dispatching_Policy => 0,
28483 Pragma_Task_Info => -1,
28484 Pragma_Task_Name => -1,
28485 Pragma_Task_Storage => -1,
28486 Pragma_Test_Case => -1,
28487 Pragma_Thread_Local_Storage => -1,
28488 Pragma_Time_Slice => -1,
28490 Pragma_Type_Invariant => -1,
28491 Pragma_Type_Invariant_Class => -1,
28492 Pragma_Unchecked_Union => 0,
28493 Pragma_Unevaluated_Use_Of_Old => 0,
28494 Pragma_Unimplemented_Unit => 0,
28495 Pragma_Universal_Aliasing => 0,
28496 Pragma_Universal_Data => 0,
28497 Pragma_Unmodified => 0,
28498 Pragma_Unreferenced => 0,
28499 Pragma_Unreferenced_Objects => 0,
28500 Pragma_Unreserve_All_Interrupts => 0,
28501 Pragma_Unsuppress => 0,
28502 Pragma_Unused => 0,
28503 Pragma_Use_VADS_Size => 0,
28504 Pragma_Validity_Checks => 0,
28505 Pragma_Volatile => 0,
28506 Pragma_Volatile_Components => 0,
28507 Pragma_Volatile_Full_Access => 0,
28508 Pragma_Volatile_Function => 0,
28509 Pragma_Warning_As_Error => 0,
28510 Pragma_Warnings => 0,
28511 Pragma_Weak_External => 0,
28512 Pragma_Wide_Character_Encoding => 0,
28513 Unknown_Pragma => 0);
28515 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
28521 function Arg_No return Nat;
28522 -- Returns an integer showing what argument we are in. A value of
28523 -- zero means we are not in any of the arguments.
28529 function Arg_No return Nat is
28534 A := First (Pragma_Argument_Associations (Parent (P)));
28548 -- Start of processing for Non_Significant_Pragma_Reference
28553 if Nkind (P) /= N_Pragma_Argument_Association then
28557 Id := Get_Pragma_Id (Parent (P));
28558 C := Sig_Flags (Id);
28573 return AN < (C - 90);
28579 end Is_Non_Significant_Pragma_Reference;
28581 ------------------------------
28582 -- Is_Pragma_String_Literal --
28583 ------------------------------
28585 -- This function returns true if the corresponding pragma argument is a
28586 -- static string expression. These are the only cases in which string
28587 -- literals can appear as pragma arguments. We also allow a string literal
28588 -- as the first argument to pragma Assert (although it will of course
28589 -- always generate a type error).
28591 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
28592 Pragn : constant Node_Id := Parent (Par);
28593 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
28594 Pname : constant Name_Id := Pragma_Name (Pragn);
28600 N := First (Assoc);
28607 if Pname = Name_Assert then
28610 elsif Pname = Name_Export then
28613 elsif Pname = Name_Ident then
28616 elsif Pname = Name_Import then
28619 elsif Pname = Name_Interface_Name then
28622 elsif Pname = Name_Linker_Alias then
28625 elsif Pname = Name_Linker_Section then
28628 elsif Pname = Name_Machine_Attribute then
28631 elsif Pname = Name_Source_File_Name then
28634 elsif Pname = Name_Source_Reference then
28637 elsif Pname = Name_Title then
28640 elsif Pname = Name_Subtitle then
28646 end Is_Pragma_String_Literal;
28648 ---------------------------
28649 -- Is_Private_SPARK_Mode --
28650 ---------------------------
28652 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
28655 (Nkind (N) = N_Pragma
28656 and then Pragma_Name (N) = Name_SPARK_Mode
28657 and then Is_List_Member (N));
28659 -- For pragma SPARK_Mode to be private, it has to appear in the private
28660 -- declarations of a package.
28663 Present (Parent (N))
28664 and then Nkind (Parent (N)) = N_Package_Specification
28665 and then List_Containing (N) = Private_Declarations (Parent (N));
28666 end Is_Private_SPARK_Mode;
28668 -------------------------------------
28669 -- Is_Unconstrained_Or_Tagged_Item --
28670 -------------------------------------
28672 function Is_Unconstrained_Or_Tagged_Item
28673 (Item : Entity_Id) return Boolean
28675 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
28676 -- Determine whether record type Typ has at least one unconstrained
28679 ---------------------------------
28680 -- Has_Unconstrained_Component --
28681 ---------------------------------
28683 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
28687 Comp := First_Component (Typ);
28688 while Present (Comp) loop
28689 if Is_Unconstrained_Or_Tagged_Item (Comp) then
28693 Next_Component (Comp);
28697 end Has_Unconstrained_Component;
28701 Typ : constant Entity_Id := Etype (Item);
28703 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28706 if Is_Tagged_Type (Typ) then
28709 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
28712 elsif Is_Record_Type (Typ) then
28713 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
28716 return Has_Unconstrained_Component (Typ);
28719 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
28725 end Is_Unconstrained_Or_Tagged_Item;
28727 -----------------------------
28728 -- Is_Valid_Assertion_Kind --
28729 -----------------------------
28731 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
28738 Name_Assertion_Policy |
28739 Name_Static_Predicate |
28740 Name_Dynamic_Predicate |
28745 Name_Type_Invariant |
28746 Name_uType_Invariant |
28750 Name_Assert_And_Cut |
28752 Name_Contract_Cases |
28754 Name_Default_Initial_Condition |
28756 Name_Initial_Condition |
28759 Name_Loop_Invariant |
28760 Name_Loop_Variant |
28761 Name_Postcondition |
28762 Name_Precondition |
28764 Name_Refined_Post |
28765 Name_Statement_Assertions => return True;
28767 when others => return False;
28769 end Is_Valid_Assertion_Kind;
28771 --------------------------------------
28772 -- Process_Compilation_Unit_Pragmas --
28773 --------------------------------------
28775 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
28777 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28778 -- strange because it comes at the end of the unit. Rational has the
28779 -- same name for a pragma, but treats it as a program unit pragma, In
28780 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28781 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28782 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28783 -- the context clause to ensure the correct processing.
28785 if Has_Pragma_Suppress_All (N) then
28786 Prepend_To (Context_Items (N),
28787 Make_Pragma (Sloc (N),
28788 Chars => Name_Suppress,
28789 Pragma_Argument_Associations => New_List (
28790 Make_Pragma_Argument_Association (Sloc (N),
28791 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
28794 -- Nothing else to do at the current time
28796 end Process_Compilation_Unit_Pragmas;
28798 ------------------------------------
28799 -- Record_Possible_Body_Reference --
28800 ------------------------------------
28802 procedure Record_Possible_Body_Reference
28803 (State_Id : Entity_Id;
28807 Spec_Id : Entity_Id;
28810 -- Ensure that we are dealing with a reference to a state
28812 pragma Assert (Ekind (State_Id) = E_Abstract_State);
28814 -- Climb the tree starting from the reference looking for a package body
28815 -- whose spec declares the referenced state. This criteria automatically
28816 -- excludes references in package specs which are legal. Note that it is
28817 -- not wise to emit an error now as the package body may lack pragma
28818 -- Refined_State or the referenced state may not be mentioned in the
28819 -- refinement. This approach avoids the generation of misleading errors.
28822 while Present (Context) loop
28823 if Nkind (Context) = N_Package_Body then
28824 Spec_Id := Corresponding_Spec (Context);
28826 if Present (Abstract_States (Spec_Id))
28827 and then Contains (Abstract_States (Spec_Id), State_Id)
28829 if No (Body_References (State_Id)) then
28830 Set_Body_References (State_Id, New_Elmt_List);
28833 Append_Elmt (Ref, To => Body_References (State_Id));
28838 Context := Parent (Context);
28840 end Record_Possible_Body_Reference;
28842 ------------------------------------------
28843 -- Relocate_Pragmas_To_Anonymous_Object --
28844 ------------------------------------------
28846 procedure Relocate_Pragmas_To_Anonymous_Object
28847 (Typ_Decl : Node_Id;
28848 Obj_Decl : Node_Id)
28852 Next_Decl : Node_Id;
28855 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
28856 Def := Protected_Definition (Typ_Decl);
28858 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
28859 Def := Task_Definition (Typ_Decl);
28862 -- The concurrent definition has a visible declaration list. Inspect it
28863 -- and relocate all canidate pragmas.
28865 if Present (Def) and then Present (Visible_Declarations (Def)) then
28866 Decl := First (Visible_Declarations (Def));
28867 while Present (Decl) loop
28869 -- Preserve the following declaration for iteration purposes due
28870 -- to possible relocation of a pragma.
28872 Next_Decl := Next (Decl);
28874 if Nkind (Decl) = N_Pragma
28875 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
28878 Insert_After (Obj_Decl, Decl);
28880 -- Skip internally generated code
28882 elsif not Comes_From_Source (Decl) then
28885 -- No candidate pragmas are available for relocation
28894 end Relocate_Pragmas_To_Anonymous_Object;
28896 ------------------------------
28897 -- Relocate_Pragmas_To_Body --
28898 ------------------------------
28900 procedure Relocate_Pragmas_To_Body
28901 (Subp_Body : Node_Id;
28902 Target_Body : Node_Id := Empty)
28904 procedure Relocate_Pragma (Prag : Node_Id);
28905 -- Remove a single pragma from its current list and add it to the
28906 -- declarations of the proper body (either Subp_Body or Target_Body).
28908 ---------------------
28909 -- Relocate_Pragma --
28910 ---------------------
28912 procedure Relocate_Pragma (Prag : Node_Id) is
28917 -- When subprogram stubs or expression functions are involves, the
28918 -- destination declaration list belongs to the proper body.
28920 if Present (Target_Body) then
28921 Target := Target_Body;
28923 Target := Subp_Body;
28926 Decls := Declarations (Target);
28930 Set_Declarations (Target, Decls);
28933 -- Unhook the pragma from its current list
28936 Prepend (Prag, Decls);
28937 end Relocate_Pragma;
28941 Body_Id : constant Entity_Id :=
28942 Defining_Unit_Name (Specification (Subp_Body));
28943 Next_Stmt : Node_Id;
28946 -- Start of processing for Relocate_Pragmas_To_Body
28949 -- Do not process a body that comes from a separate unit as no construct
28950 -- can possibly follow it.
28952 if not Is_List_Member (Subp_Body) then
28955 -- Do not relocate pragmas that follow a stub if the stub does not have
28958 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
28959 and then No (Target_Body)
28963 -- Do not process internally generated routine _Postconditions
28965 elsif Ekind (Body_Id) = E_Procedure
28966 and then Chars (Body_Id) = Name_uPostconditions
28971 -- Look at what is following the body. We are interested in certain kind
28972 -- of pragmas (either from source or byproducts of expansion) that can
28973 -- apply to a body [stub].
28975 Stmt := Next (Subp_Body);
28976 while Present (Stmt) loop
28978 -- Preserve the following statement for iteration purposes due to a
28979 -- possible relocation of a pragma.
28981 Next_Stmt := Next (Stmt);
28983 -- Move a candidate pragma following the body to the declarations of
28986 if Nkind (Stmt) = N_Pragma
28987 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28989 Relocate_Pragma (Stmt);
28991 -- Skip internally generated code
28993 elsif not Comes_From_Source (Stmt) then
28996 -- No candidate pragmas are available for relocation
29004 end Relocate_Pragmas_To_Body;
29006 -------------------
29007 -- Resolve_State --
29008 -------------------
29010 procedure Resolve_State (N : Node_Id) is
29015 if Is_Entity_Name (N) and then Present (Entity (N)) then
29016 Func := Entity (N);
29018 -- Handle overloading of state names by functions. Traverse the
29019 -- homonym chain looking for an abstract state.
29021 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
29022 State := Homonym (Func);
29023 while Present (State) loop
29025 -- Resolve the overloading by setting the proper entity of the
29026 -- reference to that of the state.
29028 if Ekind (State) = E_Abstract_State then
29029 Set_Etype (N, Standard_Void_Type);
29030 Set_Entity (N, State);
29031 Set_Associated_Node (N, State);
29035 State := Homonym (State);
29038 -- A function can never act as a state. If the homonym chain does
29039 -- not contain a corresponding state, then something went wrong in
29040 -- the overloading mechanism.
29042 raise Program_Error;
29047 ----------------------------
29048 -- Rewrite_Assertion_Kind --
29049 ----------------------------
29051 procedure Rewrite_Assertion_Kind (N : Node_Id) is
29055 if Nkind (N) = N_Attribute_Reference
29056 and then Attribute_Name (N) = Name_Class
29057 and then Nkind (Prefix (N)) = N_Identifier
29059 case Chars (Prefix (N)) is
29064 when Name_Type_Invariant =>
29065 Nam := Name_uType_Invariant;
29066 when Name_Invariant =>
29067 Nam := Name_uInvariant;
29072 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
29074 end Rewrite_Assertion_Kind;
29082 Dummy := Dummy + 1;
29085 --------------------------------
29086 -- Set_Encoded_Interface_Name --
29087 --------------------------------
29089 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
29090 Str : constant String_Id := Strval (S);
29091 Len : constant Nat := String_Length (Str);
29096 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
29099 -- Stores encoded value of character code CC. The encoding we use an
29100 -- underscore followed by four lower case hex digits.
29106 procedure Encode is
29108 Store_String_Char (Get_Char_Code ('_'));
29110 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
29112 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
29114 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
29116 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
29119 -- Start of processing for Set_Encoded_Interface_Name
29122 -- If first character is asterisk, this is a link name, and we leave it
29123 -- completely unmodified. We also ignore null strings (the latter case
29124 -- happens only in error cases).
29127 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
29129 Set_Interface_Name (E, S);
29134 CC := Get_String_Char (Str, J);
29136 exit when not In_Character_Range (CC);
29138 C := Get_Character (CC);
29140 exit when C /= '_' and then C /= '$'
29141 and then C not in '0' .. '9'
29142 and then C not in 'a' .. 'z'
29143 and then C not in 'A' .. 'Z';
29146 Set_Interface_Name (E, S);
29154 -- Here we need to encode. The encoding we use as follows:
29155 -- three underscores + four hex digits (lower case)
29159 for J in 1 .. String_Length (Str) loop
29160 CC := Get_String_Char (Str, J);
29162 if not In_Character_Range (CC) then
29165 C := Get_Character (CC);
29167 if C = '_' or else C = '$'
29168 or else C in '0' .. '9'
29169 or else C in 'a' .. 'z'
29170 or else C in 'A' .. 'Z'
29172 Store_String_Char (CC);
29179 Set_Interface_Name (E,
29180 Make_String_Literal (Sloc (S),
29181 Strval => End_String));
29183 end Set_Encoded_Interface_Name;
29185 ------------------------
29186 -- Set_Elab_Unit_Name --
29187 ------------------------
29189 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
29194 if Nkind (N) = N_Identifier
29195 and then Nkind (With_Item) = N_Identifier
29197 Set_Entity (N, Entity (With_Item));
29199 elsif Nkind (N) = N_Selected_Component then
29200 Change_Selected_Component_To_Expanded_Name (N);
29201 Set_Entity (N, Entity (With_Item));
29202 Set_Entity (Selector_Name (N), Entity (N));
29204 Pref := Prefix (N);
29205 Scop := Scope (Entity (N));
29206 while Nkind (Pref) = N_Selected_Component loop
29207 Change_Selected_Component_To_Expanded_Name (Pref);
29208 Set_Entity (Selector_Name (Pref), Scop);
29209 Set_Entity (Pref, Scop);
29210 Pref := Prefix (Pref);
29211 Scop := Scope (Scop);
29214 Set_Entity (Pref, Scop);
29217 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
29218 end Set_Elab_Unit_Name;
29220 -------------------
29221 -- Test_Case_Arg --
29222 -------------------
29224 function Test_Case_Arg
29227 From_Aspect : Boolean := False) return Node_Id
29229 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
29234 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
29239 -- The caller requests the aspect argument
29241 if From_Aspect then
29242 if Present (Aspect)
29243 and then Nkind (Expression (Aspect)) = N_Aggregate
29245 Args := Expression (Aspect);
29247 -- "Name" and "Mode" may appear without an identifier as a
29248 -- positional association.
29250 if Present (Expressions (Args)) then
29251 Arg := First (Expressions (Args));
29253 if Present (Arg) and then Arg_Nam = Name_Name then
29261 if Present (Arg) and then Arg_Nam = Name_Mode then
29266 -- Some or all arguments may appear as component associatons
29268 if Present (Component_Associations (Args)) then
29269 Arg := First (Component_Associations (Args));
29270 while Present (Arg) loop
29271 if Chars (First (Choices (Arg))) = Arg_Nam then
29280 -- Otherwise retrieve the argument directly from the pragma
29283 Arg := First (Pragma_Argument_Associations (Prag));
29285 if Present (Arg) and then Arg_Nam = Name_Name then
29289 -- Skip argument "Name"
29293 if Present (Arg) and then Arg_Nam = Name_Mode then
29297 -- Skip argument "Mode"
29301 -- Arguments "Requires" and "Ensures" are optional and may not be
29304 while Present (Arg) loop
29305 if Chars (Arg) = Arg_Nam then
29316 -------------------------------
29317 -- Update_Primitives_Mapping --
29318 -------------------------------
29320 procedure Update_Primitives_Mapping
29321 (Inher_Id : Entity_Id;
29322 Subp_Id : Entity_Id)
29324 function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
29325 -- Locate the primitive operation with the name of S whose controlling
29326 -- type is the dispatching type of Inher_Id.
29328 -------------------------
29329 -- Overridden_Ancestor --
29330 -------------------------
29332 function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
29333 Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
29339 -- Locate the ancestor subprogram with the proper controlling type
29341 while Present (Overridden_Operation (Anc)) loop
29342 Anc := Overridden_Operation (Anc);
29343 exit when Find_Dispatching_Type (Anc) = Par;
29347 end Overridden_Ancestor;
29351 Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
29352 Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
29354 Old_Elmt : Elmt_Id;
29355 Old_Prim : Entity_Id;
29358 -- Start of processing for Update_Primitives_Mapping
29361 -- If the types are already in the map, it has been previously built for
29362 -- some other overriding primitive.
29364 if Primitives_Mapping.Get (Old_Typ) = Typ then
29368 -- Initialize new mapping with the primitive operations
29370 Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
29372 -- Look for primitive operations of the current type that have
29373 -- overridden an operation of the type related to the original
29374 -- class-wide precondition. There may be several intermediate
29375 -- overridings between them.
29377 while Present (Decl) loop
29378 if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
29379 N_Subprogram_Declaration)
29381 Prim := Defining_Entity (Decl);
29383 if Is_Subprogram (Prim)
29384 and then Present (Overridden_Operation (Prim))
29385 and then Find_Dispatching_Type (Prim) = Typ
29387 Old_Prim := Overridden_Ancestor (Prim);
29389 Primitives_Mapping.Set (Old_Prim, Prim);
29396 -- Now examine inherited operations. these do not override, but have
29397 -- an alias, which is the entity used in a call. That alias may be
29398 -- inherited or come from source, in which case it may override an
29399 -- earlier operation. We only need to examine inherited functions,
29400 -- that can appear within the inherited expression.
29402 Prim := First_Entity (Scope (Subp_Id));
29403 while Present (Prim) loop
29404 if not Comes_From_Source (Prim)
29405 and then Ekind (Prim) = E_Function
29406 and then Present (Alias (Prim))
29408 Old_Prim := Alias (Prim);
29410 if Comes_From_Source (Old_Prim) then
29411 Old_Prim := Overridden_Ancestor (Old_Prim);
29414 while Present (Alias (Old_Prim))
29415 and then Scope (Old_Prim) /= Scope (Inher_Id)
29417 Old_Prim := Alias (Old_Prim);
29419 if Comes_From_Source (Old_Prim) then
29420 Old_Prim := Overridden_Ancestor (Old_Prim);
29426 Primitives_Mapping.Set (Old_Prim, Prim);
29429 Next_Entity (Prim);
29432 -- If the parent operation is an interface operation, the overriding
29433 -- indicator is not present. Instead, we get from the interface
29434 -- operation the primitive of the current type that implements it.
29436 if Is_Interface (Old_Typ) then
29437 Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
29438 while Present (Old_Elmt) loop
29439 Old_Prim := Node (Old_Elmt);
29440 Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
29442 if Present (Prim) then
29443 Primitives_Mapping.Set (Old_Prim, Prim);
29446 Next_Elmt (Old_Elmt);
29451 -- Map the types themselves, so that the process is not repeated for
29452 -- other overriding primitives.
29454 Primitives_Mapping.Set (Old_Typ, Typ);
29455 end Update_Primitives_Mapping;