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;
48 with Lib.Writ; use Lib.Writ;
49 with Lib.Xref; use Lib.Xref;
50 with Namet.Sp; use Namet.Sp;
51 with Nlists; use Nlists;
52 with Nmake; use Nmake;
53 with Output; use Output;
54 with Par_SCO; use Par_SCO;
55 with Restrict; use Restrict;
56 with Rident; use Rident;
57 with Rtsfind; use Rtsfind;
59 with Sem_Aux; use Sem_Aux;
60 with Sem_Ch3; use Sem_Ch3;
61 with Sem_Ch6; use Sem_Ch6;
62 with Sem_Ch8; use Sem_Ch8;
63 with Sem_Ch12; use Sem_Ch12;
64 with Sem_Ch13; use Sem_Ch13;
65 with Sem_Disp; use Sem_Disp;
66 with Sem_Dist; use Sem_Dist;
67 with Sem_Elim; use Sem_Elim;
68 with Sem_Eval; use Sem_Eval;
69 with Sem_Intr; use Sem_Intr;
70 with Sem_Mech; use Sem_Mech;
71 with Sem_Res; use Sem_Res;
72 with Sem_Type; use Sem_Type;
73 with Sem_Util; use Sem_Util;
74 with Sem_Warn; use Sem_Warn;
75 with Stand; use Stand;
76 with Sinfo; use Sinfo;
77 with Sinfo.CN; use Sinfo.CN;
78 with Sinput; use Sinput;
79 with Stringt; use Stringt;
80 with Stylesw; use Stylesw;
82 with Targparm; use Targparm;
83 with Tbuild; use Tbuild;
85 with Uintp; use Uintp;
86 with Uname; use Uname;
87 with Urealp; use Urealp;
88 with Validsw; use Validsw;
89 with Warnsw; use Warnsw;
91 package body Sem_Prag is
93 ----------------------------------------------
94 -- Common Handling of Import-Export Pragmas --
95 ----------------------------------------------
97 -- In the following section, a number of Import_xxx and Export_xxx pragmas
98 -- are defined by GNAT. These are compatible with the DEC pragmas of the
99 -- same name, and all have the following common form and processing:
102 -- [Internal =>] LOCAL_NAME
103 -- [, [External =>] EXTERNAL_SYMBOL]
104 -- [, other optional parameters ]);
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
111 -- EXTERNAL_SYMBOL ::=
113 -- | static_string_EXPRESSION
115 -- The internal LOCAL_NAME designates the entity that is imported or
116 -- exported, and must refer to an entity in the current declarative
117 -- part (as required by the rules for LOCAL_NAME).
119 -- The external linker name is designated by the External parameter if
120 -- given, or the Internal parameter if not (if there is no External
121 -- parameter, the External parameter is a copy of the Internal name).
123 -- If the External parameter is given as a string, then this string is
124 -- treated as an external name (exactly as though it had been given as an
125 -- External_Name parameter for a normal Import pragma).
127 -- If the External parameter is given as an identifier (or there is no
128 -- External parameter, so that the Internal identifier is used), then
129 -- the external name is the characters of the identifier, translated
130 -- to all lower case letters.
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals is new Table.Table (
159 Table_Component_Type => Node_Id,
160 Table_Index_Type => Int,
161 Table_Low_Bound => 0,
162 Table_Initial => 100,
163 Table_Increment => 100,
164 Table_Name => "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
171 -- This routine is used for possible casing adjustment of an explicit
172 -- external name supplied as a string literal (the node N), according to
173 -- the casing requirement of Opt.External_Name_Casing. If this is set to
174 -- As_Is, then the string literal is returned unchanged, but if it is set
175 -- to Uppercase or Lowercase, then a new string literal with appropriate
176 -- casing is constructed.
178 procedure Analyze_Part_Of
182 Encap_Id : out Entity_Id;
183 Legal : out Boolean);
184 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
185 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
186 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
187 -- package instantiation. Encap denotes the encapsulating state or single
188 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
189 -- the indicator is legal.
191 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
192 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
193 -- Query whether a particular item appears in a mixed list of nodes and
194 -- entities. It is assumed that all nodes in the list have entities.
196 procedure Check_Postcondition_Use_In_Inlined_Subprogram
198 Spec_Id : Entity_Id);
199 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
200 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
201 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
203 procedure Check_State_And_Constituent_Use
207 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
208 -- Global and Initializes. Determine whether a state from list States and a
209 -- corresponding constituent from list Constits (if any) appear in the same
210 -- context denoted by Context. If this is the case, emit an error.
212 procedure Contract_Freeze_Error
213 (Contract_Id : Entity_Id;
214 Freeze_Id : Entity_Id);
215 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
216 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
217 -- of a body which caused contract "freezing" and Contract_Id denotes the
218 -- entity of the affected contstruct.
220 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
221 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
222 -- Prag that duplicates previous pragma Prev.
224 function Find_Related_Context
226 Do_Checks : Boolean := False) return Node_Id;
227 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
228 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
229 -- Part_Of. Find the first source declaration or statement found while
230 -- traversing the previous node chain starting from pragma Prag. If flag
231 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
232 -- returns Empty when reaching the start of the node chain.
234 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
235 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
236 -- original one, following the renaming chain) is returned. Otherwise the
237 -- entity is returned unchanged. Should be in Einfo???
239 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
240 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
241 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
242 -- value of type SPARK_Mode_Type.
244 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
245 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
246 -- Determine whether dependency clause Clause is surrounded by extra
247 -- parentheses. If this is the case, issue an error message.
249 function Is_CCT_Instance
251 Context_Id : Entity_Id) return Boolean;
252 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
253 -- Global. Determine whether entity Ref_Id denotes the current instance of
254 -- a concurrent type. Context_Id denotes the associated context where the
257 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
258 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
259 -- pragma Depends. Determine whether the type of dependency item Item is
260 -- tagged, unconstrained array, unconstrained record or a record with at
261 -- least one unconstrained component.
263 procedure Record_Possible_Body_Reference
264 (State_Id : Entity_Id;
266 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
267 -- Global. Given an abstract state denoted by State_Id and a reference Ref
268 -- to it, determine whether the reference appears in a package body that
269 -- will eventually refine the state. If this is the case, record the
270 -- reference for future checks (see Analyze_Refined_State_In_Decls).
272 procedure Resolve_State (N : Node_Id);
273 -- Handle the overloading of state names by functions. When N denotes a
274 -- function, this routine finds the corresponding state and sets the entity
275 -- of N to that of the state.
277 procedure Rewrite_Assertion_Kind (N : Node_Id);
278 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
279 -- then it is rewritten as an identifier with the corresponding special
280 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
283 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
284 -- Place semantic information on the argument of an Elaborate/Elaborate_All
285 -- pragma. Entity name for unit and its parents is taken from item in
286 -- previous with_clause that mentions the unit.
288 Dummy : Integer := 0;
289 pragma Volatile (Dummy);
290 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
293 pragma No_Inline (ip);
294 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
295 -- is just to help debugging the front end. If a pragma Inspection_Point
296 -- is added to a source program, then breaking on ip will get you to that
297 -- point in the program.
300 pragma No_Inline (rv);
301 -- This is a dummy function called by the processing for pragma Reviewable.
302 -- It is there for assisting front end debugging. By placing a Reviewable
303 -- pragma in the source program, a breakpoint on rv catches this place in
304 -- the source, allowing convenient stepping to the point of interest.
306 -------------------------------
307 -- Adjust_External_Name_Case --
308 -------------------------------
310 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
314 -- Adjust case of literal if required
316 if Opt.External_Name_Exp_Casing = As_Is then
320 -- Copy existing string
326 for J in 1 .. String_Length (Strval (N)) loop
327 CC := Get_String_Char (Strval (N), J);
329 if Opt.External_Name_Exp_Casing = Uppercase
330 and then CC >= Get_Char_Code ('a')
331 and then CC <= Get_Char_Code ('z')
333 Store_String_Char (CC - 32);
335 elsif Opt.External_Name_Exp_Casing = Lowercase
336 and then CC >= Get_Char_Code ('A')
337 and then CC <= Get_Char_Code ('Z')
339 Store_String_Char (CC + 32);
342 Store_String_Char (CC);
347 Make_String_Literal (Sloc (N),
348 Strval => End_String);
350 end Adjust_External_Name_Case;
352 -----------------------------------------
353 -- Analyze_Contract_Cases_In_Decl_Part --
354 -----------------------------------------
356 procedure Analyze_Contract_Cases_In_Decl_Part
358 Freeze_Id : Entity_Id := Empty)
360 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
361 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
363 Others_Seen : Boolean := False;
364 -- This flag is set when an "others" choice is encountered. It is used
365 -- to detect multiple illegal occurrences of "others".
367 procedure Analyze_Contract_Case (CCase : Node_Id);
368 -- Verify the legality of a single contract case
370 ---------------------------
371 -- Analyze_Contract_Case --
372 ---------------------------
374 procedure Analyze_Contract_Case (CCase : Node_Id) is
375 Case_Guard : Node_Id;
378 Extra_Guard : Node_Id;
381 if Nkind (CCase) = N_Component_Association then
382 Case_Guard := First (Choices (CCase));
383 Conseq := Expression (CCase);
385 -- Each contract case must have exactly one case guard
387 Extra_Guard := Next (Case_Guard);
389 if Present (Extra_Guard) then
391 ("contract case must have exactly one case guard",
395 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
397 if Nkind (Case_Guard) = N_Others_Choice then
400 ("only one others choice allowed in contract cases",
406 elsif Others_Seen then
408 ("others must be the last choice in contract cases", N);
411 -- Preanalyze the case guard and consequence
413 if Nkind (Case_Guard) /= N_Others_Choice then
414 Errors := Serious_Errors_Detected;
415 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
417 -- Emit a clarification message when the case guard contains
418 -- at least one undefined reference, possibly due to contract
421 if Errors /= Serious_Errors_Detected
422 and then Present (Freeze_Id)
423 and then Has_Undefined_Reference (Case_Guard)
425 Contract_Freeze_Error (Spec_Id, Freeze_Id);
429 Errors := Serious_Errors_Detected;
430 Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
432 -- Emit a clarification message when the consequence contains
433 -- at least one undefined reference, possibly due to contract
436 if Errors /= Serious_Errors_Detected
437 and then Present (Freeze_Id)
438 and then Has_Undefined_Reference (Conseq)
440 Contract_Freeze_Error (Spec_Id, Freeze_Id);
443 -- The contract case is malformed
446 Error_Msg_N ("wrong syntax in contract case", CCase);
448 end Analyze_Contract_Case;
452 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
454 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
457 Restore_Scope : Boolean := False;
459 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
462 -- Do not analyze the pragma multiple times
464 if Is_Analyzed_Pragma (N) then
468 -- Set the Ghost mode in effect from the pragma. Due to the delayed
469 -- analysis of the pragma, the Ghost mode at point of declaration and
470 -- point of analysis may not necessarily be the same. Use the mode in
471 -- effect at the point of declaration.
475 -- Single and multiple contract cases must appear in aggregate form. If
476 -- this is not the case, then either the parser of the analysis of the
477 -- pragma failed to produce an aggregate.
479 pragma Assert (Nkind (CCases) = N_Aggregate);
481 if Present (Component_Associations (CCases)) then
483 -- Ensure that the formal parameters are visible when analyzing all
484 -- clauses. This falls out of the general rule of aspects pertaining
485 -- to subprogram declarations.
487 if not In_Open_Scopes (Spec_Id) then
488 Restore_Scope := True;
489 Push_Scope (Spec_Id);
491 if Is_Generic_Subprogram (Spec_Id) then
492 Install_Generic_Formals (Spec_Id);
494 Install_Formals (Spec_Id);
498 CCase := First (Component_Associations (CCases));
499 while Present (CCase) loop
500 Analyze_Contract_Case (CCase);
504 if Restore_Scope then
508 -- Currently it is not possible to inline pre/postconditions on a
509 -- subprogram subject to pragma Inline_Always.
511 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
513 -- Otherwise the pragma is illegal
516 Error_Msg_N ("wrong syntax for constract cases", N);
519 Ghost_Mode := Save_Ghost_Mode;
520 Set_Is_Analyzed_Pragma (N);
521 end Analyze_Contract_Cases_In_Decl_Part;
523 ----------------------------------
524 -- Analyze_Depends_In_Decl_Part --
525 ----------------------------------
527 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
528 Loc : constant Source_Ptr := Sloc (N);
529 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
530 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
532 All_Inputs_Seen : Elist_Id := No_Elist;
533 -- A list containing the entities of all the inputs processed so far.
534 -- The list is populated with unique entities because the same input
535 -- may appear in multiple input lists.
537 All_Outputs_Seen : Elist_Id := No_Elist;
538 -- A list containing the entities of all the outputs processed so far.
539 -- The list is populated with unique entities because output items are
540 -- unique in a dependence relation.
542 Constits_Seen : Elist_Id := No_Elist;
543 -- A list containing the entities of all constituents processed so far.
544 -- It aids in detecting illegal usage of a state and a corresponding
545 -- constituent in pragma [Refinde_]Depends.
547 Global_Seen : Boolean := False;
548 -- A flag set when pragma Global has been processed
550 Null_Output_Seen : Boolean := False;
551 -- A flag used to track the legality of a null output
553 Result_Seen : Boolean := False;
554 -- A flag set when Spec_Id'Result is processed
556 States_Seen : Elist_Id := No_Elist;
557 -- A list containing the entities of all states processed so far. It
558 -- helps in detecting illegal usage of a state and a corresponding
559 -- constituent in pragma [Refined_]Depends.
561 Subp_Inputs : Elist_Id := No_Elist;
562 Subp_Outputs : Elist_Id := No_Elist;
563 -- Two lists containing the full set of inputs and output of the related
564 -- subprograms. Note that these lists contain both nodes and entities.
566 Task_Input_Seen : Boolean := False;
567 Task_Output_Seen : Boolean := False;
568 -- Flags used to track the implicit dependence of a task unit on itself
570 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
571 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
572 -- to the name buffer. The individual kinds are as follows:
573 -- E_Abstract_State - "state"
574 -- E_Constant - "constant"
575 -- E_Discriminant - "discriminant"
576 -- E_Generic_In_Out_Parameter - "generic parameter"
577 -- E_Generic_In_Parameter - "generic parameter"
578 -- E_In_Parameter - "parameter"
579 -- E_In_Out_Parameter - "parameter"
580 -- E_Loop_Parameter - "loop parameter"
581 -- E_Out_Parameter - "parameter"
582 -- E_Protected_Type - "current instance of protected type"
583 -- E_Task_Type - "current instance of task type"
584 -- E_Variable - "global"
586 procedure Analyze_Dependency_Clause
589 -- Verify the legality of a single dependency clause. Flag Is_Last
590 -- denotes whether Clause is the last clause in the relation.
592 procedure Check_Function_Return;
593 -- Verify that Funtion'Result appears as one of the outputs
594 -- (SPARK RM 6.1.5(10)).
601 -- Ensure that an item fulfills its designated input and/or output role
602 -- as specified by pragma Global (if any) or the enclosing context. If
603 -- this is not the case, emit an error. Item and Item_Id denote the
604 -- attributes of an item. Flag Is_Input should be set when item comes
605 -- from an input list. Flag Self_Ref should be set when the item is an
606 -- output and the dependency clause has operator "+".
608 procedure Check_Usage
609 (Subp_Items : Elist_Id;
610 Used_Items : Elist_Id;
612 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
613 -- error if this is not the case.
615 procedure Normalize_Clause (Clause : Node_Id);
616 -- Remove a self-dependency "+" from the input list of a clause
618 -----------------------------
619 -- Add_Item_To_Name_Buffer --
620 -----------------------------
622 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
624 if Ekind (Item_Id) = E_Abstract_State then
625 Add_Str_To_Name_Buffer ("state");
627 elsif Ekind (Item_Id) = E_Constant then
628 Add_Str_To_Name_Buffer ("constant");
630 elsif Ekind (Item_Id) = E_Discriminant then
631 Add_Str_To_Name_Buffer ("discriminant");
633 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
634 E_Generic_In_Parameter)
636 Add_Str_To_Name_Buffer ("generic parameter");
638 elsif Is_Formal (Item_Id) then
639 Add_Str_To_Name_Buffer ("parameter");
641 elsif Ekind (Item_Id) = E_Loop_Parameter then
642 Add_Str_To_Name_Buffer ("loop parameter");
644 elsif Ekind (Item_Id) = E_Protected_Type
645 or else Is_Single_Protected_Object (Item_Id)
647 Add_Str_To_Name_Buffer ("current instance of protected type");
649 elsif Ekind (Item_Id) = E_Task_Type
650 or else Is_Single_Task_Object (Item_Id)
652 Add_Str_To_Name_Buffer ("current instance of task type");
654 elsif Ekind (Item_Id) = E_Variable then
655 Add_Str_To_Name_Buffer ("global");
657 -- The routine should not be called with non-SPARK items
662 end Add_Item_To_Name_Buffer;
664 -------------------------------
665 -- Analyze_Dependency_Clause --
666 -------------------------------
668 procedure Analyze_Dependency_Clause
672 procedure Analyze_Input_List (Inputs : Node_Id);
673 -- Verify the legality of a single input list
675 procedure Analyze_Input_Output
680 Seen : in out Elist_Id;
681 Null_Seen : in out Boolean;
682 Non_Null_Seen : in out Boolean);
683 -- Verify the legality of a single input or output item. Flag
684 -- Is_Input should be set whenever Item is an input, False when it
685 -- denotes an output. Flag Self_Ref should be set when the item is an
686 -- output and the dependency clause has a "+". Flag Top_Level should
687 -- be set whenever Item appears immediately within an input or output
688 -- list. Seen is a collection of all abstract states, objects and
689 -- formals processed so far. Flag Null_Seen denotes whether a null
690 -- input or output has been encountered. Flag Non_Null_Seen denotes
691 -- whether a non-null input or output has been encountered.
693 ------------------------
694 -- Analyze_Input_List --
695 ------------------------
697 procedure Analyze_Input_List (Inputs : Node_Id) is
698 Inputs_Seen : Elist_Id := No_Elist;
699 -- A list containing the entities of all inputs that appear in the
700 -- current input list.
702 Non_Null_Input_Seen : Boolean := False;
703 Null_Input_Seen : Boolean := False;
704 -- Flags used to check the legality of an input list
709 -- Multiple inputs appear as an aggregate
711 if Nkind (Inputs) = N_Aggregate then
712 if Present (Component_Associations (Inputs)) then
714 ("nested dependency relations not allowed", Inputs);
716 elsif Present (Expressions (Inputs)) then
717 Input := First (Expressions (Inputs));
718 while Present (Input) loop
725 Null_Seen => Null_Input_Seen,
726 Non_Null_Seen => Non_Null_Input_Seen);
731 -- Syntax error, always report
734 Error_Msg_N ("malformed input dependency list", Inputs);
737 -- Process a solitary input
746 Null_Seen => Null_Input_Seen,
747 Non_Null_Seen => Non_Null_Input_Seen);
750 -- Detect an illegal dependency clause of the form
754 if Null_Output_Seen and then Null_Input_Seen then
756 ("null dependency clause cannot have a null input list",
759 end Analyze_Input_List;
761 --------------------------
762 -- Analyze_Input_Output --
763 --------------------------
765 procedure Analyze_Input_Output
770 Seen : in out Elist_Id;
771 Null_Seen : in out Boolean;
772 Non_Null_Seen : in out Boolean)
774 procedure Current_Task_Instance_Seen;
775 -- Set the appropriate global flag when the current instance of a
776 -- task unit is encountered.
778 --------------------------------
779 -- Current_Task_Instance_Seen --
780 --------------------------------
782 procedure Current_Task_Instance_Seen is
785 Task_Input_Seen := True;
787 Task_Output_Seen := True;
789 end Current_Task_Instance_Seen;
793 Is_Output : constant Boolean := not Is_Input;
797 -- Start of processing for Analyze_Input_Output
800 -- Multiple input or output items appear as an aggregate
802 if Nkind (Item) = N_Aggregate then
803 if not Top_Level then
804 SPARK_Msg_N ("nested grouping of items not allowed", Item);
806 elsif Present (Component_Associations (Item)) then
808 ("nested dependency relations not allowed", Item);
810 -- Recursively analyze the grouped items
812 elsif Present (Expressions (Item)) then
813 Grouped := First (Expressions (Item));
814 while Present (Grouped) loop
817 Is_Input => Is_Input,
818 Self_Ref => Self_Ref,
821 Null_Seen => Null_Seen,
822 Non_Null_Seen => Non_Null_Seen);
827 -- Syntax error, always report
830 Error_Msg_N ("malformed dependency list", Item);
833 -- Process attribute 'Result in the context of a dependency clause
835 elsif Is_Attribute_Result (Item) then
836 Non_Null_Seen := True;
840 -- Attribute 'Result is allowed to appear on the output side of
841 -- a dependency clause (SPARK RM 6.1.5(6)).
844 SPARK_Msg_N ("function result cannot act as input", Item);
848 ("cannot mix null and non-null dependency items", Item);
854 -- Detect multiple uses of null in a single dependency list or
855 -- throughout the whole relation. Verify the placement of a null
856 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
858 elsif Nkind (Item) = N_Null then
861 ("multiple null dependency relations not allowed", Item);
863 elsif Non_Null_Seen then
865 ("cannot mix null and non-null dependency items", Item);
873 ("null output list must be the last clause in a "
874 & "dependency relation", Item);
876 -- Catch a useless dependence of the form:
881 ("useless dependence, null depends on itself", Item);
889 Non_Null_Seen := True;
892 SPARK_Msg_N ("cannot mix null and non-null items", Item);
896 Resolve_State (Item);
898 -- Find the entity of the item. If this is a renaming, climb
899 -- the renaming chain to reach the root object. Renamings of
900 -- non-entire objects do not yield an entity (Empty).
902 Item_Id := Entity_Of (Item);
904 if Present (Item_Id) then
908 if Ekind_In (Item_Id, E_Constant,
913 -- Current instances of concurrent types
915 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
920 Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
921 E_Generic_In_Parameter,
929 Ekind_In (Item_Id, E_Abstract_State, E_Variable)
931 -- The item denotes a concurrent type. Note that single
932 -- protected/task types are not considered here because
933 -- they behave as objects in the context of pragma
934 -- [Refined_]Depends.
936 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
938 -- This use is legal as long as the concurrent type is
939 -- the current instance of an enclosing type.
941 if Is_CCT_Instance (Item_Id, Spec_Id) then
943 -- The dependence of a task unit on itself is
944 -- implicit and may or may not be explicitly
945 -- specified (SPARK RM 6.1.4).
947 if Ekind (Item_Id) = E_Task_Type then
948 Current_Task_Instance_Seen;
951 -- Otherwise this is not the current instance
955 ("invalid use of subtype mark in dependency "
959 -- The dependency of a task unit on itself is implicit
960 -- and may or may not be explicitly specified
963 elsif Is_Single_Task_Object (Item_Id)
964 and then Is_CCT_Instance (Item_Id, Spec_Id)
966 Current_Task_Instance_Seen;
969 -- Ensure that the item fulfills its role as input and/or
970 -- output as specified by pragma Global or the enclosing
973 Check_Role (Item, Item_Id, Is_Input, Self_Ref);
975 -- Detect multiple uses of the same state, variable or
976 -- formal parameter. If this is not the case, add the
977 -- item to the list of processed relations.
979 if Contains (Seen, Item_Id) then
981 ("duplicate use of item &", Item, Item_Id);
983 Append_New_Elmt (Item_Id, Seen);
986 -- Detect illegal use of an input related to a null
987 -- output. Such input items cannot appear in other
988 -- input lists (SPARK RM 6.1.5(13)).
991 and then Null_Output_Seen
992 and then Contains (All_Inputs_Seen, Item_Id)
995 ("input of a null output list cannot appear in "
996 & "multiple input lists", Item);
999 -- Add an input or a self-referential output to the list
1000 -- of all processed inputs.
1002 if Is_Input or else Self_Ref then
1003 Append_New_Elmt (Item_Id, All_Inputs_Seen);
1006 -- State related checks (SPARK RM 6.1.5(3))
1008 if Ekind (Item_Id) = E_Abstract_State then
1010 -- Package and subprogram bodies are instantiated
1011 -- individually in a separate compiler pass. Due to
1012 -- this mode of instantiation, the refinement of a
1013 -- state may no longer be visible when a subprogram
1014 -- body contract is instantiated. Since the generic
1015 -- template is legal, do not perform this check in
1016 -- the instance to circumvent this oddity.
1018 if Is_Generic_Instance (Spec_Id) then
1021 -- An abstract state with visible refinement cannot
1022 -- appear in pragma [Refined_]Depends as its place
1023 -- must be taken by some of its constituents
1024 -- (SPARK RM 6.1.4(7)).
1026 elsif Has_Visible_Refinement (Item_Id) then
1028 ("cannot mention state & in dependence relation",
1030 SPARK_Msg_N ("\use its constituents instead", Item);
1033 -- If the reference to the abstract state appears in
1034 -- an enclosing package body that will eventually
1035 -- refine the state, record the reference for future
1039 Record_Possible_Body_Reference
1040 (State_Id => Item_Id,
1045 -- When the item renames an entire object, replace the
1046 -- item with a reference to the object.
1048 if Entity (Item) /= Item_Id then
1050 New_Occurrence_Of (Item_Id, Sloc (Item)));
1054 -- Add the entity of the current item to the list of
1057 if Ekind (Item_Id) = E_Abstract_State then
1058 Append_New_Elmt (Item_Id, States_Seen);
1060 -- The variable may eventually become a constituent of a
1061 -- single protected/task type. Record the reference now
1062 -- and verify its legality when analyzing the contract of
1063 -- the variable (SPARK RM 9.3).
1065 elsif Ekind (Item_Id) = E_Variable then
1066 Record_Possible_Part_Of_Reference
1071 if Ekind_In (Item_Id, E_Abstract_State,
1074 and then Present (Encapsulating_State (Item_Id))
1076 Append_New_Elmt (Item_Id, Constits_Seen);
1079 -- All other input/output items are illegal
1080 -- (SPARK RM 6.1.5(1)).
1084 ("item must denote parameter, variable, state or "
1085 & "current instance of concurren type", Item);
1088 -- All other input/output items are illegal
1089 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1093 ("item must denote parameter, variable, state or current "
1094 & "instance of concurrent type", Item);
1097 end Analyze_Input_Output;
1105 Non_Null_Output_Seen : Boolean := False;
1106 -- Flag used to check the legality of an output list
1108 -- Start of processing for Analyze_Dependency_Clause
1111 Inputs := Expression (Clause);
1114 -- An input list with a self-dependency appears as operator "+" where
1115 -- the actuals inputs are the right operand.
1117 if Nkind (Inputs) = N_Op_Plus then
1118 Inputs := Right_Opnd (Inputs);
1122 -- Process the output_list of a dependency_clause
1124 Output := First (Choices (Clause));
1125 while Present (Output) loop
1126 Analyze_Input_Output
1129 Self_Ref => Self_Ref,
1131 Seen => All_Outputs_Seen,
1132 Null_Seen => Null_Output_Seen,
1133 Non_Null_Seen => Non_Null_Output_Seen);
1138 -- Process the input_list of a dependency_clause
1140 Analyze_Input_List (Inputs);
1141 end Analyze_Dependency_Clause;
1143 ---------------------------
1144 -- Check_Function_Return --
1145 ---------------------------
1147 procedure Check_Function_Return is
1149 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1150 and then not Result_Seen
1153 ("result of & must appear in exactly one output list",
1156 end Check_Function_Return;
1162 procedure Check_Role
1164 Item_Id : Entity_Id;
1169 (Item_Is_Input : out Boolean;
1170 Item_Is_Output : out Boolean);
1171 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1172 -- Item_Is_Output are set depending on the role.
1174 procedure Role_Error
1175 (Item_Is_Input : Boolean;
1176 Item_Is_Output : Boolean);
1177 -- Emit an error message concerning the incorrect use of Item in
1178 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1179 -- denote whether the item is an input and/or an output.
1186 (Item_Is_Input : out Boolean;
1187 Item_Is_Output : out Boolean)
1190 Item_Is_Input := False;
1191 Item_Is_Output := False;
1195 if Ekind (Item_Id) = E_Abstract_State then
1197 -- When pragma Global is present, the mode of the state may be
1198 -- further constrained by setting a more restrictive mode.
1201 if Appears_In (Subp_Inputs, Item_Id) then
1202 Item_Is_Input := True;
1205 if Appears_In (Subp_Outputs, Item_Id) then
1206 Item_Is_Output := True;
1209 -- Otherwise the state has a default IN OUT mode
1212 Item_Is_Input := True;
1213 Item_Is_Output := True;
1218 elsif Ekind_In (Item_Id, E_Constant,
1222 Item_Is_Input := True;
1226 elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1229 Item_Is_Input := True;
1231 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1234 Item_Is_Input := True;
1235 Item_Is_Output := True;
1237 elsif Ekind (Item_Id) = E_Out_Parameter then
1238 if Scope (Item_Id) = Spec_Id then
1240 -- An OUT parameter of the related subprogram has mode IN
1241 -- if its type is unconstrained or tagged because array
1242 -- bounds, discriminants or tags can be read.
1244 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1245 Item_Is_Input := True;
1248 Item_Is_Output := True;
1250 -- An OUT parameter of an enclosing subprogram behaves as a
1251 -- read-write variable in which case the mode is IN OUT.
1254 Item_Is_Input := True;
1255 Item_Is_Output := True;
1260 elsif Ekind (Item_Id) = E_Protected_Type then
1262 -- A protected type acts as a formal parameter of mode IN when
1263 -- it applies to a protected function.
1265 if Ekind (Spec_Id) = E_Function then
1266 Item_Is_Input := True;
1268 -- Otherwise the protected type acts as a formal of mode IN OUT
1271 Item_Is_Input := True;
1272 Item_Is_Output := True;
1277 elsif Ekind (Item_Id) = E_Task_Type then
1278 Item_Is_Input := True;
1279 Item_Is_Output := True;
1283 else pragma Assert (Ekind (Item_Id) = E_Variable);
1285 -- When pragma Global is present, the mode of the variable may
1286 -- be further constrained by setting a more restrictive mode.
1290 -- A variable has mode IN when its type is unconstrained or
1291 -- tagged because array bounds, discriminants or tags can be
1294 if Appears_In (Subp_Inputs, Item_Id)
1295 or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1297 Item_Is_Input := True;
1300 if Appears_In (Subp_Outputs, Item_Id) then
1301 Item_Is_Output := True;
1304 -- Otherwise the variable has a default IN OUT mode
1307 Item_Is_Input := True;
1308 Item_Is_Output := True;
1317 procedure Role_Error
1318 (Item_Is_Input : Boolean;
1319 Item_Is_Output : Boolean)
1321 Error_Msg : Name_Id;
1326 -- When the item is not part of the input and the output set of
1327 -- the related subprogram, then it appears as extra in pragma
1328 -- [Refined_]Depends.
1330 if not Item_Is_Input and then not Item_Is_Output then
1331 Add_Item_To_Name_Buffer (Item_Id);
1332 Add_Str_To_Name_Buffer
1333 (" & cannot appear in dependence relation");
1335 Error_Msg := Name_Find;
1336 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1338 Error_Msg_Name_1 := Chars (Spec_Id);
1340 (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1341 & "set of subprogram %"), Item, Item_Id);
1343 -- The mode of the item and its role in pragma [Refined_]Depends
1344 -- are in conflict. Construct a detailed message explaining the
1345 -- illegality (SPARK RM 6.1.5(5-6)).
1348 if Item_Is_Input then
1349 Add_Str_To_Name_Buffer ("read-only");
1351 Add_Str_To_Name_Buffer ("write-only");
1354 Add_Char_To_Name_Buffer (' ');
1355 Add_Item_To_Name_Buffer (Item_Id);
1356 Add_Str_To_Name_Buffer (" & cannot appear as ");
1358 if Item_Is_Input then
1359 Add_Str_To_Name_Buffer ("output");
1361 Add_Str_To_Name_Buffer ("input");
1364 Add_Str_To_Name_Buffer (" in dependence relation");
1365 Error_Msg := Name_Find;
1366 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1372 Item_Is_Input : Boolean;
1373 Item_Is_Output : Boolean;
1375 -- Start of processing for Check_Role
1378 Find_Role (Item_Is_Input, Item_Is_Output);
1383 if not Item_Is_Input then
1384 Role_Error (Item_Is_Input, Item_Is_Output);
1387 -- Self-referential item
1390 if not Item_Is_Input or else not Item_Is_Output then
1391 Role_Error (Item_Is_Input, Item_Is_Output);
1396 elsif not Item_Is_Output then
1397 Role_Error (Item_Is_Input, Item_Is_Output);
1405 procedure Check_Usage
1406 (Subp_Items : Elist_Id;
1407 Used_Items : Elist_Id;
1410 procedure Usage_Error (Item_Id : Entity_Id);
1411 -- Emit an error concerning the illegal usage of an item
1417 procedure Usage_Error (Item_Id : Entity_Id) is
1418 Error_Msg : Name_Id;
1425 -- Unconstrained and tagged items are not part of the explicit
1426 -- input set of the related subprogram, they do not have to be
1427 -- present in a dependence relation and should not be flagged
1428 -- (SPARK RM 6.1.5(8)).
1430 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1433 Add_Item_To_Name_Buffer (Item_Id);
1434 Add_Str_To_Name_Buffer
1435 (" & is missing from input dependence list");
1437 Error_Msg := Name_Find;
1438 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1441 -- Output case (SPARK RM 6.1.5(10))
1446 Add_Item_To_Name_Buffer (Item_Id);
1447 Add_Str_To_Name_Buffer
1448 (" & is missing from output dependence list");
1450 Error_Msg := Name_Find;
1451 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1459 Item_Id : Entity_Id;
1461 -- Start of processing for Check_Usage
1464 if No (Subp_Items) then
1468 -- Each input or output of the subprogram must appear in a dependency
1471 Elmt := First_Elmt (Subp_Items);
1472 while Present (Elmt) loop
1473 Item := Node (Elmt);
1475 if Nkind (Item) = N_Defining_Identifier then
1478 Item_Id := Entity_Of (Item);
1481 -- The item does not appear in a dependency
1483 if Present (Item_Id)
1484 and then not Contains (Used_Items, Item_Id)
1486 if Is_Formal (Item_Id) then
1487 Usage_Error (Item_Id);
1489 -- The current instance of a protected type behaves as a formal
1490 -- parameter (SPARK RM 6.1.4).
1492 elsif Ekind (Item_Id) = E_Protected_Type
1493 or else Is_Single_Protected_Object (Item_Id)
1495 Usage_Error (Item_Id);
1497 -- The current instance of a task type behaves as a formal
1498 -- parameter (SPARK RM 6.1.4).
1500 elsif Ekind (Item_Id) = E_Task_Type
1501 or else Is_Single_Task_Object (Item_Id)
1503 -- The dependence of a task unit on itself is implicit and
1504 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1505 -- Emit an error if only one input/output is present.
1507 if Task_Input_Seen /= Task_Output_Seen then
1508 Usage_Error (Item_Id);
1511 -- States and global objects are not used properly only when
1512 -- the subprogram is subject to pragma Global.
1514 elsif Global_Seen then
1515 Usage_Error (Item_Id);
1523 ----------------------
1524 -- Normalize_Clause --
1525 ----------------------
1527 procedure Normalize_Clause (Clause : Node_Id) is
1528 procedure Create_Or_Modify_Clause
1534 Multiple : Boolean);
1535 -- Create a brand new clause to represent the self-reference or
1536 -- modify the input and/or output lists of an existing clause. Output
1537 -- denotes a self-referencial output. Outputs is the output list of a
1538 -- clause. Inputs is the input list of a clause. After denotes the
1539 -- clause after which the new clause is to be inserted. Flag In_Place
1540 -- should be set when normalizing the last output of an output list.
1541 -- Flag Multiple should be set when Output comes from a list with
1544 -----------------------------
1545 -- Create_Or_Modify_Clause --
1546 -----------------------------
1548 procedure Create_Or_Modify_Clause
1556 procedure Propagate_Output
1559 -- Handle the various cases of output propagation to the input
1560 -- list. Output denotes a self-referencial output item. Inputs
1561 -- is the input list of a clause.
1563 ----------------------
1564 -- Propagate_Output --
1565 ----------------------
1567 procedure Propagate_Output
1571 function In_Input_List
1573 Inputs : List_Id) return Boolean;
1574 -- Determine whether a particulat item appears in the input
1575 -- list of a clause.
1581 function In_Input_List
1583 Inputs : List_Id) return Boolean
1588 Elmt := First (Inputs);
1589 while Present (Elmt) loop
1590 if Entity_Of (Elmt) = Item then
1602 Output_Id : constant Entity_Id := Entity_Of (Output);
1605 -- Start of processing for Propagate_Output
1608 -- The clause is of the form:
1610 -- (Output =>+ null)
1612 -- Remove null input and replace it with a copy of the output:
1614 -- (Output => Output)
1616 if Nkind (Inputs) = N_Null then
1617 Rewrite (Inputs, New_Copy_Tree (Output));
1619 -- The clause is of the form:
1621 -- (Output =>+ (Input1, ..., InputN))
1623 -- Determine whether the output is not already mentioned in the
1624 -- input list and if not, add it to the list of inputs:
1626 -- (Output => (Output, Input1, ..., InputN))
1628 elsif Nkind (Inputs) = N_Aggregate then
1629 Grouped := Expressions (Inputs);
1631 if not In_Input_List
1635 Prepend_To (Grouped, New_Copy_Tree (Output));
1638 -- The clause is of the form:
1640 -- (Output =>+ Input)
1642 -- If the input does not mention the output, group the two
1645 -- (Output => (Output, Input))
1647 elsif Entity_Of (Inputs) /= Output_Id then
1649 Make_Aggregate (Loc,
1650 Expressions => New_List (
1651 New_Copy_Tree (Output),
1652 New_Copy_Tree (Inputs))));
1654 end Propagate_Output;
1658 Loc : constant Source_Ptr := Sloc (Clause);
1659 New_Clause : Node_Id;
1661 -- Start of processing for Create_Or_Modify_Clause
1664 -- A null output depending on itself does not require any
1667 if Nkind (Output) = N_Null then
1670 -- A function result cannot depend on itself because it cannot
1671 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1673 elsif Is_Attribute_Result (Output) then
1674 SPARK_Msg_N ("function result cannot depend on itself", Output);
1678 -- When performing the transformation in place, simply add the
1679 -- output to the list of inputs (if not already there). This
1680 -- case arises when dealing with the last output of an output
1681 -- list. Perform the normalization in place to avoid generating
1682 -- a malformed tree.
1685 Propagate_Output (Output, Inputs);
1687 -- A list with multiple outputs is slowly trimmed until only
1688 -- one element remains. When this happens, replace aggregate
1689 -- with the element itself.
1693 Rewrite (Outputs, Output);
1699 -- Unchain the output from its output list as it will appear in
1700 -- a new clause. Note that we cannot simply rewrite the output
1701 -- as null because this will violate the semantics of pragma
1706 -- Generate a new clause of the form:
1707 -- (Output => Inputs)
1710 Make_Component_Association (Loc,
1711 Choices => New_List (Output),
1712 Expression => New_Copy_Tree (Inputs));
1714 -- The new clause contains replicated content that has already
1715 -- been analyzed. There is not need to reanalyze or renormalize
1718 Set_Analyzed (New_Clause);
1721 (Output => First (Choices (New_Clause)),
1722 Inputs => Expression (New_Clause));
1724 Insert_After (After, New_Clause);
1726 end Create_Or_Modify_Clause;
1730 Outputs : constant Node_Id := First (Choices (Clause));
1732 Last_Output : Node_Id;
1733 Next_Output : Node_Id;
1736 -- Start of processing for Normalize_Clause
1739 -- A self-dependency appears as operator "+". Remove the "+" from the
1740 -- tree by moving the real inputs to their proper place.
1742 if Nkind (Expression (Clause)) = N_Op_Plus then
1743 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1744 Inputs := Expression (Clause);
1746 -- Multiple outputs appear as an aggregate
1748 if Nkind (Outputs) = N_Aggregate then
1749 Last_Output := Last (Expressions (Outputs));
1751 Output := First (Expressions (Outputs));
1752 while Present (Output) loop
1754 -- Normalization may remove an output from its list,
1755 -- preserve the subsequent output now.
1757 Next_Output := Next (Output);
1759 Create_Or_Modify_Clause
1764 In_Place => Output = Last_Output,
1767 Output := Next_Output;
1773 Create_Or_Modify_Clause
1782 end Normalize_Clause;
1786 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
1787 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1791 Last_Clause : Node_Id;
1792 Restore_Scope : Boolean := False;
1794 -- Start of processing for Analyze_Depends_In_Decl_Part
1797 -- Do not analyze the pragma multiple times
1799 if Is_Analyzed_Pragma (N) then
1803 -- Empty dependency list
1805 if Nkind (Deps) = N_Null then
1807 -- Gather all states, objects and formal parameters that the
1808 -- subprogram may depend on. These items are obtained from the
1809 -- parameter profile or pragma [Refined_]Global (if available).
1811 Collect_Subprogram_Inputs_Outputs
1812 (Subp_Id => Subp_Id,
1813 Subp_Inputs => Subp_Inputs,
1814 Subp_Outputs => Subp_Outputs,
1815 Global_Seen => Global_Seen);
1817 -- Verify that every input or output of the subprogram appear in a
1820 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1821 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1822 Check_Function_Return;
1824 -- Dependency clauses appear as component associations of an aggregate
1826 elsif Nkind (Deps) = N_Aggregate then
1828 -- Do not attempt to perform analysis of a syntactically illegal
1829 -- clause as this will lead to misleading errors.
1831 if Has_Extra_Parentheses (Deps) then
1835 if Present (Component_Associations (Deps)) then
1836 Last_Clause := Last (Component_Associations (Deps));
1838 -- Gather all states, objects and formal parameters that the
1839 -- subprogram may depend on. These items are obtained from the
1840 -- parameter profile or pragma [Refined_]Global (if available).
1842 Collect_Subprogram_Inputs_Outputs
1843 (Subp_Id => Subp_Id,
1844 Subp_Inputs => Subp_Inputs,
1845 Subp_Outputs => Subp_Outputs,
1846 Global_Seen => Global_Seen);
1848 -- When pragma [Refined_]Depends appears on a single concurrent
1849 -- type, it is relocated to the anonymous object.
1851 if Is_Single_Concurrent_Object (Spec_Id) then
1854 -- Ensure that the formal parameters are visible when analyzing
1855 -- all clauses. This falls out of the general rule of aspects
1856 -- pertaining to subprogram declarations.
1858 elsif not In_Open_Scopes (Spec_Id) then
1859 Restore_Scope := True;
1860 Push_Scope (Spec_Id);
1862 if Ekind (Spec_Id) = E_Task_Type then
1863 if Has_Discriminants (Spec_Id) then
1864 Install_Discriminants (Spec_Id);
1867 elsif Is_Generic_Subprogram (Spec_Id) then
1868 Install_Generic_Formals (Spec_Id);
1871 Install_Formals (Spec_Id);
1875 Clause := First (Component_Associations (Deps));
1876 while Present (Clause) loop
1877 Errors := Serious_Errors_Detected;
1879 -- The normalization mechanism may create extra clauses that
1880 -- contain replicated input and output names. There is no need
1881 -- to reanalyze them.
1883 if not Analyzed (Clause) then
1884 Set_Analyzed (Clause);
1886 Analyze_Dependency_Clause
1888 Is_Last => Clause = Last_Clause);
1891 -- Do not normalize a clause if errors were detected (count
1892 -- of Serious_Errors has increased) because the inputs and/or
1893 -- outputs may denote illegal items. Normalization is disabled
1894 -- in ASIS mode as it alters the tree by introducing new nodes
1895 -- similar to expansion.
1897 if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1898 Normalize_Clause (Clause);
1904 if Restore_Scope then
1908 -- Verify that every input or output of the subprogram appear in a
1911 Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1912 Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1913 Check_Function_Return;
1915 -- The dependency list is malformed. This is a syntax error, always
1919 Error_Msg_N ("malformed dependency relation", Deps);
1923 -- The top level dependency relation is malformed. This is a syntax
1924 -- error, always report.
1927 Error_Msg_N ("malformed dependency relation", Deps);
1931 -- Ensure that a state and a corresponding constituent do not appear
1932 -- together in pragma [Refined_]Depends.
1934 Check_State_And_Constituent_Use
1935 (States => States_Seen,
1936 Constits => Constits_Seen,
1940 Set_Is_Analyzed_Pragma (N);
1941 end Analyze_Depends_In_Decl_Part;
1943 --------------------------------------------
1944 -- Analyze_External_Property_In_Decl_Part --
1945 --------------------------------------------
1947 procedure Analyze_External_Property_In_Decl_Part
1949 Expr_Val : out Boolean)
1951 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
1952 Obj_Decl : constant Node_Id := Find_Related_Context (N);
1953 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
1959 -- Do not analyze the pragma multiple times
1961 if Is_Analyzed_Pragma (N) then
1965 Error_Msg_Name_1 := Pragma_Name (N);
1967 -- An external property pragma must apply to an effectively volatile
1968 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1969 -- The check is performed at the end of the declarative region due to a
1970 -- possible out-of-order arrangement of pragmas:
1973 -- pragma Async_Readers (Obj);
1974 -- pragma Volatile (Obj);
1976 if not Is_Effectively_Volatile (Obj_Id) then
1978 ("external property % must apply to a volatile object", N);
1981 -- Ensure that the Boolean expression (if present) is static. A missing
1982 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1986 if Present (Arg1) then
1987 Expr := Get_Pragma_Arg (Arg1);
1989 if Is_OK_Static_Expression (Expr) then
1990 Expr_Val := Is_True (Expr_Value (Expr));
1994 Set_Is_Analyzed_Pragma (N);
1995 end Analyze_External_Property_In_Decl_Part;
1997 ---------------------------------
1998 -- Analyze_Global_In_Decl_Part --
1999 ---------------------------------
2001 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2002 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
2003 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2004 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
2006 Constits_Seen : Elist_Id := No_Elist;
2007 -- A list containing the entities of all constituents processed so far.
2008 -- It aids in detecting illegal usage of a state and a corresponding
2009 -- constituent in pragma [Refinde_]Global.
2011 Seen : Elist_Id := No_Elist;
2012 -- A list containing the entities of all the items processed so far. It
2013 -- plays a role in detecting distinct entities.
2015 States_Seen : Elist_Id := No_Elist;
2016 -- A list containing the entities of all states processed so far. It
2017 -- helps in detecting illegal usage of a state and a corresponding
2018 -- constituent in pragma [Refined_]Global.
2020 In_Out_Seen : Boolean := False;
2021 Input_Seen : Boolean := False;
2022 Output_Seen : Boolean := False;
2023 Proof_Seen : Boolean := False;
2024 -- Flags used to verify the consistency of modes
2026 procedure Analyze_Global_List
2028 Global_Mode : Name_Id := Name_Input);
2029 -- Verify the legality of a single global list declaration. Global_Mode
2030 -- denotes the current mode in effect.
2032 -------------------------
2033 -- Analyze_Global_List --
2034 -------------------------
2036 procedure Analyze_Global_List
2038 Global_Mode : Name_Id := Name_Input)
2040 procedure Analyze_Global_Item
2042 Global_Mode : Name_Id);
2043 -- Verify the legality of a single global item declaration denoted by
2044 -- Item. Global_Mode denotes the current mode in effect.
2046 procedure Check_Duplicate_Mode
2048 Status : in out Boolean);
2049 -- Flag Status denotes whether a particular mode has been seen while
2050 -- processing a global list. This routine verifies that Mode is not a
2051 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2053 procedure Check_Mode_Restriction_In_Enclosing_Context
2055 Item_Id : Entity_Id);
2056 -- Verify that an item of mode In_Out or Output does not appear as an
2057 -- input in the Global aspect of an enclosing subprogram. If this is
2058 -- the case, emit an error. Item and Item_Id are respectively the
2059 -- item and its entity.
2061 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2062 -- Mode denotes either In_Out or Output. Depending on the kind of the
2063 -- related subprogram, emit an error if those two modes apply to a
2064 -- function (SPARK RM 6.1.4(10)).
2066 -------------------------
2067 -- Analyze_Global_Item --
2068 -------------------------
2070 procedure Analyze_Global_Item
2072 Global_Mode : Name_Id)
2074 Item_Id : Entity_Id;
2077 -- Detect one of the following cases
2079 -- with Global => (null, Name)
2080 -- with Global => (Name_1, null, Name_2)
2081 -- with Global => (Name, null)
2083 if Nkind (Item) = N_Null then
2084 SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2089 Resolve_State (Item);
2091 -- Find the entity of the item. If this is a renaming, climb the
2092 -- renaming chain to reach the root object. Renamings of non-
2093 -- entire objects do not yield an entity (Empty).
2095 Item_Id := Entity_Of (Item);
2097 if Present (Item_Id) then
2099 -- A global item may denote a formal parameter of an enclosing
2100 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2101 -- provide a better error diagnostic.
2103 if Is_Formal (Item_Id) then
2104 if Scope (Item_Id) = Spec_Id then
2106 (Fix_Msg (Spec_Id, "global item cannot reference "
2107 & "parameter of subprogram &"), Item, Spec_Id);
2111 -- A global item may denote a concurrent type as long as it is
2112 -- the current instance of an enclosing protected or task type
2113 -- (SPARK RM 6.1.4).
2115 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2116 if Is_CCT_Instance (Item_Id, Spec_Id) then
2118 -- Pragma [Refined_]Global associated with a protected
2119 -- subprogram cannot mention the current instance of a
2120 -- protected type because the instance behaves as a
2121 -- formal parameter.
2123 if Ekind (Item_Id) = E_Protected_Type then
2124 Error_Msg_Name_1 := Chars (Item_Id);
2126 (Fix_Msg (Spec_Id, "global item of subprogram & "
2127 & "cannot reference current instance of protected "
2128 & "type %"), Item, Spec_Id);
2131 -- Pragma [Refined_]Global associated with a task type
2132 -- cannot mention the current instance of a task type
2133 -- because the instance behaves as a formal parameter.
2135 else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2136 Error_Msg_Name_1 := Chars (Item_Id);
2138 (Fix_Msg (Spec_Id, "global item of subprogram & "
2139 & "cannot reference current instance of task type "
2140 & "%"), Item, Spec_Id);
2144 -- Otherwise the global item denotes a subtype mark that is
2145 -- not a current instance.
2149 ("invalid use of subtype mark in global list", Item);
2153 -- A global item may denote the anonymous object created for a
2154 -- single protected/task type as long as the current instance
2155 -- is the same single type (SPARK RM 6.1.4).
2157 elsif Is_Single_Concurrent_Object (Item_Id)
2158 and then Is_CCT_Instance (Item_Id, Spec_Id)
2160 -- Pragma [Refined_]Global associated with a protected
2161 -- subprogram cannot mention the current instance of a
2162 -- protected type because the instance behaves as a formal
2165 if Is_Single_Protected_Object (Item_Id) then
2166 Error_Msg_Name_1 := Chars (Item_Id);
2168 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2169 & "reference current instance of protected type %"),
2173 -- Pragma [Refined_]Global associated with a task type
2174 -- cannot mention the current instance of a task type
2175 -- because the instance behaves as a formal parameter.
2177 else pragma Assert (Is_Single_Task_Object (Item_Id));
2178 Error_Msg_Name_1 := Chars (Item_Id);
2180 (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2181 & "reference current instance of task type %"),
2186 -- A formal object may act as a global item inside a generic
2188 elsif Is_Formal_Object (Item_Id) then
2191 -- The only legal references are those to abstract states,
2192 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2194 elsif not Ekind_In (Item_Id, E_Abstract_State,
2201 ("global item must denote object, state or current "
2202 & "instance of concurrent type", Item);
2206 -- State related checks
2208 if Ekind (Item_Id) = E_Abstract_State then
2210 -- Package and subprogram bodies are instantiated
2211 -- individually in a separate compiler pass. Due to this
2212 -- mode of instantiation, the refinement of a state may
2213 -- no longer be visible when a subprogram body contract
2214 -- is instantiated. Since the generic template is legal,
2215 -- do not perform this check in the instance to circumvent
2218 if Is_Generic_Instance (Spec_Id) then
2221 -- An abstract state with visible refinement cannot appear
2222 -- in pragma [Refined_]Global as its place must be taken by
2223 -- some of its constituents (SPARK RM 6.1.4(7)).
2225 elsif Has_Visible_Refinement (Item_Id) then
2227 ("cannot mention state & in global refinement",
2229 SPARK_Msg_N ("\use its constituents instead", Item);
2232 -- An external state cannot appear as a global item of a
2233 -- nonvolatile function (SPARK RM 7.1.3(8)).
2235 elsif Is_External_State (Item_Id)
2236 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2237 and then not Is_Volatile_Function (Spec_Id)
2240 ("external state & cannot act as global item of "
2241 & "nonvolatile function", Item, Item_Id);
2244 -- If the reference to the abstract state appears in an
2245 -- enclosing package body that will eventually refine the
2246 -- state, record the reference for future checks.
2249 Record_Possible_Body_Reference
2250 (State_Id => Item_Id,
2254 -- Constant related checks
2256 elsif Ekind (Item_Id) = E_Constant then
2258 -- A constant is a read-only item, therefore it cannot act
2261 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2263 ("constant & cannot act as output", Item, Item_Id);
2267 -- Discriminant related checks
2269 elsif Ekind (Item_Id) = E_Discriminant then
2271 -- A discriminant is a read-only item, therefore it cannot
2272 -- act as an output.
2274 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2276 ("discriminant & cannot act as output", Item, Item_Id);
2280 -- Loop parameter related checks
2282 elsif Ekind (Item_Id) = E_Loop_Parameter then
2284 -- A loop parameter is a read-only item, therefore it cannot
2285 -- act as an output.
2287 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2289 ("loop parameter & cannot act as output",
2294 -- Variable related checks. These are only relevant when
2295 -- SPARK_Mode is on as they are not standard Ada legality
2298 elsif SPARK_Mode = On
2299 and then Ekind (Item_Id) = E_Variable
2300 and then Is_Effectively_Volatile (Item_Id)
2302 -- An effectively volatile object cannot appear as a global
2303 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2305 if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2306 and then not Is_Volatile_Function (Spec_Id)
2309 ("volatile object & cannot act as global item of a "
2310 & "function", Item, Item_Id);
2313 -- An effectively volatile object with external property
2314 -- Effective_Reads set to True must have mode Output or
2315 -- In_Out (SPARK RM 7.1.3(10)).
2317 elsif Effective_Reads_Enabled (Item_Id)
2318 and then Global_Mode = Name_Input
2321 ("volatile object & with property Effective_Reads must "
2322 & "have mode In_Out or Output", Item, Item_Id);
2327 -- When the item renames an entire object, replace the item
2328 -- with a reference to the object.
2330 if Entity (Item) /= Item_Id then
2331 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2335 -- Some form of illegal construct masquerading as a name
2336 -- (SPARK RM 6.1.4(4)).
2340 ("global item must denote object, state or current instance "
2341 & "of concurrent type", Item);
2345 -- Verify that an output does not appear as an input in an
2346 -- enclosing subprogram.
2348 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2349 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2352 -- The same entity might be referenced through various way.
2353 -- Check the entity of the item rather than the item itself
2354 -- (SPARK RM 6.1.4(10)).
2356 if Contains (Seen, Item_Id) then
2357 SPARK_Msg_N ("duplicate global item", Item);
2359 -- Add the entity of the current item to the list of processed
2363 Append_New_Elmt (Item_Id, Seen);
2365 if Ekind (Item_Id) = E_Abstract_State then
2366 Append_New_Elmt (Item_Id, States_Seen);
2368 -- The variable may eventually become a constituent of a single
2369 -- protected/task type. Record the reference now and verify its
2370 -- legality when analyzing the contract of the variable
2373 elsif Ekind (Item_Id) = E_Variable then
2374 Record_Possible_Part_Of_Reference
2379 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2380 and then Present (Encapsulating_State (Item_Id))
2382 Append_New_Elmt (Item_Id, Constits_Seen);
2385 end Analyze_Global_Item;
2387 --------------------------
2388 -- Check_Duplicate_Mode --
2389 --------------------------
2391 procedure Check_Duplicate_Mode
2393 Status : in out Boolean)
2397 SPARK_Msg_N ("duplicate global mode", Mode);
2401 end Check_Duplicate_Mode;
2403 -------------------------------------------------
2404 -- Check_Mode_Restriction_In_Enclosing_Context --
2405 -------------------------------------------------
2407 procedure Check_Mode_Restriction_In_Enclosing_Context
2409 Item_Id : Entity_Id)
2411 Context : Entity_Id;
2413 Inputs : Elist_Id := No_Elist;
2414 Outputs : Elist_Id := No_Elist;
2417 -- Traverse the scope stack looking for enclosing subprograms
2418 -- subject to pragma [Refined_]Global.
2420 Context := Scope (Subp_Id);
2421 while Present (Context) and then Context /= Standard_Standard loop
2422 if Is_Subprogram (Context)
2424 (Present (Get_Pragma (Context, Pragma_Global))
2426 Present (Get_Pragma (Context, Pragma_Refined_Global)))
2428 Collect_Subprogram_Inputs_Outputs
2429 (Subp_Id => Context,
2430 Subp_Inputs => Inputs,
2431 Subp_Outputs => Outputs,
2432 Global_Seen => Dummy);
2434 -- The item is classified as In_Out or Output but appears as
2435 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2437 if Appears_In (Inputs, Item_Id)
2438 and then not Appears_In (Outputs, Item_Id)
2441 ("global item & cannot have mode In_Out or Output",
2445 (Fix_Msg (Subp_Id, "\item already appears as input of "
2446 & "subprogram &"), Item, Context);
2448 -- Stop the traversal once an error has been detected
2454 Context := Scope (Context);
2456 end Check_Mode_Restriction_In_Enclosing_Context;
2458 ----------------------------------------
2459 -- Check_Mode_Restriction_In_Function --
2460 ----------------------------------------
2462 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2464 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2466 ("global mode & is not applicable to functions", Mode);
2468 end Check_Mode_Restriction_In_Function;
2476 -- Start of processing for Analyze_Global_List
2479 if Nkind (List) = N_Null then
2480 Set_Analyzed (List);
2482 -- Single global item declaration
2484 elsif Nkind_In (List, N_Expanded_Name,
2486 N_Selected_Component)
2488 Analyze_Global_Item (List, Global_Mode);
2490 -- Simple global list or moded global list declaration
2492 elsif Nkind (List) = N_Aggregate then
2493 Set_Analyzed (List);
2495 -- The declaration of a simple global list appear as a collection
2498 if Present (Expressions (List)) then
2499 if Present (Component_Associations (List)) then
2501 ("cannot mix moded and non-moded global lists", List);
2504 Item := First (Expressions (List));
2505 while Present (Item) loop
2506 Analyze_Global_Item (Item, Global_Mode);
2510 -- The declaration of a moded global list appears as a collection
2511 -- of component associations where individual choices denote
2514 elsif Present (Component_Associations (List)) then
2515 if Present (Expressions (List)) then
2517 ("cannot mix moded and non-moded global lists", List);
2520 Assoc := First (Component_Associations (List));
2521 while Present (Assoc) loop
2522 Mode := First (Choices (Assoc));
2524 if Nkind (Mode) = N_Identifier then
2525 if Chars (Mode) = Name_In_Out then
2526 Check_Duplicate_Mode (Mode, In_Out_Seen);
2527 Check_Mode_Restriction_In_Function (Mode);
2529 elsif Chars (Mode) = Name_Input then
2530 Check_Duplicate_Mode (Mode, Input_Seen);
2532 elsif Chars (Mode) = Name_Output then
2533 Check_Duplicate_Mode (Mode, Output_Seen);
2534 Check_Mode_Restriction_In_Function (Mode);
2536 elsif Chars (Mode) = Name_Proof_In then
2537 Check_Duplicate_Mode (Mode, Proof_Seen);
2540 SPARK_Msg_N ("invalid mode selector", Mode);
2544 SPARK_Msg_N ("invalid mode selector", Mode);
2547 -- Items in a moded list appear as a collection of
2548 -- expressions. Reuse the existing machinery to analyze
2552 (List => Expression (Assoc),
2553 Global_Mode => Chars (Mode));
2561 raise Program_Error;
2564 -- Any other attempt to declare a global item is illegal. This is a
2565 -- syntax error, always report.
2568 Error_Msg_N ("malformed global list", List);
2570 end Analyze_Global_List;
2574 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2576 Restore_Scope : Boolean := False;
2578 -- Start of processing for Analyze_Global_In_Decl_Part
2581 -- Do not analyze the pragma multiple times
2583 if Is_Analyzed_Pragma (N) then
2587 -- There is nothing to be done for a null global list
2589 if Nkind (Items) = N_Null then
2590 Set_Analyzed (Items);
2592 -- Analyze the various forms of global lists and items. Note that some
2593 -- of these may be malformed in which case the analysis emits error
2597 -- When pragma [Refined_]Global appears on a single concurrent type,
2598 -- it is relocated to the anonymous object.
2600 if Is_Single_Concurrent_Object (Spec_Id) then
2603 -- Ensure that the formal parameters are visible when processing an
2604 -- item. This falls out of the general rule of aspects pertaining to
2605 -- subprogram declarations.
2607 elsif not In_Open_Scopes (Spec_Id) then
2608 Restore_Scope := True;
2609 Push_Scope (Spec_Id);
2611 if Ekind (Spec_Id) = E_Task_Type then
2612 if Has_Discriminants (Spec_Id) then
2613 Install_Discriminants (Spec_Id);
2616 elsif Is_Generic_Subprogram (Spec_Id) then
2617 Install_Generic_Formals (Spec_Id);
2620 Install_Formals (Spec_Id);
2624 Analyze_Global_List (Items);
2626 if Restore_Scope then
2631 -- Ensure that a state and a corresponding constituent do not appear
2632 -- together in pragma [Refined_]Global.
2634 Check_State_And_Constituent_Use
2635 (States => States_Seen,
2636 Constits => Constits_Seen,
2639 Set_Is_Analyzed_Pragma (N);
2640 end Analyze_Global_In_Decl_Part;
2642 --------------------------------------------
2643 -- Analyze_Initial_Condition_In_Decl_Part --
2644 --------------------------------------------
2646 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2647 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2648 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2649 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
2651 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2654 -- Do not analyze the pragma multiple times
2656 if Is_Analyzed_Pragma (N) then
2660 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2661 -- analysis of the pragma, the Ghost mode at point of declaration and
2662 -- point of analysis may not necessarily be the same. Use the mode in
2663 -- effect at the point of declaration.
2667 -- The expression is preanalyzed because it has not been moved to its
2668 -- final place yet. A direct analysis may generate side effects and this
2669 -- is not desired at this point.
2671 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2672 Ghost_Mode := Save_Ghost_Mode;
2674 Set_Is_Analyzed_Pragma (N);
2675 end Analyze_Initial_Condition_In_Decl_Part;
2677 --------------------------------------
2678 -- Analyze_Initializes_In_Decl_Part --
2679 --------------------------------------
2681 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2682 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
2683 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
2685 Constits_Seen : Elist_Id := No_Elist;
2686 -- A list containing the entities of all constituents processed so far.
2687 -- It aids in detecting illegal usage of a state and a corresponding
2688 -- constituent in pragma Initializes.
2690 Items_Seen : Elist_Id := No_Elist;
2691 -- A list of all initialization items processed so far. This list is
2692 -- used to detect duplicate items.
2694 Non_Null_Seen : Boolean := False;
2695 Null_Seen : Boolean := False;
2696 -- Flags used to check the legality of a null initialization list
2698 States_And_Objs : Elist_Id := No_Elist;
2699 -- A list of all abstract states and objects declared in the visible
2700 -- declarations of the related package. This list is used to detect the
2701 -- legality of initialization items.
2703 States_Seen : Elist_Id := No_Elist;
2704 -- A list containing the entities of all states processed so far. It
2705 -- helps in detecting illegal usage of a state and a corresponding
2706 -- constituent in pragma Initializes.
2708 procedure Analyze_Initialization_Item (Item : Node_Id);
2709 -- Verify the legality of a single initialization item
2711 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2712 -- Verify the legality of a single initialization item followed by a
2713 -- list of input items.
2715 procedure Collect_States_And_Objects;
2716 -- Inspect the visible declarations of the related package and gather
2717 -- the entities of all abstract states and objects in States_And_Objs.
2719 ---------------------------------
2720 -- Analyze_Initialization_Item --
2721 ---------------------------------
2723 procedure Analyze_Initialization_Item (Item : Node_Id) is
2724 Item_Id : Entity_Id;
2727 -- Null initialization list
2729 if Nkind (Item) = N_Null then
2731 SPARK_Msg_N ("multiple null initializations not allowed", Item);
2733 elsif Non_Null_Seen then
2735 ("cannot mix null and non-null initialization items", Item);
2740 -- Initialization item
2743 Non_Null_Seen := True;
2747 ("cannot mix null and non-null initialization items", Item);
2751 Resolve_State (Item);
2753 if Is_Entity_Name (Item) then
2754 Item_Id := Entity_Of (Item);
2756 if Ekind_In (Item_Id, E_Abstract_State,
2760 -- The state or variable must be declared in the visible
2761 -- declarations of the package (SPARK RM 7.1.5(7)).
2763 if not Contains (States_And_Objs, Item_Id) then
2764 Error_Msg_Name_1 := Chars (Pack_Id);
2766 ("initialization item & must appear in the visible "
2767 & "declarations of package %", Item, Item_Id);
2769 -- Detect a duplicate use of the same initialization item
2770 -- (SPARK RM 7.1.5(5)).
2772 elsif Contains (Items_Seen, Item_Id) then
2773 SPARK_Msg_N ("duplicate initialization item", Item);
2775 -- The item is legal, add it to the list of processed states
2779 Append_New_Elmt (Item_Id, Items_Seen);
2781 if Ekind (Item_Id) = E_Abstract_State then
2782 Append_New_Elmt (Item_Id, States_Seen);
2785 if Present (Encapsulating_State (Item_Id)) then
2786 Append_New_Elmt (Item_Id, Constits_Seen);
2790 -- The item references something that is not a state or object
2791 -- (SPARK RM 7.1.5(3)).
2795 ("initialization item must denote object or state", Item);
2798 -- Some form of illegal construct masquerading as a name
2799 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2803 ("initialization item must denote object or state", Item);
2806 end Analyze_Initialization_Item;
2808 ---------------------------------------------
2809 -- Analyze_Initialization_Item_With_Inputs --
2810 ---------------------------------------------
2812 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2813 Inputs_Seen : Elist_Id := No_Elist;
2814 -- A list of all inputs processed so far. This list is used to detect
2815 -- duplicate uses of an input.
2817 Non_Null_Seen : Boolean := False;
2818 Null_Seen : Boolean := False;
2819 -- Flags used to check the legality of an input list
2821 procedure Analyze_Input_Item (Input : Node_Id);
2822 -- Verify the legality of a single input item
2824 ------------------------
2825 -- Analyze_Input_Item --
2826 ------------------------
2828 procedure Analyze_Input_Item (Input : Node_Id) is
2829 Input_Id : Entity_Id;
2830 Input_OK : Boolean := True;
2835 if Nkind (Input) = N_Null then
2838 ("multiple null initializations not allowed", Item);
2840 elsif Non_Null_Seen then
2842 ("cannot mix null and non-null initialization item", Item);
2850 Non_Null_Seen := True;
2854 ("cannot mix null and non-null initialization item", Item);
2858 Resolve_State (Input);
2860 if Is_Entity_Name (Input) then
2861 Input_Id := Entity_Of (Input);
2863 if Ekind_In (Input_Id, E_Abstract_State,
2865 E_Generic_In_Out_Parameter,
2866 E_Generic_In_Parameter,
2872 -- The input cannot denote states or objects declared
2873 -- within the related package (SPARK RM 7.1.5(4)).
2875 if Within_Scope (Input_Id, Current_Scope) then
2877 -- Do not consider generic formal parameters or their
2878 -- respective mappings to generic formals. Even though
2879 -- the formals appear within the scope of the package,
2880 -- it is allowed for an initialization item to depend
2881 -- on an input item.
2883 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2884 E_Generic_In_Parameter)
2888 elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2889 and then Present (Corresponding_Generic_Association
2890 (Declaration_Node (Input_Id)))
2896 Error_Msg_Name_1 := Chars (Pack_Id);
2898 ("input item & cannot denote a visible object or "
2899 & "state of package %", Input, Input_Id);
2903 -- Detect a duplicate use of the same input item
2904 -- (SPARK RM 7.1.5(5)).
2906 if Contains (Inputs_Seen, Input_Id) then
2908 SPARK_Msg_N ("duplicate input item", Input);
2911 -- Input is legal, add it to the list of processed inputs
2914 Append_New_Elmt (Input_Id, Inputs_Seen);
2916 if Ekind (Input_Id) = E_Abstract_State then
2917 Append_New_Elmt (Input_Id, States_Seen);
2920 if Ekind_In (Input_Id, E_Abstract_State,
2923 and then Present (Encapsulating_State (Input_Id))
2925 Append_New_Elmt (Input_Id, Constits_Seen);
2929 -- The input references something that is not a state or an
2930 -- object (SPARK RM 7.1.5(3)).
2934 ("input item must denote object or state", Input);
2937 -- Some form of illegal construct masquerading as a name
2938 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2942 ("input item must denote object or state", Input);
2945 end Analyze_Input_Item;
2949 Inputs : constant Node_Id := Expression (Item);
2953 Name_Seen : Boolean := False;
2954 -- A flag used to detect multiple item names
2956 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2959 -- Inspect the name of an item with inputs
2961 Elmt := First (Choices (Item));
2962 while Present (Elmt) loop
2964 SPARK_Msg_N ("only one item allowed in initialization", Elmt);
2967 Analyze_Initialization_Item (Elmt);
2973 -- Multiple input items appear as an aggregate
2975 if Nkind (Inputs) = N_Aggregate then
2976 if Present (Expressions (Inputs)) then
2977 Input := First (Expressions (Inputs));
2978 while Present (Input) loop
2979 Analyze_Input_Item (Input);
2984 if Present (Component_Associations (Inputs)) then
2986 ("inputs must appear in named association form", Inputs);
2989 -- Single input item
2992 Analyze_Input_Item (Inputs);
2994 end Analyze_Initialization_Item_With_Inputs;
2996 --------------------------------
2997 -- Collect_States_And_Objects --
2998 --------------------------------
3000 procedure Collect_States_And_Objects is
3001 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3005 -- Collect the abstract states defined in the package (if any)
3007 if Present (Abstract_States (Pack_Id)) then
3008 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3011 -- Collect all objects the appear in the visible declarations of the
3014 if Present (Visible_Declarations (Pack_Spec)) then
3015 Decl := First (Visible_Declarations (Pack_Spec));
3016 while Present (Decl) loop
3017 if Comes_From_Source (Decl)
3018 and then Nkind (Decl) = N_Object_Declaration
3020 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3026 end Collect_States_And_Objects;
3030 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3033 -- Start of processing for Analyze_Initializes_In_Decl_Part
3036 -- Do not analyze the pragma multiple times
3038 if Is_Analyzed_Pragma (N) then
3042 -- Nothing to do when the initialization list is empty
3044 if Nkind (Inits) = N_Null then
3048 -- Single and multiple initialization clauses appear as an aggregate. If
3049 -- this is not the case, then either the parser or the analysis of the
3050 -- pragma failed to produce an aggregate.
3052 pragma Assert (Nkind (Inits) = N_Aggregate);
3054 -- Initialize the various lists used during analysis
3056 Collect_States_And_Objects;
3058 if Present (Expressions (Inits)) then
3059 Init := First (Expressions (Inits));
3060 while Present (Init) loop
3061 Analyze_Initialization_Item (Init);
3066 if Present (Component_Associations (Inits)) then
3067 Init := First (Component_Associations (Inits));
3068 while Present (Init) loop
3069 Analyze_Initialization_Item_With_Inputs (Init);
3074 -- Ensure that a state and a corresponding constituent do not appear
3075 -- together in pragma Initializes.
3077 Check_State_And_Constituent_Use
3078 (States => States_Seen,
3079 Constits => Constits_Seen,
3082 Set_Is_Analyzed_Pragma (N);
3083 end Analyze_Initializes_In_Decl_Part;
3085 ---------------------
3086 -- Analyze_Part_Of --
3087 ---------------------
3089 procedure Analyze_Part_Of
3091 Item_Id : Entity_Id;
3093 Encap_Id : out Entity_Id;
3094 Legal : out Boolean)
3096 Encap_Typ : Entity_Id;
3097 Item_Decl : Node_Id;
3098 Pack_Id : Entity_Id;
3099 Placement : State_Space_Kind;
3100 Parent_Unit : Entity_Id;
3103 -- Assume that the indicator is illegal
3108 if Nkind_In (Encap, N_Expanded_Name,
3110 N_Selected_Component)
3113 Resolve_State (Encap);
3115 Encap_Id := Entity (Encap);
3117 -- The encapsulator is an abstract state
3119 if Ekind (Encap_Id) = E_Abstract_State then
3122 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3124 elsif Is_Single_Concurrent_Object (Encap_Id) then
3127 -- Otherwise the encapsulator is not a legal choice
3131 ("indicator Part_Of must denote abstract state, single "
3132 & "protected type or single task type", Encap);
3136 -- This is a syntax error, always report
3140 ("indicator Part_Of must denote abstract state, single protected "
3141 & "type or single task type", Encap);
3145 -- Catch a case where indicator Part_Of denotes the abstract view of a
3146 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3148 if From_Limited_With (Encap_Id)
3149 and then Present (Non_Limited_View (Encap_Id))
3150 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3152 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3153 SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3157 -- The encapsulator is an abstract state
3159 if Ekind (Encap_Id) = E_Abstract_State then
3161 -- Determine where the object, package instantiation or state lives
3162 -- with respect to the enclosing packages or package bodies.
3164 Find_Placement_In_State_Space
3165 (Item_Id => Item_Id,
3166 Placement => Placement,
3167 Pack_Id => Pack_Id);
3169 -- The item appears in a non-package construct with a declarative
3170 -- part (subprogram, block, etc). As such, the item is not allowed
3171 -- to be a part of an encapsulating state because the item is not
3174 if Placement = Not_In_Package then
3176 ("indicator Part_Of cannot appear in this context "
3177 & "(SPARK RM 7.2.6(5))", Indic);
3178 Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3180 ("\& is not part of the hidden state of package %",
3183 -- The item appears in the visible state space of some package. In
3184 -- general this scenario does not warrant Part_Of except when the
3185 -- package is a private child unit and the encapsulating state is
3186 -- declared in a parent unit or a public descendant of that parent
3189 elsif Placement = Visible_State_Space then
3190 if Is_Child_Unit (Pack_Id)
3191 and then Is_Private_Descendant (Pack_Id)
3193 -- A variable or state abstraction which is part of the visible
3194 -- state of a private child unit (or one of its public
3195 -- descendants) must have its Part_Of indicator specified. The
3196 -- Part_Of indicator must denote a state abstraction declared
3197 -- by either the parent unit of the private unit or by a public
3198 -- descendant of that parent unit.
3200 -- Find nearest private ancestor (which can be the current unit
3203 Parent_Unit := Pack_Id;
3204 while Present (Parent_Unit) loop
3207 (Parent (Unit_Declaration_Node (Parent_Unit)));
3208 Parent_Unit := Scope (Parent_Unit);
3211 Parent_Unit := Scope (Parent_Unit);
3213 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3215 ("indicator Part_Of must denote abstract state or public "
3216 & "descendant of & (SPARK RM 7.2.6(3))",
3217 Indic, Parent_Unit);
3219 elsif Scope (Encap_Id) = Parent_Unit
3221 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3222 and then not Is_Private_Descendant (Scope (Encap_Id)))
3228 ("indicator Part_Of must denote abstract state or public "
3229 & "descendant of & (SPARK RM 7.2.6(3))",
3230 Indic, Parent_Unit);
3233 -- Indicator Part_Of is not needed when the related package is not
3234 -- a private child unit or a public descendant thereof.
3238 ("indicator Part_Of cannot appear in this context "
3239 & "(SPARK RM 7.2.6(5))", Indic);
3240 Error_Msg_Name_1 := Chars (Pack_Id);
3242 ("\& is declared in the visible part of package %",
3246 -- When the item appears in the private state space of a package, the
3247 -- encapsulating state must be declared in the same package.
3249 elsif Placement = Private_State_Space then
3250 if Scope (Encap_Id) /= Pack_Id then
3252 ("indicator Part_Of must designate an abstract state of "
3253 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3254 Error_Msg_Name_1 := Chars (Pack_Id);
3256 ("\& is declared in the private part of package %",
3260 -- Items declared in the body state space of a package do not need
3261 -- Part_Of indicators as the refinement has already been seen.
3265 ("indicator Part_Of cannot appear in this context "
3266 & "(SPARK RM 7.2.6(5))", Indic);
3268 if Scope (Encap_Id) = Pack_Id then
3269 Error_Msg_Name_1 := Chars (Pack_Id);
3271 ("\& is declared in the body of package %", Indic, Item_Id);
3275 -- The encapsulator is a single concurrent type
3278 Encap_Typ := Etype (Encap_Id);
3280 -- Only abstract states and variables can act as constituents of an
3281 -- encapsulating single concurrent type.
3283 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3286 -- The constituent is a constant
3288 elsif Ekind (Item_Id) = E_Constant then
3289 Error_Msg_Name_1 := Chars (Encap_Id);
3291 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3292 & "single protected type %"), Indic, Item_Id);
3294 -- The constituent is a package instantiation
3297 Error_Msg_Name_1 := Chars (Encap_Id);
3299 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3300 & "constituent of single protected type %"), Indic, Item_Id);
3303 -- When the item denotes an abstract state of a nested package, use
3304 -- the declaration of the package to detect proper placement.
3309 -- with Abstract_State => (State with Part_Of => T)
3311 if Ekind (Item_Id) = E_Abstract_State then
3312 Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3314 Item_Decl := Declaration_Node (Item_Id);
3317 -- Both the item and its encapsulating single concurrent type must
3318 -- appear in the same declarative region (SPARK RM 9.3). Note that
3319 -- privacy is ignored.
3321 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3322 Error_Msg_Name_1 := Chars (Encap_Id);
3324 (Fix_Msg (Encap_Typ, "constituent & must be declared "
3325 & "immediately within the same region as single protected "
3326 & "type %"), Indic, Item_Id);
3331 end Analyze_Part_Of;
3333 ----------------------------------
3334 -- Analyze_Part_Of_In_Decl_Part --
3335 ----------------------------------
3337 procedure Analyze_Part_Of_In_Decl_Part
3339 Freeze_Id : Entity_Id := Empty)
3341 Encap : constant Node_Id :=
3342 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3343 Errors : constant Nat := Serious_Errors_Detected;
3344 Var_Decl : constant Node_Id := Find_Related_Context (N);
3345 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
3346 Constits : Elist_Id;
3347 Encap_Id : Entity_Id;
3351 -- Detect any discrepancies between the placement of the variable with
3352 -- respect to general state space and the encapsulating state or single
3359 Encap_Id => Encap_Id,
3362 -- The Part_Of indicator turns the variable into a constituent of the
3363 -- encapsulating state or single concurrent type.
3366 pragma Assert (Present (Encap_Id));
3367 Constits := Part_Of_Constituents (Encap_Id);
3369 if No (Constits) then
3370 Constits := New_Elmt_List;
3371 Set_Part_Of_Constituents (Encap_Id, Constits);
3374 Append_Elmt (Var_Id, Constits);
3375 Set_Encapsulating_State (Var_Id, Encap_Id);
3378 -- Emit a clarification message when the encapsulator is undefined,
3379 -- possibly due to contract "freezing".
3381 if Errors /= Serious_Errors_Detected
3382 and then Present (Freeze_Id)
3383 and then Has_Undefined_Reference (Encap)
3385 Contract_Freeze_Error (Var_Id, Freeze_Id);
3387 end Analyze_Part_Of_In_Decl_Part;
3389 --------------------
3390 -- Analyze_Pragma --
3391 --------------------
3393 procedure Analyze_Pragma (N : Node_Id) is
3394 Loc : constant Source_Ptr := Sloc (N);
3395 Prag_Id : Pragma_Id;
3398 -- Name of the source pragma, or name of the corresponding aspect for
3399 -- pragmas which originate in a source aspect. In the latter case, the
3400 -- name may be different from the pragma name.
3402 Pragma_Exit : exception;
3403 -- This exception is used to exit pragma processing completely. It
3404 -- is used when an error is detected, and no further processing is
3405 -- required. It is also used if an earlier error has left the tree in
3406 -- a state where the pragma should not be processed.
3409 -- Number of pragma argument associations
3415 -- First four pragma arguments (pragma argument association nodes, or
3416 -- Empty if the corresponding argument does not exist).
3418 type Name_List is array (Natural range <>) of Name_Id;
3419 type Args_List is array (Natural range <>) of Node_Id;
3420 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3422 -----------------------
3423 -- Local Subprograms --
3424 -----------------------
3426 procedure Acquire_Warning_Match_String (Arg : Node_Id);
3427 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3428 -- get the given string argument, and place it in Name_Buffer, adding
3429 -- leading and trailing asterisks if they are not already present. The
3430 -- caller has already checked that Arg is a static string expression.
3432 procedure Ada_2005_Pragma;
3433 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3434 -- Ada 95 mode, these are implementation defined pragmas, so should be
3435 -- caught by the No_Implementation_Pragmas restriction.
3437 procedure Ada_2012_Pragma;
3438 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3439 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3440 -- should be caught by the No_Implementation_Pragmas restriction.
3442 procedure Analyze_Depends_Global
3443 (Spec_Id : out Entity_Id;
3444 Subp_Decl : out Node_Id;
3445 Legal : out Boolean);
3446 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3447 -- legality of the placement and related context of the pragma. Spec_Id
3448 -- is the entity of the related subprogram. Subp_Decl is the declaration
3449 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3451 procedure Analyze_If_Present (Id : Pragma_Id);
3452 -- Inspect the remainder of the list containing pragma N and look for
3453 -- a pragma that matches Id. If found, analyze the pragma.
3455 procedure Analyze_Pre_Post_Condition;
3456 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3458 procedure Analyze_Refined_Depends_Global_Post
3459 (Spec_Id : out Entity_Id;
3460 Body_Id : out Entity_Id;
3461 Legal : out Boolean);
3462 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3463 -- Refined_Global and Refined_Post. Verify the legality of the placement
3464 -- and related context of the pragma. Spec_Id is the entity of the
3465 -- related subprogram. Body_Id is the entity of the subprogram body.
3466 -- Flag Legal is set when the pragma is legal.
3468 procedure Check_Ada_83_Warning;
3469 -- Issues a warning message for the current pragma if operating in Ada
3470 -- 83 mode (used for language pragmas that are not a standard part of
3471 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3474 procedure Check_Arg_Count (Required : Nat);
3475 -- Check argument count for pragma is equal to given parameter. If not,
3476 -- then issue an error message and raise Pragma_Exit.
3478 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3479 -- Arg which can either be a pragma argument association, in which case
3480 -- the check is applied to the expression of the association or an
3481 -- expression directly.
3483 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3484 -- Check that an argument has the right form for an EXTERNAL_NAME
3485 -- parameter of an extended import/export pragma. The rule is that the
3486 -- name must be an identifier or string literal (in Ada 83 mode) or a
3487 -- static string expression (in Ada 95 mode).
3489 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3490 -- Check the specified argument Arg to make sure that it is an
3491 -- identifier. If not give error and raise Pragma_Exit.
3493 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3494 -- Check the specified argument Arg to make sure that it is an integer
3495 -- literal. If not give error and raise Pragma_Exit.
3497 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3498 -- Check the specified argument Arg to make sure that it has the proper
3499 -- syntactic form for a local name and meets the semantic requirements
3500 -- for a local name. The local name is analyzed as part of the
3501 -- processing for this call. In addition, the local name is required
3502 -- to represent an entity at the library level.
3504 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3505 -- Check the specified argument Arg to make sure that it has the proper
3506 -- syntactic form for a local name and meets the semantic requirements
3507 -- for a local name. The local name is analyzed as part of the
3508 -- processing for this call.
3510 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3511 -- Check the specified argument Arg to make sure that it is a valid
3512 -- locking policy name. If not give error and raise Pragma_Exit.
3514 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3515 -- Check the specified argument Arg to make sure that it is a valid
3516 -- elaboration policy name. If not give error and raise Pragma_Exit.
3518 procedure Check_Arg_Is_One_Of
3521 procedure Check_Arg_Is_One_Of
3523 N1, N2, N3 : Name_Id);
3524 procedure Check_Arg_Is_One_Of
3526 N1, N2, N3, N4 : Name_Id);
3527 procedure Check_Arg_Is_One_Of
3529 N1, N2, N3, N4, N5 : Name_Id);
3530 -- Check the specified argument Arg to make sure that it is an
3531 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3532 -- present). If not then give error and raise Pragma_Exit.
3534 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3535 -- Check the specified argument Arg to make sure that it is a valid
3536 -- queuing policy name. If not give error and raise Pragma_Exit.
3538 procedure Check_Arg_Is_OK_Static_Expression
3540 Typ : Entity_Id := Empty);
3541 -- Check the specified argument Arg to make sure that it is a static
3542 -- expression of the given type (i.e. it will be analyzed and resolved
3543 -- using this type, which can be any valid argument to Resolve, e.g.
3544 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3545 -- Typ is left Empty, then any static expression is allowed. Includes
3546 -- checking that the argument does not raise Constraint_Error.
3548 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3549 -- Check the specified argument Arg to make sure that it is a valid task
3550 -- dispatching policy name. If not give error and raise Pragma_Exit.
3552 procedure Check_Arg_Order (Names : Name_List);
3553 -- Checks for an instance of two arguments with identifiers for the
3554 -- current pragma which are not in the sequence indicated by Names,
3555 -- and if so, generates a fatal message about bad order of arguments.
3557 procedure Check_At_Least_N_Arguments (N : Nat);
3558 -- Check there are at least N arguments present
3560 procedure Check_At_Most_N_Arguments (N : Nat);
3561 -- Check there are no more than N arguments present
3563 procedure Check_Component
3566 In_Variant_Part : Boolean := False);
3567 -- Examine an Unchecked_Union component for correct use of per-object
3568 -- constrained subtypes, and for restrictions on finalizable components.
3569 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3570 -- should be set when Comp comes from a record variant.
3572 procedure Check_Duplicate_Pragma (E : Entity_Id);
3573 -- Check if a rep item of the same name as the current pragma is already
3574 -- chained as a rep pragma to the given entity. If so give a message
3575 -- about the duplicate, and then raise Pragma_Exit so does not return.
3576 -- Note that if E is a type, then this routine avoids flagging a pragma
3577 -- which applies to a parent type from which E is derived.
3579 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3580 -- Nam is an N_String_Literal node containing the external name set by
3581 -- an Import or Export pragma (or extended Import or Export pragma).
3582 -- This procedure checks for possible duplications if this is the export
3583 -- case, and if found, issues an appropriate error message.
3585 procedure Check_Expr_Is_OK_Static_Expression
3587 Typ : Entity_Id := Empty);
3588 -- Check the specified expression Expr 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 expression does not raise Constraint_Error.
3595 procedure Check_First_Subtype (Arg : Node_Id);
3596 -- Checks that Arg, whose expression is an entity name, references a
3599 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3600 -- Checks that the given argument has an identifier, and if so, requires
3601 -- it to match the given identifier name. If there is no identifier, or
3602 -- a non-matching identifier, then an error message is given and
3603 -- Pragma_Exit is raised.
3605 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3606 -- Checks that the given argument has an identifier, and if so, requires
3607 -- it to match one of the given identifier names. If there is no
3608 -- identifier, or a non-matching identifier, then an error message is
3609 -- given and Pragma_Exit is raised.
3611 procedure Check_In_Main_Program;
3612 -- Common checks for pragmas that appear within a main program
3613 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3615 procedure Check_Interrupt_Or_Attach_Handler;
3616 -- Common processing for first argument of pragma Interrupt_Handler or
3617 -- pragma Attach_Handler.
3619 procedure Check_Loop_Pragma_Placement;
3620 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3621 -- appear immediately within a construct restricted to loops, and that
3622 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3624 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3625 -- Check that pragma appears in a declarative part, or in a package
3626 -- specification, i.e. that it does not occur in a statement sequence
3629 procedure Check_No_Identifier (Arg : Node_Id);
3630 -- Checks that the given argument does not have an identifier. If
3631 -- an identifier is present, then an error message is issued, and
3632 -- Pragma_Exit is raised.
3634 procedure Check_No_Identifiers;
3635 -- Checks that none of the arguments to the pragma has an identifier.
3636 -- If any argument has an identifier, then an error message is issued,
3637 -- and Pragma_Exit is raised.
3639 procedure Check_No_Link_Name;
3640 -- Checks that no link name is specified
3642 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3643 -- Checks if the given argument has an identifier, and if so, requires
3644 -- it to match the given identifier name. If there is a non-matching
3645 -- identifier, then an error message is given and Pragma_Exit is raised.
3647 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3648 -- Checks if the given argument has an identifier, and if so, requires
3649 -- it to match the given identifier name. If there is a non-matching
3650 -- identifier, then an error message is given and Pragma_Exit is raised.
3651 -- In this version of the procedure, the identifier name is given as
3652 -- a string with lower case letters.
3654 procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3655 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3656 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3657 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3658 -- is an OK static boolean expression. Emit an error if this is not the
3661 procedure Check_Static_Constraint (Constr : Node_Id);
3662 -- Constr is a constraint from an N_Subtype_Indication node from a
3663 -- component constraint in an Unchecked_Union type. This routine checks
3664 -- that the constraint is static as required by the restrictions for
3667 procedure Check_Valid_Configuration_Pragma;
3668 -- Legality checks for placement of a configuration pragma
3670 procedure Check_Valid_Library_Unit_Pragma;
3671 -- Legality checks for library unit pragmas. A special case arises for
3672 -- pragmas in generic instances that come from copies of the original
3673 -- library unit pragmas in the generic templates. In the case of other
3674 -- than library level instantiations these can appear in contexts which
3675 -- would normally be invalid (they only apply to the original template
3676 -- and to library level instantiations), and they are simply ignored,
3677 -- which is implemented by rewriting them as null statements.
3679 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3680 -- Check an Unchecked_Union variant for lack of nested variants and
3681 -- presence of at least one component. UU_Typ is the related Unchecked_
3684 procedure Ensure_Aggregate_Form (Arg : Node_Id);
3685 -- Subsidiary routine to the processing of pragmas Abstract_State,
3686 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3687 -- Refined_Global and Refined_State. Transform argument Arg into
3688 -- an aggregate if not one already. N_Null is never transformed.
3689 -- Arg may denote an aspect specification or a pragma argument
3692 procedure Error_Pragma (Msg : String);
3693 pragma No_Return (Error_Pragma);
3694 -- Outputs error message for current pragma. The message contains a %
3695 -- that will be replaced with the pragma name, and the flag is placed
3696 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3697 -- calls Fix_Error (see spec of that procedure for details).
3699 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3700 pragma No_Return (Error_Pragma_Arg);
3701 -- Outputs error message for current pragma. The message may contain
3702 -- a % that will be replaced with the pragma name. The parameter Arg
3703 -- may either be a pragma argument association, in which case the flag
3704 -- is placed on the expression of this association, or an expression,
3705 -- in which case the flag is placed directly on the expression. The
3706 -- message is placed using Error_Msg_N, so the message may also contain
3707 -- an & insertion character which will reference the given Arg value.
3708 -- After placing the message, Pragma_Exit is raised. Note: this routine
3709 -- calls Fix_Error (see spec of that procedure for details).
3711 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3712 pragma No_Return (Error_Pragma_Arg);
3713 -- Similar to above form of Error_Pragma_Arg except that two messages
3714 -- are provided, the second is a continuation comment starting with \.
3716 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3717 pragma No_Return (Error_Pragma_Arg_Ident);
3718 -- Outputs error message for current pragma. The message may contain a %
3719 -- that will be replaced with the pragma name. The parameter Arg must be
3720 -- a pragma argument association with a non-empty identifier (i.e. its
3721 -- Chars field must be set), and the error message is placed on the
3722 -- identifier. The message is placed using Error_Msg_N so the message
3723 -- may also contain an & insertion character which will reference
3724 -- the identifier. After placing the message, Pragma_Exit is raised.
3725 -- Note: this routine calls Fix_Error (see spec of that procedure for
3728 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3729 pragma No_Return (Error_Pragma_Ref);
3730 -- Outputs error message for current pragma. The message may contain
3731 -- a % that will be replaced with the pragma name. The parameter Ref
3732 -- must be an entity whose name can be referenced by & and sloc by #.
3733 -- After placing the message, Pragma_Exit is raised. Note: this routine
3734 -- calls Fix_Error (see spec of that procedure for details).
3736 function Find_Lib_Unit_Name return Entity_Id;
3737 -- Used for a library unit pragma to find the entity to which the
3738 -- library unit pragma applies, returns the entity found.
3740 procedure Find_Program_Unit_Name (Id : Node_Id);
3741 -- If the pragma is a compilation unit pragma, the id must denote the
3742 -- compilation unit in the same compilation, and the pragma must appear
3743 -- in the list of preceding or trailing pragmas. If it is a program
3744 -- unit pragma that is not a compilation unit pragma, then the
3745 -- identifier must be visible.
3747 function Find_Unique_Parameterless_Procedure
3749 Arg : Node_Id) return Entity_Id;
3750 -- Used for a procedure pragma to find the unique parameterless
3751 -- procedure identified by Name, returns it if it exists, otherwise
3752 -- errors out and uses Arg as the pragma argument for the message.
3754 function Fix_Error (Msg : String) return String;
3755 -- This is called prior to issuing an error message. Msg is the normal
3756 -- error message issued in the pragma case. This routine checks for the
3757 -- case of a pragma coming from an aspect in the source, and returns a
3758 -- message suitable for the aspect case as follows:
3760 -- Each substring "pragma" is replaced by "aspect"
3762 -- If "argument of" is at the start of the error message text, it is
3763 -- replaced by "entity for".
3765 -- If "argument" is at the start of the error message text, it is
3766 -- replaced by "entity".
3768 -- So for example, "argument of pragma X must be discrete type"
3769 -- returns "entity for aspect X must be a discrete type".
3771 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3772 -- be different from the pragma name). If the current pragma results
3773 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3774 -- original pragma name.
3776 procedure Gather_Associations
3778 Args : out Args_List);
3779 -- This procedure is used to gather the arguments for a pragma that
3780 -- permits arbitrary ordering of parameters using the normal rules
3781 -- for named and positional parameters. The Names argument is a list
3782 -- of Name_Id values that corresponds to the allowed pragma argument
3783 -- association identifiers in order. The result returned in Args is
3784 -- a list of corresponding expressions that are the pragma arguments.
3785 -- Note that this is a list of expressions, not of pragma argument
3786 -- associations (Gather_Associations has completely checked all the
3787 -- optional identifiers when it returns). An entry in Args is Empty
3788 -- on return if the corresponding argument is not present.
3790 procedure GNAT_Pragma;
3791 -- Called for all GNAT defined pragmas to check the relevant restriction
3792 -- (No_Implementation_Pragmas).
3794 function Is_Before_First_Decl
3795 (Pragma_Node : Node_Id;
3796 Decls : List_Id) return Boolean;
3797 -- Return True if Pragma_Node is before the first declarative item in
3798 -- Decls where Decls is the list of declarative items.
3800 function Is_Configuration_Pragma return Boolean;
3801 -- Determines if the placement of the current pragma is appropriate
3802 -- for a configuration pragma.
3804 function Is_In_Context_Clause return Boolean;
3805 -- Returns True if pragma appears within the context clause of a unit,
3806 -- and False for any other placement (does not generate any messages).
3808 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3809 -- Analyzes the argument, and determines if it is a static string
3810 -- expression, returns True if so, False if non-static or not String.
3811 -- A special case is that a string literal returns True in Ada 83 mode
3812 -- (which has no such thing as static string expressions). Note that
3813 -- the call analyzes its argument, so this cannot be used for the case
3814 -- where an identifier might not be declared.
3816 procedure Pragma_Misplaced;
3817 pragma No_Return (Pragma_Misplaced);
3818 -- Issue fatal error message for misplaced pragma
3820 procedure Process_Atomic_Independent_Shared_Volatile;
3821 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3822 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3823 -- and treated as being identical in effect to pragma Atomic.
3825 procedure Process_Compile_Time_Warning_Or_Error;
3826 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3828 procedure Process_Convention
3829 (C : out Convention_Id;
3830 Ent : out Entity_Id);
3831 -- Common processing for Convention, Interface, Import and Export.
3832 -- Checks first two arguments of pragma, and sets the appropriate
3833 -- convention value in the specified entity or entities. On return
3834 -- C is the convention, Ent is the referenced entity.
3836 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3837 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3838 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3840 procedure Process_Extended_Import_Export_Object_Pragma
3841 (Arg_Internal : Node_Id;
3842 Arg_External : Node_Id;
3843 Arg_Size : Node_Id);
3844 -- Common processing for the pragmas Import/Export_Object. The three
3845 -- arguments correspond to the three named parameters of the pragmas. An
3846 -- argument is empty if the corresponding parameter is not present in
3849 procedure Process_Extended_Import_Export_Internal_Arg
3850 (Arg_Internal : Node_Id := Empty);
3851 -- Common processing for all extended Import and Export pragmas. The
3852 -- argument is the pragma parameter for the Internal argument. If
3853 -- Arg_Internal is empty or inappropriate, an error message is posted.
3854 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3855 -- set to identify the referenced entity.
3857 procedure Process_Extended_Import_Export_Subprogram_Pragma
3858 (Arg_Internal : Node_Id;
3859 Arg_External : Node_Id;
3860 Arg_Parameter_Types : Node_Id;
3861 Arg_Result_Type : Node_Id := Empty;
3862 Arg_Mechanism : Node_Id;
3863 Arg_Result_Mechanism : Node_Id := Empty);
3864 -- Common processing for all extended Import and Export pragmas applying
3865 -- to subprograms. The caller omits any arguments that do not apply to
3866 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3867 -- only in the Import_Function and Export_Function cases). The argument
3868 -- names correspond to the allowed pragma association identifiers.
3870 procedure Process_Generic_List;
3871 -- Common processing for Share_Generic and Inline_Generic
3873 procedure Process_Import_Or_Interface;
3874 -- Common processing for Import or Interface
3876 procedure Process_Import_Predefined_Type;
3877 -- Processing for completing a type with pragma Import. This is used
3878 -- to declare types that match predefined C types, especially for cases
3879 -- without corresponding Ada predefined type.
3881 type Inline_Status is (Suppressed, Disabled, Enabled);
3882 -- Inline status of a subprogram, indicated as follows:
3883 -- Suppressed: inlining is suppressed for the subprogram
3884 -- Disabled: no inlining is requested for the subprogram
3885 -- Enabled: inlining is requested/required for the subprogram
3887 procedure Process_Inline (Status : Inline_Status);
3888 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3889 -- indicates the inline status specified by the pragma.
3891 procedure Process_Interface_Name
3892 (Subprogram_Def : Entity_Id;
3894 Link_Arg : Node_Id);
3895 -- Given the last two arguments of pragma Import, pragma Export, or
3896 -- pragma Interface_Name, performs validity checks and sets the
3897 -- Interface_Name field of the given subprogram entity to the
3898 -- appropriate external or link name, depending on the arguments given.
3899 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3900 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3901 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3902 -- nor Link_Arg is present, the interface name is set to the default
3903 -- from the subprogram name.
3905 procedure Process_Interrupt_Or_Attach_Handler;
3906 -- Common processing for Interrupt and Attach_Handler pragmas
3908 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3909 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3910 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3911 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3912 -- is not set in the Restrictions case.
3914 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3915 -- Common processing for Suppress and Unsuppress. The boolean parameter
3916 -- Suppress_Case is True for the Suppress case, and False for the
3919 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3920 -- Subsidiary to the analysis of pragmas Independent[_Components].
3921 -- Record such a pragma N applied to entity E for future checks.
3923 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3924 -- This procedure sets the Is_Exported flag for the given entity,
3925 -- checking that the entity was not previously imported. Arg is
3926 -- the argument that specified the entity. A check is also made
3927 -- for exporting inappropriate entities.
3929 procedure Set_Extended_Import_Export_External_Name
3930 (Internal_Ent : Entity_Id;
3931 Arg_External : Node_Id);
3932 -- Common processing for all extended import export pragmas. The first
3933 -- argument, Internal_Ent, is the internal entity, which has already
3934 -- been checked for validity by the caller. Arg_External is from the
3935 -- Import or Export pragma, and may be null if no External parameter
3936 -- was present. If Arg_External is present and is a non-null string
3937 -- (a null string is treated as the default), then the Interface_Name
3938 -- field of Internal_Ent is set appropriately.
3940 procedure Set_Imported (E : Entity_Id);
3941 -- This procedure sets the Is_Imported flag for the given entity,
3942 -- checking that it is not previously exported or imported.
3944 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3945 -- Mech is a parameter passing mechanism (see Import_Function syntax
3946 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3947 -- has the right form, and if not issues an error message. If the
3948 -- argument has the right form then the Mechanism field of Ent is
3949 -- set appropriately.
3951 procedure Set_Rational_Profile;
3952 -- Activate the set of configuration pragmas and permissions that make
3953 -- up the Rational profile.
3955 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
3956 -- Activate the set of configuration pragmas and restrictions that make
3957 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
3958 -- Ravenscar. N is the corresponding pragma node, which is used for
3959 -- error messages on any constructs violating the profile.
3961 ----------------------------------
3962 -- Acquire_Warning_Match_String --
3963 ----------------------------------
3965 procedure Acquire_Warning_Match_String (Arg : Node_Id) is
3967 String_To_Name_Buffer
3968 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
3970 -- Add asterisk at start if not already there
3972 if Name_Len > 0 and then Name_Buffer (1) /= '*' then
3973 Name_Buffer (2 .. Name_Len + 1) :=
3974 Name_Buffer (1 .. Name_Len);
3975 Name_Buffer (1) := '*';
3976 Name_Len := Name_Len + 1;
3979 -- Add asterisk at end if not already there
3981 if Name_Buffer (Name_Len) /= '*' then
3982 Name_Len := Name_Len + 1;
3983 Name_Buffer (Name_Len) := '*';
3985 end Acquire_Warning_Match_String;
3987 ---------------------
3988 -- Ada_2005_Pragma --
3989 ---------------------
3991 procedure Ada_2005_Pragma is
3993 if Ada_Version <= Ada_95 then
3994 Check_Restriction (No_Implementation_Pragmas, N);
3996 end Ada_2005_Pragma;
3998 ---------------------
3999 -- Ada_2012_Pragma --
4000 ---------------------
4002 procedure Ada_2012_Pragma is
4004 if Ada_Version <= Ada_2005 then
4005 Check_Restriction (No_Implementation_Pragmas, N);
4007 end Ada_2012_Pragma;
4009 ----------------------------
4010 -- Analyze_Depends_Global --
4011 ----------------------------
4013 procedure Analyze_Depends_Global
4014 (Spec_Id : out Entity_Id;
4015 Subp_Decl : out Node_Id;
4016 Legal : out Boolean)
4019 -- Assume that the pragma is illegal
4026 Check_Arg_Count (1);
4028 -- Ensure the proper placement of the pragma. Depends/Global must be
4029 -- associated with a subprogram declaration or a body that acts as a
4032 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4036 if Nkind (Subp_Decl) = N_Entry_Declaration then
4039 -- Generic subprogram
4041 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4044 -- Object declaration of a single concurrent type
4046 elsif Nkind (Subp_Decl) = N_Object_Declaration then
4051 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4054 -- Subprogram body acts as spec
4056 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4057 and then No (Corresponding_Spec (Subp_Decl))
4061 -- Subprogram body stub acts as spec
4063 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4064 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4068 -- Subprogram declaration
4070 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4075 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4083 -- If we get here, then the pragma is legal
4086 Spec_Id := Unique_Defining_Entity (Subp_Decl);
4088 -- When the related context is an entry, the entry must belong to a
4089 -- protected unit (SPARK RM 6.1.4(6)).
4091 if Is_Entry_Declaration (Spec_Id)
4092 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4097 -- When the related context is an anonymous object created for a
4098 -- simple concurrent type, the type must be a task
4099 -- (SPARK RM 6.1.4(6)).
4101 elsif Is_Single_Concurrent_Object (Spec_Id)
4102 and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4108 -- A pragma that applies to a Ghost entity becomes Ghost for the
4109 -- purposes of legality checks and removal of ignored Ghost code.
4111 Mark_Pragma_As_Ghost (N, Spec_Id);
4112 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4113 end Analyze_Depends_Global;
4115 ------------------------
4116 -- Analyze_If_Present --
4117 ------------------------
4119 procedure Analyze_If_Present (Id : Pragma_Id) is
4123 pragma Assert (Is_List_Member (N));
4125 -- Inspect the declarations or statements following pragma N looking
4126 -- for another pragma whose Id matches the caller's request. If it is
4127 -- available, analyze it.
4130 while Present (Stmt) loop
4131 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4132 Analyze_Pragma (Stmt);
4135 -- The first source declaration or statement immediately following
4136 -- N ends the region where a pragma may appear.
4138 elsif Comes_From_Source (Stmt) then
4144 end Analyze_If_Present;
4146 --------------------------------
4147 -- Analyze_Pre_Post_Condition --
4148 --------------------------------
4150 procedure Analyze_Pre_Post_Condition is
4151 Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4152 Subp_Decl : Node_Id;
4153 Subp_Id : Entity_Id;
4155 Duplicates_OK : Boolean := False;
4156 -- Flag set when a pre/postcondition allows multiple pragmas of the
4159 In_Body_OK : Boolean := False;
4160 -- Flag set when a pre/postcondition is allowed to appear on a body
4161 -- even though the subprogram may have a spec.
4163 Is_Pre_Post : Boolean := False;
4164 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4168 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4169 -- offer uniformity among the various kinds of pre/postconditions by
4170 -- rewriting the pragma identifier. This allows the retrieval of the
4171 -- original pragma name by routine Original_Aspect_Pragma_Name.
4173 if Comes_From_Source (N) then
4174 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4175 Is_Pre_Post := True;
4176 Set_Class_Present (N, Pname = Name_Pre_Class);
4177 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4179 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4180 Is_Pre_Post := True;
4181 Set_Class_Present (N, Pname = Name_Post_Class);
4182 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4186 -- Determine the semantics with respect to duplicates and placement
4187 -- in a body. Pragmas Precondition and Postcondition were introduced
4188 -- before aspects and are not subject to the same aspect-like rules.
4190 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4191 Duplicates_OK := True;
4197 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4198 -- argument without an identifier.
4201 Check_Arg_Count (1);
4202 Check_No_Identifiers;
4204 -- Pragmas Precondition and Postcondition have complex argument
4208 Check_At_Least_N_Arguments (1);
4209 Check_At_Most_N_Arguments (2);
4210 Check_Optional_Identifier (Arg1, Name_Check);
4212 if Present (Arg2) then
4213 Check_Optional_Identifier (Arg2, Name_Message);
4214 Preanalyze_Spec_Expression
4215 (Get_Pragma_Arg (Arg2), Standard_String);
4219 -- For a pragma PPC in the extended main source unit, record enabled
4221 -- ??? nothing checks that the pragma is in the main source unit
4223 if Is_Checked (N) and then not Split_PPC (N) then
4224 Set_SCO_Pragma_Enabled (Loc);
4227 -- Ensure the proper placement of the pragma
4230 Find_Related_Declaration_Or_Body
4231 (N, Do_Checks => not Duplicates_OK);
4233 -- When a pre/postcondition pragma applies to an abstract subprogram,
4234 -- its original form must be an aspect with 'Class.
4236 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4237 if not From_Aspect_Specification (N) then
4239 ("pragma % cannot be applied to abstract subprogram");
4241 elsif not Class_Present (N) then
4243 ("aspect % requires ''Class for abstract subprogram");
4246 -- Entry declaration
4248 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4251 -- Generic subprogram declaration
4253 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4258 elsif Nkind (Subp_Decl) = N_Subprogram_Body
4259 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4263 -- Subprogram body stub
4265 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4266 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4270 -- Subprogram declaration
4272 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4274 -- AI05-0230: When a pre/postcondition pragma applies to a null
4275 -- procedure, its original form must be an aspect with 'Class.
4277 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4278 and then Null_Present (Specification (Subp_Decl))
4279 and then From_Aspect_Specification (N)
4280 and then not Class_Present (N)
4282 Error_Pragma ("aspect % requires ''Class for null procedure");
4285 -- Otherwise the placement is illegal
4292 Subp_Id := Defining_Entity (Subp_Decl);
4294 -- Chain the pragma on the contract for further processing by
4295 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4297 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4299 -- A pragma that applies to a Ghost entity becomes Ghost for the
4300 -- purposes of legality checks and removal of ignored Ghost code.
4302 Mark_Pragma_As_Ghost (N, Subp_Id);
4304 -- Fully analyze the pragma when it appears inside an entry or
4305 -- subprogram body because it cannot benefit from forward references.
4307 if Nkind_In (Subp_Decl, N_Entry_Body,
4309 N_Subprogram_Body_Stub)
4311 -- The legality checks of pragmas Precondition and Postcondition
4312 -- are affected by the SPARK mode in effect and the volatility of
4313 -- the context. Analyze all pragmas in a specific order.
4315 Analyze_If_Present (Pragma_SPARK_Mode);
4316 Analyze_If_Present (Pragma_Volatile_Function);
4317 Analyze_Pre_Post_Condition_In_Decl_Part (N);
4319 end Analyze_Pre_Post_Condition;
4321 -----------------------------------------
4322 -- Analyze_Refined_Depends_Global_Post --
4323 -----------------------------------------
4325 procedure Analyze_Refined_Depends_Global_Post
4326 (Spec_Id : out Entity_Id;
4327 Body_Id : out Entity_Id;
4328 Legal : out Boolean)
4330 Body_Decl : Node_Id;
4331 Spec_Decl : Node_Id;
4334 -- Assume that the pragma is illegal
4341 Check_Arg_Count (1);
4342 Check_No_Identifiers;
4344 -- Verify the placement of the pragma and check for duplicates. The
4345 -- pragma must apply to a subprogram body [stub].
4347 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4351 if Nkind (Body_Decl) = N_Entry_Body then
4356 elsif Nkind (Body_Decl) = N_Subprogram_Body then
4359 -- Subprogram body stub
4361 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4366 elsif Nkind (Body_Decl) = N_Task_Body then
4374 Body_Id := Defining_Entity (Body_Decl);
4375 Spec_Id := Unique_Defining_Entity (Body_Decl);
4377 -- The pragma must apply to the second declaration of a subprogram.
4378 -- In other words, the body [stub] cannot acts as a spec.
4380 if No (Spec_Id) then
4381 Error_Pragma ("pragma % cannot apply to a stand alone body");
4384 -- Catch the case where the subprogram body is a subunit and acts as
4385 -- the third declaration of the subprogram.
4387 elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4388 Error_Pragma ("pragma % cannot apply to a subunit");
4392 -- A refined pragma can only apply to the body [stub] of a subprogram
4393 -- declared in the visible part of a package. Retrieve the context of
4394 -- the subprogram declaration.
4396 Spec_Decl := Unit_Declaration_Node (Spec_Id);
4398 -- When dealing with protected entries or protected subprograms, use
4399 -- the enclosing protected type as the proper context.
4401 if Ekind_In (Spec_Id, E_Entry,
4405 and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4407 Spec_Decl := Declaration_Node (Scope (Spec_Id));
4410 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4412 (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4413 & "subprogram declared in a package specification"));
4417 -- If we get here, then the pragma is legal
4421 -- A pragma that applies to a Ghost entity becomes Ghost for the
4422 -- purposes of legality checks and removal of ignored Ghost code.
4424 Mark_Pragma_As_Ghost (N, Spec_Id);
4426 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4427 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4429 end Analyze_Refined_Depends_Global_Post;
4431 --------------------------
4432 -- Check_Ada_83_Warning --
4433 --------------------------
4435 procedure Check_Ada_83_Warning is
4437 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4438 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4440 end Check_Ada_83_Warning;
4442 ---------------------
4443 -- Check_Arg_Count --
4444 ---------------------
4446 procedure Check_Arg_Count (Required : Nat) is
4448 if Arg_Count /= Required then
4449 Error_Pragma ("wrong number of arguments for pragma%");
4451 end Check_Arg_Count;
4453 --------------------------------
4454 -- Check_Arg_Is_External_Name --
4455 --------------------------------
4457 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4458 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4461 if Nkind (Argx) = N_Identifier then
4465 Analyze_And_Resolve (Argx, Standard_String);
4467 if Is_OK_Static_Expression (Argx) then
4470 elsif Etype (Argx) = Any_Type then
4473 -- An interesting special case, if we have a string literal and
4474 -- we are in Ada 83 mode, then we allow it even though it will
4475 -- not be flagged as static. This allows expected Ada 83 mode
4476 -- use of external names which are string literals, even though
4477 -- technically these are not static in Ada 83.
4479 elsif Ada_Version = Ada_83
4480 and then Nkind (Argx) = N_String_Literal
4484 -- Static expression that raises Constraint_Error. This has
4485 -- already been flagged, so just exit from pragma processing.
4487 elsif Is_OK_Static_Expression (Argx) then
4490 -- Here we have a real error (non-static expression)
4493 Error_Msg_Name_1 := Pname;
4496 Msg : constant String :=
4497 "argument for pragma% must be a identifier or "
4498 & "static string expression!";
4500 Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4505 end Check_Arg_Is_External_Name;
4507 -----------------------------
4508 -- Check_Arg_Is_Identifier --
4509 -----------------------------
4511 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4512 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4514 if Nkind (Argx) /= N_Identifier then
4516 ("argument for pragma% must be identifier", Argx);
4518 end Check_Arg_Is_Identifier;
4520 ----------------------------------
4521 -- Check_Arg_Is_Integer_Literal --
4522 ----------------------------------
4524 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4525 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4527 if Nkind (Argx) /= N_Integer_Literal then
4529 ("argument for pragma% must be integer literal", Argx);
4531 end Check_Arg_Is_Integer_Literal;
4533 -------------------------------------------
4534 -- Check_Arg_Is_Library_Level_Local_Name --
4535 -------------------------------------------
4539 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4540 -- | library_unit_NAME
4542 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4544 Check_Arg_Is_Local_Name (Arg);
4546 -- If it came from an aspect, we want to give the error just as if it
4547 -- came from source.
4549 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4550 and then (Comes_From_Source (N)
4551 or else Present (Corresponding_Aspect (Parent (Arg))))
4554 ("argument for pragma% must be library level entity", Arg);
4556 end Check_Arg_Is_Library_Level_Local_Name;
4558 -----------------------------
4559 -- Check_Arg_Is_Local_Name --
4560 -----------------------------
4564 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4565 -- | library_unit_NAME
4567 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4568 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4571 -- If this pragma came from an aspect specification, we don't want to
4572 -- check for this error, because that would cause spurious errors, in
4573 -- case a type is frozen in a scope more nested than the type. The
4574 -- aspect itself of course can't be anywhere but on the declaration
4577 if Nkind (Arg) = N_Pragma_Argument_Association then
4578 if From_Aspect_Specification (Parent (Arg)) then
4582 -- Arg is the Expression of an N_Pragma_Argument_Association
4585 if From_Aspect_Specification (Parent (Parent (Arg))) then
4592 if Nkind (Argx) not in N_Direct_Name
4593 and then (Nkind (Argx) /= N_Attribute_Reference
4594 or else Present (Expressions (Argx))
4595 or else Nkind (Prefix (Argx)) /= N_Identifier)
4596 and then (not Is_Entity_Name (Argx)
4597 or else not Is_Compilation_Unit (Entity (Argx)))
4599 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4602 -- No further check required if not an entity name
4604 if not Is_Entity_Name (Argx) then
4610 Ent : constant Entity_Id := Entity (Argx);
4611 Scop : constant Entity_Id := Scope (Ent);
4614 -- Case of a pragma applied to a compilation unit: pragma must
4615 -- occur immediately after the program unit in the compilation.
4617 if Is_Compilation_Unit (Ent) then
4619 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4622 -- Case of pragma placed immediately after spec
4624 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4627 -- Case of pragma placed immediately after body
4629 elsif Nkind (Decl) = N_Subprogram_Declaration
4630 and then Present (Corresponding_Body (Decl))
4634 (Parent (Unit_Declaration_Node
4635 (Corresponding_Body (Decl))));
4637 -- All other cases are illegal
4644 -- Special restricted placement rule from 10.2.1(11.8/2)
4646 elsif Is_Generic_Formal (Ent)
4647 and then Prag_Id = Pragma_Preelaborable_Initialization
4649 OK := List_Containing (N) =
4650 Generic_Formal_Declarations
4651 (Unit_Declaration_Node (Scop));
4653 -- If this is an aspect applied to a subprogram body, the
4654 -- pragma is inserted in its declarative part.
4656 elsif From_Aspect_Specification (N)
4657 and then Ent = Current_Scope
4659 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4663 -- If the aspect is a predicate (possibly others ???) and the
4664 -- context is a record type, this is a discriminant expression
4665 -- within a type declaration, that freezes the predicated
4668 elsif From_Aspect_Specification (N)
4669 and then Prag_Id = Pragma_Predicate
4670 and then Ekind (Current_Scope) = E_Record_Type
4671 and then Scop = Scope (Current_Scope)
4675 -- Default case, just check that the pragma occurs in the scope
4676 -- of the entity denoted by the name.
4679 OK := Current_Scope = Scop;
4684 ("pragma% argument must be in same declarative part", Arg);
4688 end Check_Arg_Is_Local_Name;
4690 ---------------------------------
4691 -- Check_Arg_Is_Locking_Policy --
4692 ---------------------------------
4694 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
4695 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4698 Check_Arg_Is_Identifier (Argx);
4700 if not Is_Locking_Policy_Name (Chars (Argx)) then
4701 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
4703 end Check_Arg_Is_Locking_Policy;
4705 -----------------------------------------------
4706 -- Check_Arg_Is_Partition_Elaboration_Policy --
4707 -----------------------------------------------
4709 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
4710 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4713 Check_Arg_Is_Identifier (Argx);
4715 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
4717 ("& is not a valid partition elaboration policy name", Argx);
4719 end Check_Arg_Is_Partition_Elaboration_Policy;
4721 -------------------------
4722 -- Check_Arg_Is_One_Of --
4723 -------------------------
4725 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
4726 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4729 Check_Arg_Is_Identifier (Argx);
4731 if not Nam_In (Chars (Argx), N1, N2) then
4732 Error_Msg_Name_2 := N1;
4733 Error_Msg_Name_3 := N2;
4734 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
4736 end Check_Arg_Is_One_Of;
4738 procedure Check_Arg_Is_One_Of
4740 N1, N2, N3 : Name_Id)
4742 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4745 Check_Arg_Is_Identifier (Argx);
4747 if not Nam_In (Chars (Argx), N1, N2, N3) then
4748 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4750 end Check_Arg_Is_One_Of;
4752 procedure Check_Arg_Is_One_Of
4754 N1, N2, N3, N4 : Name_Id)
4756 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4759 Check_Arg_Is_Identifier (Argx);
4761 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
4762 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4764 end Check_Arg_Is_One_Of;
4766 procedure Check_Arg_Is_One_Of
4768 N1, N2, N3, N4, N5 : Name_Id)
4770 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4773 Check_Arg_Is_Identifier (Argx);
4775 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
4776 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
4778 end Check_Arg_Is_One_Of;
4780 ---------------------------------
4781 -- Check_Arg_Is_Queuing_Policy --
4782 ---------------------------------
4784 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
4785 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4788 Check_Arg_Is_Identifier (Argx);
4790 if not Is_Queuing_Policy_Name (Chars (Argx)) then
4791 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
4793 end Check_Arg_Is_Queuing_Policy;
4795 ---------------------------------------
4796 -- Check_Arg_Is_OK_Static_Expression --
4797 ---------------------------------------
4799 procedure Check_Arg_Is_OK_Static_Expression
4801 Typ : Entity_Id := Empty)
4804 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
4805 end Check_Arg_Is_OK_Static_Expression;
4807 ------------------------------------------
4808 -- Check_Arg_Is_Task_Dispatching_Policy --
4809 ------------------------------------------
4811 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
4812 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4815 Check_Arg_Is_Identifier (Argx);
4817 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
4819 ("& is not an allowed task dispatching policy name", Argx);
4821 end Check_Arg_Is_Task_Dispatching_Policy;
4823 ---------------------
4824 -- Check_Arg_Order --
4825 ---------------------
4827 procedure Check_Arg_Order (Names : Name_List) is
4830 Highest_So_Far : Natural := 0;
4831 -- Highest index in Names seen do far
4835 for J in 1 .. Arg_Count loop
4836 if Chars (Arg) /= No_Name then
4837 for K in Names'Range loop
4838 if Chars (Arg) = Names (K) then
4839 if K < Highest_So_Far then
4840 Error_Msg_Name_1 := Pname;
4842 ("parameters out of order for pragma%", Arg);
4843 Error_Msg_Name_1 := Names (K);
4844 Error_Msg_Name_2 := Names (Highest_So_Far);
4845 Error_Msg_N ("\% must appear before %", Arg);
4849 Highest_So_Far := K;
4857 end Check_Arg_Order;
4859 --------------------------------
4860 -- Check_At_Least_N_Arguments --
4861 --------------------------------
4863 procedure Check_At_Least_N_Arguments (N : Nat) is
4865 if Arg_Count < N then
4866 Error_Pragma ("too few arguments for pragma%");
4868 end Check_At_Least_N_Arguments;
4870 -------------------------------
4871 -- Check_At_Most_N_Arguments --
4872 -------------------------------
4874 procedure Check_At_Most_N_Arguments (N : Nat) is
4877 if Arg_Count > N then
4879 for J in 1 .. N loop
4881 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
4884 end Check_At_Most_N_Arguments;
4886 ---------------------
4887 -- Check_Component --
4888 ---------------------
4890 procedure Check_Component
4893 In_Variant_Part : Boolean := False)
4895 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
4896 Sindic : constant Node_Id :=
4897 Subtype_Indication (Component_Definition (Comp));
4898 Typ : constant Entity_Id := Etype (Comp_Id);
4901 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4902 -- object constraint, then the component type shall be an Unchecked_
4905 if Nkind (Sindic) = N_Subtype_Indication
4906 and then Has_Per_Object_Constraint (Comp_Id)
4907 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
4910 ("component subtype subject to per-object constraint "
4911 & "must be an Unchecked_Union", Comp);
4913 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4914 -- the body of a generic unit, or within the body of any of its
4915 -- descendant library units, no part of the type of a component
4916 -- declared in a variant_part of the unchecked union type shall be of
4917 -- a formal private type or formal private extension declared within
4918 -- the formal part of the generic unit.
4920 elsif Ada_Version >= Ada_2012
4921 and then In_Generic_Body (UU_Typ)
4922 and then In_Variant_Part
4923 and then Is_Private_Type (Typ)
4924 and then Is_Generic_Type (Typ)
4927 ("component of unchecked union cannot be of generic type", Comp);
4929 elsif Needs_Finalization (Typ) then
4931 ("component of unchecked union cannot be controlled", Comp);
4933 elsif Has_Task (Typ) then
4935 ("component of unchecked union cannot have tasks", Comp);
4937 end Check_Component;
4939 ----------------------------
4940 -- Check_Duplicate_Pragma --
4941 ----------------------------
4943 procedure Check_Duplicate_Pragma (E : Entity_Id) is
4944 Id : Entity_Id := E;
4948 -- Nothing to do if this pragma comes from an aspect specification,
4949 -- since we could not be duplicating a pragma, and we dealt with the
4950 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4952 if From_Aspect_Specification (N) then
4956 -- Otherwise current pragma may duplicate previous pragma or a
4957 -- previously given aspect specification or attribute definition
4958 -- clause for the same pragma.
4960 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
4964 -- If the entity is a type, then we have to make sure that the
4965 -- ostensible duplicate is not for a parent type from which this
4969 if Nkind (P) = N_Pragma then
4971 Args : constant List_Id :=
4972 Pragma_Argument_Associations (P);
4975 and then Is_Entity_Name (Expression (First (Args)))
4976 and then Is_Type (Entity (Expression (First (Args))))
4977 and then Entity (Expression (First (Args))) /= E
4983 elsif Nkind (P) = N_Aspect_Specification
4984 and then Is_Type (Entity (P))
4985 and then Entity (P) /= E
4991 -- Here we have a definite duplicate
4993 Error_Msg_Name_1 := Pragma_Name (N);
4994 Error_Msg_Sloc := Sloc (P);
4996 -- For a single protected or a single task object, the error is
4997 -- issued on the original entity.
4999 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5000 Id := Defining_Identifier (Original_Node (Parent (Id)));
5003 if Nkind (P) = N_Aspect_Specification
5004 or else From_Aspect_Specification (P)
5006 Error_Msg_NE ("aspect% for & previously given#", N, Id);
5008 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5013 end Check_Duplicate_Pragma;
5015 ----------------------------------
5016 -- Check_Duplicated_Export_Name --
5017 ----------------------------------
5019 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5020 String_Val : constant String_Id := Strval (Nam);
5023 -- We are only interested in the export case, and in the case of
5024 -- generics, it is the instance, not the template, that is the
5025 -- problem (the template will generate a warning in any case).
5027 if not Inside_A_Generic
5028 and then (Prag_Id = Pragma_Export
5030 Prag_Id = Pragma_Export_Procedure
5032 Prag_Id = Pragma_Export_Valued_Procedure
5034 Prag_Id = Pragma_Export_Function)
5036 for J in Externals.First .. Externals.Last loop
5037 if String_Equal (String_Val, Strval (Externals.Table (J))) then
5038 Error_Msg_Sloc := Sloc (Externals.Table (J));
5039 Error_Msg_N ("external name duplicates name given#", Nam);
5044 Externals.Append (Nam);
5046 end Check_Duplicated_Export_Name;
5048 ----------------------------------------
5049 -- Check_Expr_Is_OK_Static_Expression --
5050 ----------------------------------------
5052 procedure Check_Expr_Is_OK_Static_Expression
5054 Typ : Entity_Id := Empty)
5057 if Present (Typ) then
5058 Analyze_And_Resolve (Expr, Typ);
5060 Analyze_And_Resolve (Expr);
5063 -- An expression cannot be considered static if its resolution failed
5064 -- or if it's erroneous. Stop the analysis of the related pragma.
5066 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5069 elsif Is_OK_Static_Expression (Expr) then
5072 -- An interesting special case, if we have a string literal and we
5073 -- are in Ada 83 mode, then we allow it even though it will not be
5074 -- flagged as static. This allows the use of Ada 95 pragmas like
5075 -- Import in Ada 83 mode. They will of course be flagged with
5076 -- warnings as usual, but will not cause errors.
5078 elsif Ada_Version = Ada_83
5079 and then Nkind (Expr) = N_String_Literal
5083 -- Finally, we have a real error
5086 Error_Msg_Name_1 := Pname;
5087 Flag_Non_Static_Expr
5088 (Fix_Error ("argument for pragma% must be a static expression!"),
5092 end Check_Expr_Is_OK_Static_Expression;
5094 -------------------------
5095 -- Check_First_Subtype --
5096 -------------------------
5098 procedure Check_First_Subtype (Arg : Node_Id) is
5099 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5100 Ent : constant Entity_Id := Entity (Argx);
5103 if Is_First_Subtype (Ent) then
5106 elsif Is_Type (Ent) then
5108 ("pragma% cannot apply to subtype", Argx);
5110 elsif Is_Object (Ent) then
5112 ("pragma% cannot apply to object, requires a type", Argx);
5116 ("pragma% cannot apply to&, requires a type", Argx);
5118 end Check_First_Subtype;
5120 ----------------------
5121 -- Check_Identifier --
5122 ----------------------
5124 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5127 and then Nkind (Arg) = N_Pragma_Argument_Association
5129 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5130 Error_Msg_Name_1 := Pname;
5131 Error_Msg_Name_2 := Id;
5132 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5136 end Check_Identifier;
5138 --------------------------------
5139 -- Check_Identifier_Is_One_Of --
5140 --------------------------------
5142 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5145 and then Nkind (Arg) = N_Pragma_Argument_Association
5147 if Chars (Arg) = No_Name then
5148 Error_Msg_Name_1 := Pname;
5149 Error_Msg_N ("pragma% argument expects an identifier", Arg);
5152 elsif Chars (Arg) /= N1
5153 and then Chars (Arg) /= N2
5155 Error_Msg_Name_1 := Pname;
5156 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5160 end Check_Identifier_Is_One_Of;
5162 ---------------------------
5163 -- Check_In_Main_Program --
5164 ---------------------------
5166 procedure Check_In_Main_Program is
5167 P : constant Node_Id := Parent (N);
5170 -- Must be in subprogram body
5172 if Nkind (P) /= N_Subprogram_Body then
5173 Error_Pragma ("% pragma allowed only in subprogram");
5175 -- Otherwise warn if obviously not main program
5177 elsif Present (Parameter_Specifications (Specification (P)))
5178 or else not Is_Compilation_Unit (Defining_Entity (P))
5180 Error_Msg_Name_1 := Pname;
5182 ("??pragma% is only effective in main program", N);
5184 end Check_In_Main_Program;
5186 ---------------------------------------
5187 -- Check_Interrupt_Or_Attach_Handler --
5188 ---------------------------------------
5190 procedure Check_Interrupt_Or_Attach_Handler is
5191 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5192 Handler_Proc, Proc_Scope : Entity_Id;
5197 if Prag_Id = Pragma_Interrupt_Handler then
5198 Check_Restriction (No_Dynamic_Attachment, N);
5201 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5202 Proc_Scope := Scope (Handler_Proc);
5204 if Ekind (Proc_Scope) /= E_Protected_Type then
5206 ("argument of pragma% must be protected procedure", Arg1);
5209 -- For pragma case (as opposed to access case), check placement.
5210 -- We don't need to do that for aspects, because we have the
5211 -- check that they aspect applies an appropriate procedure.
5213 if not From_Aspect_Specification (N)
5214 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5216 Error_Pragma ("pragma% must be in protected definition");
5219 if not Is_Library_Level_Entity (Proc_Scope) then
5221 ("argument for pragma% must be library level entity", Arg1);
5224 -- AI05-0033: A pragma cannot appear within a generic body, because
5225 -- instance can be in a nested scope. The check that protected type
5226 -- is itself a library-level declaration is done elsewhere.
5228 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5229 -- handle code prior to AI-0033. Analysis tools typically are not
5230 -- interested in this pragma in any case, so no need to worry too
5231 -- much about its placement.
5233 if Inside_A_Generic then
5234 if Ekind (Scope (Current_Scope)) = E_Generic_Package
5235 and then In_Package_Body (Scope (Current_Scope))
5236 and then not Relaxed_RM_Semantics
5238 Error_Pragma ("pragma% cannot be used inside a generic");
5241 end Check_Interrupt_Or_Attach_Handler;
5243 ---------------------------------
5244 -- Check_Loop_Pragma_Placement --
5245 ---------------------------------
5247 procedure Check_Loop_Pragma_Placement is
5248 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5249 -- Verify whether the current pragma is properly grouped with other
5250 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5251 -- related loop where the pragma appears.
5253 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5254 -- Determine whether an arbitrary statement Stmt denotes pragma
5255 -- Loop_Invariant or Loop_Variant.
5257 procedure Placement_Error (Constr : Node_Id);
5258 pragma No_Return (Placement_Error);
5259 -- Node Constr denotes the last loop restricted construct before we
5260 -- encountered an illegal relation between enclosing constructs. Emit
5261 -- an error depending on what Constr was.
5263 --------------------------------
5264 -- Check_Loop_Pragma_Grouping --
5265 --------------------------------
5267 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5268 Stop_Search : exception;
5269 -- This exception is used to terminate the recursive descent of
5270 -- routine Check_Grouping.
5272 procedure Check_Grouping (L : List_Id);
5273 -- Find the first group of pragmas in list L and if successful,
5274 -- ensure that the current pragma is part of that group. The
5275 -- routine raises Stop_Search once such a check is performed to
5276 -- halt the recursive descent.
5278 procedure Grouping_Error (Prag : Node_Id);
5279 pragma No_Return (Grouping_Error);
5280 -- Emit an error concerning the current pragma indicating that it
5281 -- should be placed after pragma Prag.
5283 --------------------
5284 -- Check_Grouping --
5285 --------------------
5287 procedure Check_Grouping (L : List_Id) is
5293 -- Inspect the list of declarations or statements looking for
5294 -- the first grouping of pragmas:
5297 -- pragma Loop_Invariant ...;
5298 -- pragma Loop_Variant ...;
5300 -- pragma Loop_Variant ...; -- current pragma
5302 -- If the current pragma is not in the grouping, then it must
5303 -- either appear in a different declarative or statement list
5304 -- or the construct at (1) is separating the pragma from the
5308 while Present (Stmt) loop
5310 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5311 -- inside a loop or a block housed inside a loop. Inspect
5312 -- the declarations and statements of the block as they may
5313 -- contain the first grouping.
5315 if Nkind (Stmt) = N_Block_Statement then
5316 HSS := Handled_Statement_Sequence (Stmt);
5318 Check_Grouping (Declarations (Stmt));
5320 if Present (HSS) then
5321 Check_Grouping (Statements (HSS));
5324 -- First pragma of the first topmost grouping has been found
5326 elsif Is_Loop_Pragma (Stmt) then
5328 -- The group and the current pragma are not in the same
5329 -- declarative or statement list.
5331 if List_Containing (Stmt) /= List_Containing (N) then
5332 Grouping_Error (Stmt);
5334 -- Try to reach the current pragma from the first pragma
5335 -- of the grouping while skipping other members:
5337 -- pragma Loop_Invariant ...; -- first pragma
5338 -- pragma Loop_Variant ...; -- member
5340 -- pragma Loop_Variant ...; -- current pragma
5343 while Present (Stmt) loop
5345 -- The current pragma is either the first pragma
5346 -- of the group or is a member of the group. Stop
5347 -- the search as the placement is legal.
5352 -- Skip group members, but keep track of the last
5353 -- pragma in the group.
5355 elsif Is_Loop_Pragma (Stmt) then
5358 -- Skip declarations and statements generated by
5359 -- the compiler during expansion.
5361 elsif not Comes_From_Source (Stmt) then
5364 -- A non-pragma is separating the group from the
5365 -- current pragma, the placement is illegal.
5368 Grouping_Error (Prag);
5374 -- If the traversal did not reach the current pragma,
5375 -- then the list must be malformed.
5377 raise Program_Error;
5385 --------------------
5386 -- Grouping_Error --
5387 --------------------
5389 procedure Grouping_Error (Prag : Node_Id) is
5391 Error_Msg_Sloc := Sloc (Prag);
5392 Error_Pragma ("pragma% must appear next to pragma#");
5395 -- Start of processing for Check_Loop_Pragma_Grouping
5398 -- Inspect the statements of the loop or nested blocks housed
5399 -- within to determine whether the current pragma is part of the
5400 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5402 Check_Grouping (Statements (Loop_Stmt));
5405 when Stop_Search => null;
5406 end Check_Loop_Pragma_Grouping;
5408 --------------------
5409 -- Is_Loop_Pragma --
5410 --------------------
5412 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5414 -- Inspect the original node as Loop_Invariant and Loop_Variant
5415 -- pragmas are rewritten to null when assertions are disabled.
5417 if Nkind (Original_Node (Stmt)) = N_Pragma then
5419 Nam_In (Pragma_Name (Original_Node (Stmt)),
5420 Name_Loop_Invariant,
5427 ---------------------
5428 -- Placement_Error --
5429 ---------------------
5431 procedure Placement_Error (Constr : Node_Id) is
5432 LA : constant String := " with Loop_Entry";
5435 if Prag_Id = Pragma_Assert then
5436 Error_Msg_String (1 .. LA'Length) := LA;
5437 Error_Msg_Strlen := LA'Length;
5439 Error_Msg_Strlen := 0;
5442 if Nkind (Constr) = N_Pragma then
5444 ("pragma %~ must appear immediately within the statements "
5448 ("block containing pragma %~ must appear immediately within "
5449 & "the statements of a loop", Constr);
5451 end Placement_Error;
5453 -- Local declarations
5458 -- Start of processing for Check_Loop_Pragma_Placement
5461 -- Check that pragma appears immediately within a loop statement,
5462 -- ignoring intervening block statements.
5466 while Present (Stmt) loop
5468 -- The pragma or previous block must appear immediately within the
5469 -- current block's declarative or statement part.
5471 if Nkind (Stmt) = N_Block_Statement then
5472 if (No (Declarations (Stmt))
5473 or else List_Containing (Prev) /= Declarations (Stmt))
5475 List_Containing (Prev) /=
5476 Statements (Handled_Statement_Sequence (Stmt))
5478 Placement_Error (Prev);
5481 -- Keep inspecting the parents because we are now within a
5482 -- chain of nested blocks.
5486 Stmt := Parent (Stmt);
5489 -- The pragma or previous block must appear immediately within the
5490 -- statements of the loop.
5492 elsif Nkind (Stmt) = N_Loop_Statement then
5493 if List_Containing (Prev) /= Statements (Stmt) then
5494 Placement_Error (Prev);
5497 -- Stop the traversal because we reached the innermost loop
5498 -- regardless of whether we encountered an error or not.
5502 -- Ignore a handled statement sequence. Note that this node may
5503 -- be related to a subprogram body in which case we will emit an
5504 -- error on the next iteration of the search.
5506 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5507 Stmt := Parent (Stmt);
5509 -- Any other statement breaks the chain from the pragma to the
5513 Placement_Error (Prev);
5518 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5519 -- grouped together with other such pragmas.
5521 if Is_Loop_Pragma (N) then
5523 -- The previous check should have located the related loop
5525 pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5526 Check_Loop_Pragma_Grouping (Stmt);
5528 end Check_Loop_Pragma_Placement;
5530 -------------------------------------------
5531 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5532 -------------------------------------------
5534 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5543 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5546 elsif Nkind_In (P, N_Package_Specification,
5551 -- Note: the following tests seem a little peculiar, because
5552 -- they test for bodies, but if we were in the statement part
5553 -- of the body, we would already have hit the handled statement
5554 -- sequence, so the only way we get here is by being in the
5555 -- declarative part of the body.
5557 elsif Nkind_In (P, N_Subprogram_Body,
5568 Error_Pragma ("pragma% is not in declarative part or package spec");
5569 end Check_Is_In_Decl_Part_Or_Package_Spec;
5571 -------------------------
5572 -- Check_No_Identifier --
5573 -------------------------
5575 procedure Check_No_Identifier (Arg : Node_Id) is
5577 if Nkind (Arg) = N_Pragma_Argument_Association
5578 and then Chars (Arg) /= No_Name
5580 Error_Pragma_Arg_Ident
5581 ("pragma% does not permit identifier& here", Arg);
5583 end Check_No_Identifier;
5585 --------------------------
5586 -- Check_No_Identifiers --
5587 --------------------------
5589 procedure Check_No_Identifiers is
5593 for J in 1 .. Arg_Count loop
5594 Check_No_Identifier (Arg_Node);
5597 end Check_No_Identifiers;
5599 ------------------------
5600 -- Check_No_Link_Name --
5601 ------------------------
5603 procedure Check_No_Link_Name is
5605 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5609 if Present (Arg4) then
5611 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5613 end Check_No_Link_Name;
5615 -------------------------------
5616 -- Check_Optional_Identifier --
5617 -------------------------------
5619 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5622 and then Nkind (Arg) = N_Pragma_Argument_Association
5623 and then Chars (Arg) /= No_Name
5625 if Chars (Arg) /= Id then
5626 Error_Msg_Name_1 := Pname;
5627 Error_Msg_Name_2 := Id;
5628 Error_Msg_N ("pragma% argument expects identifier%", Arg);
5632 end Check_Optional_Identifier;
5634 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5636 Name_Buffer (1 .. Id'Length) := Id;
5637 Name_Len := Id'Length;
5638 Check_Optional_Identifier (Arg, Name_Find);
5639 end Check_Optional_Identifier;
5641 -------------------------------------
5642 -- Check_Static_Boolean_Expression --
5643 -------------------------------------
5645 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5647 if Present (Expr) then
5648 Analyze_And_Resolve (Expr, Standard_Boolean);
5650 if not Is_OK_Static_Expression (Expr) then
5652 ("expression of pragma % must be static", Expr);
5655 end Check_Static_Boolean_Expression;
5657 -----------------------------
5658 -- Check_Static_Constraint --
5659 -----------------------------
5661 -- Note: for convenience in writing this procedure, in addition to
5662 -- the officially (i.e. by spec) allowed argument which is always a
5663 -- constraint, it also allows ranges and discriminant associations.
5664 -- Above is not clear ???
5666 procedure Check_Static_Constraint (Constr : Node_Id) is
5668 procedure Require_Static (E : Node_Id);
5669 -- Require given expression to be static expression
5671 --------------------
5672 -- Require_Static --
5673 --------------------
5675 procedure Require_Static (E : Node_Id) is
5677 if not Is_OK_Static_Expression (E) then
5678 Flag_Non_Static_Expr
5679 ("non-static constraint not allowed in Unchecked_Union!", E);
5684 -- Start of processing for Check_Static_Constraint
5687 case Nkind (Constr) is
5688 when N_Discriminant_Association =>
5689 Require_Static (Expression (Constr));
5692 Require_Static (Low_Bound (Constr));
5693 Require_Static (High_Bound (Constr));
5695 when N_Attribute_Reference =>
5696 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
5697 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
5699 when N_Range_Constraint =>
5700 Check_Static_Constraint (Range_Expression (Constr));
5702 when N_Index_Or_Discriminant_Constraint =>
5706 IDC := First (Constraints (Constr));
5707 while Present (IDC) loop
5708 Check_Static_Constraint (IDC);
5716 end Check_Static_Constraint;
5718 --------------------------------------
5719 -- Check_Valid_Configuration_Pragma --
5720 --------------------------------------
5722 -- A configuration pragma must appear in the context clause of a
5723 -- compilation unit, and only other pragmas may precede it. Note that
5724 -- the test also allows use in a configuration pragma file.
5726 procedure Check_Valid_Configuration_Pragma is
5728 if not Is_Configuration_Pragma then
5729 Error_Pragma ("incorrect placement for configuration pragma%");
5731 end Check_Valid_Configuration_Pragma;
5733 -------------------------------------
5734 -- Check_Valid_Library_Unit_Pragma --
5735 -------------------------------------
5737 procedure Check_Valid_Library_Unit_Pragma is
5739 Parent_Node : Node_Id;
5740 Unit_Name : Entity_Id;
5741 Unit_Kind : Node_Kind;
5742 Unit_Node : Node_Id;
5743 Sindex : Source_File_Index;
5746 if not Is_List_Member (N) then
5750 Plist := List_Containing (N);
5751 Parent_Node := Parent (Plist);
5753 if Parent_Node = Empty then
5756 -- Case of pragma appearing after a compilation unit. In this case
5757 -- it must have an argument with the corresponding name and must
5758 -- be part of the following pragmas of its parent.
5760 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
5761 if Plist /= Pragmas_After (Parent_Node) then
5764 elsif Arg_Count = 0 then
5766 ("argument required if outside compilation unit");
5769 Check_No_Identifiers;
5770 Check_Arg_Count (1);
5771 Unit_Node := Unit (Parent (Parent_Node));
5772 Unit_Kind := Nkind (Unit_Node);
5774 Analyze (Get_Pragma_Arg (Arg1));
5776 if Unit_Kind = N_Generic_Subprogram_Declaration
5777 or else Unit_Kind = N_Subprogram_Declaration
5779 Unit_Name := Defining_Entity (Unit_Node);
5781 elsif Unit_Kind in N_Generic_Instantiation then
5782 Unit_Name := Defining_Entity (Unit_Node);
5785 Unit_Name := Cunit_Entity (Current_Sem_Unit);
5788 if Chars (Unit_Name) /=
5789 Chars (Entity (Get_Pragma_Arg (Arg1)))
5792 ("pragma% argument is not current unit name", Arg1);
5795 if Ekind (Unit_Name) = E_Package
5796 and then Present (Renamed_Entity (Unit_Name))
5798 Error_Pragma ("pragma% not allowed for renamed package");
5802 -- Pragma appears other than after a compilation unit
5805 -- Here we check for the generic instantiation case and also
5806 -- for the case of processing a generic formal package. We
5807 -- detect these cases by noting that the Sloc on the node
5808 -- does not belong to the current compilation unit.
5810 Sindex := Source_Index (Current_Sem_Unit);
5812 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
5813 Rewrite (N, Make_Null_Statement (Loc));
5816 -- If before first declaration, the pragma applies to the
5817 -- enclosing unit, and the name if present must be this name.
5819 elsif Is_Before_First_Decl (N, Plist) then
5820 Unit_Node := Unit_Declaration_Node (Current_Scope);
5821 Unit_Kind := Nkind (Unit_Node);
5823 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
5826 elsif Unit_Kind = N_Subprogram_Body
5827 and then not Acts_As_Spec (Unit_Node)
5831 elsif Nkind (Parent_Node) = N_Package_Body then
5834 elsif Nkind (Parent_Node) = N_Package_Specification
5835 and then Plist = Private_Declarations (Parent_Node)
5839 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
5840 or else Nkind (Parent_Node) =
5841 N_Generic_Subprogram_Declaration)
5842 and then Plist = Generic_Formal_Declarations (Parent_Node)
5846 elsif Arg_Count > 0 then
5847 Analyze (Get_Pragma_Arg (Arg1));
5849 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
5851 ("name in pragma% must be enclosing unit", Arg1);
5854 -- It is legal to have no argument in this context
5860 -- Error if not before first declaration. This is because a
5861 -- library unit pragma argument must be the name of a library
5862 -- unit (RM 10.1.5(7)), but the only names permitted in this
5863 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5864 -- generic subprogram declarations or generic instantiations.
5868 ("pragma% misplaced, must be before first declaration");
5872 end Check_Valid_Library_Unit_Pragma;
5878 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
5879 Clist : constant Node_Id := Component_List (Variant);
5883 Comp := First (Component_Items (Clist));
5884 while Present (Comp) loop
5885 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
5890 ---------------------------
5891 -- Ensure_Aggregate_Form --
5892 ---------------------------
5894 procedure Ensure_Aggregate_Form (Arg : Node_Id) is
5895 CFSD : constant Boolean := Get_Comes_From_Source_Default;
5896 Expr : constant Node_Id := Expression (Arg);
5897 Loc : constant Source_Ptr := Sloc (Expr);
5898 Comps : List_Id := No_List;
5899 Exprs : List_Id := No_List;
5900 Nam : Name_Id := No_Name;
5901 Nam_Loc : Source_Ptr;
5904 -- The pragma argument is in positional form:
5906 -- pragma Depends (Nam => ...)
5910 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5911 -- argument association.
5913 if Nkind (Arg) = N_Pragma_Argument_Association then
5915 Nam_Loc := Sloc (Arg);
5917 -- Remove the pragma argument name as this will be captured in the
5920 Set_Chars (Arg, No_Name);
5923 -- The argument is already in aggregate form, but the presence of a
5924 -- name causes this to be interpreted as named association which in
5925 -- turn must be converted into an aggregate.
5927 -- pragma Global (In_Out => (A, B, C))
5931 -- pragma Global ((In_Out => (A, B, C)))
5933 -- aggregate aggregate
5935 if Nkind (Expr) = N_Aggregate then
5936 if Nam = No_Name then
5940 -- Do not transform a null argument into an aggregate as N_Null has
5941 -- special meaning in formal verification pragmas.
5943 elsif Nkind (Expr) = N_Null then
5947 -- Everything comes from source if the original comes from source
5949 Set_Comes_From_Source_Default (Comes_From_Source (Arg));
5951 -- Positional argument is transformed into an aggregate with an
5952 -- Expressions list.
5954 if Nam = No_Name then
5955 Exprs := New_List (Relocate_Node (Expr));
5957 -- An associative argument is transformed into an aggregate with
5958 -- Component_Associations.
5962 Make_Component_Association (Loc,
5963 Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
5964 Expression => Relocate_Node (Expr)));
5967 Set_Expression (Arg,
5968 Make_Aggregate (Loc,
5969 Component_Associations => Comps,
5970 Expressions => Exprs));
5972 -- Restore Comes_From_Source default
5974 Set_Comes_From_Source_Default (CFSD);
5975 end Ensure_Aggregate_Form;
5981 procedure Error_Pragma (Msg : String) is
5983 Error_Msg_Name_1 := Pname;
5984 Error_Msg_N (Fix_Error (Msg), N);
5988 ----------------------
5989 -- Error_Pragma_Arg --
5990 ----------------------
5992 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
5994 Error_Msg_Name_1 := Pname;
5995 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
5997 end Error_Pragma_Arg;
5999 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6001 Error_Msg_Name_1 := Pname;
6002 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6003 Error_Pragma_Arg (Msg2, Arg);
6004 end Error_Pragma_Arg;
6006 ----------------------------
6007 -- Error_Pragma_Arg_Ident --
6008 ----------------------------
6010 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6012 Error_Msg_Name_1 := Pname;
6013 Error_Msg_N (Fix_Error (Msg), Arg);
6015 end Error_Pragma_Arg_Ident;
6017 ----------------------
6018 -- Error_Pragma_Ref --
6019 ----------------------
6021 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6023 Error_Msg_Name_1 := Pname;
6024 Error_Msg_Sloc := Sloc (Ref);
6025 Error_Msg_NE (Fix_Error (Msg), N, Ref);
6027 end Error_Pragma_Ref;
6029 ------------------------
6030 -- Find_Lib_Unit_Name --
6031 ------------------------
6033 function Find_Lib_Unit_Name return Entity_Id is
6035 -- Return inner compilation unit entity, for case of nested
6036 -- categorization pragmas. This happens in generic unit.
6038 if Nkind (Parent (N)) = N_Package_Specification
6039 and then Defining_Entity (Parent (N)) /= Current_Scope
6041 return Defining_Entity (Parent (N));
6043 return Current_Scope;
6045 end Find_Lib_Unit_Name;
6047 ----------------------------
6048 -- Find_Program_Unit_Name --
6049 ----------------------------
6051 procedure Find_Program_Unit_Name (Id : Node_Id) is
6052 Unit_Name : Entity_Id;
6053 Unit_Kind : Node_Kind;
6054 P : constant Node_Id := Parent (N);
6057 if Nkind (P) = N_Compilation_Unit then
6058 Unit_Kind := Nkind (Unit (P));
6060 if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6061 N_Package_Declaration)
6062 or else Unit_Kind in N_Generic_Declaration
6064 Unit_Name := Defining_Entity (Unit (P));
6066 if Chars (Id) = Chars (Unit_Name) then
6067 Set_Entity (Id, Unit_Name);
6068 Set_Etype (Id, Etype (Unit_Name));
6070 Set_Etype (Id, Any_Type);
6072 ("cannot find program unit referenced by pragma%");
6076 Set_Etype (Id, Any_Type);
6077 Error_Pragma ("pragma% inapplicable to this unit");
6083 end Find_Program_Unit_Name;
6085 -----------------------------------------
6086 -- Find_Unique_Parameterless_Procedure --
6087 -----------------------------------------
6089 function Find_Unique_Parameterless_Procedure
6091 Arg : Node_Id) return Entity_Id
6093 Proc : Entity_Id := Empty;
6096 -- The body of this procedure needs some comments ???
6098 if not Is_Entity_Name (Name) then
6100 ("argument of pragma% must be entity name", Arg);
6102 elsif not Is_Overloaded (Name) then
6103 Proc := Entity (Name);
6105 if Ekind (Proc) /= E_Procedure
6106 or else Present (First_Formal (Proc))
6109 ("argument of pragma% must be parameterless procedure", Arg);
6114 Found : Boolean := False;
6116 Index : Interp_Index;
6119 Get_First_Interp (Name, Index, It);
6120 while Present (It.Nam) loop
6123 if Ekind (Proc) = E_Procedure
6124 and then No (First_Formal (Proc))
6128 Set_Entity (Name, Proc);
6129 Set_Is_Overloaded (Name, False);
6132 ("ambiguous handler name for pragma% ", Arg);
6136 Get_Next_Interp (Index, It);
6141 ("argument of pragma% must be parameterless procedure",
6144 Proc := Entity (Name);
6150 end Find_Unique_Parameterless_Procedure;
6156 function Fix_Error (Msg : String) return String is
6157 Res : String (Msg'Range) := Msg;
6158 Res_Last : Natural := Msg'Last;
6162 -- If we have a rewriting of another pragma, go to that pragma
6164 if Is_Rewrite_Substitution (N)
6165 and then Nkind (Original_Node (N)) = N_Pragma
6167 Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6170 -- Case where pragma comes from an aspect specification
6172 if From_Aspect_Specification (N) then
6174 -- Change appearence of "pragma" in message to "aspect"
6177 while J <= Res_Last - 5 loop
6178 if Res (J .. J + 5) = "pragma" then
6179 Res (J .. J + 5) := "aspect";
6187 -- Change "argument of" at start of message to "entity for"
6190 and then Res (Res'First .. Res'First + 10) = "argument of"
6192 Res (Res'First .. Res'First + 9) := "entity for";
6193 Res (Res'First + 10 .. Res_Last - 1) :=
6194 Res (Res'First + 11 .. Res_Last);
6195 Res_Last := Res_Last - 1;
6198 -- Change "argument" at start of message to "entity"
6201 and then Res (Res'First .. Res'First + 7) = "argument"
6203 Res (Res'First .. Res'First + 5) := "entity";
6204 Res (Res'First + 6 .. Res_Last - 2) :=
6205 Res (Res'First + 8 .. Res_Last);
6206 Res_Last := Res_Last - 2;
6209 -- Get name from corresponding aspect
6211 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6214 -- Return possibly modified message
6216 return Res (Res'First .. Res_Last);
6219 -------------------------
6220 -- Gather_Associations --
6221 -------------------------
6223 procedure Gather_Associations
6225 Args : out Args_List)
6230 -- Initialize all parameters to Empty
6232 for J in Args'Range loop
6236 -- That's all we have to do if there are no argument associations
6238 if No (Pragma_Argument_Associations (N)) then
6242 -- Otherwise first deal with any positional parameters present
6244 Arg := First (Pragma_Argument_Associations (N));
6245 for Index in Args'Range loop
6246 exit when No (Arg) or else Chars (Arg) /= No_Name;
6247 Args (Index) := Get_Pragma_Arg (Arg);
6251 -- Positional parameters all processed, if any left, then we
6252 -- have too many positional parameters.
6254 if Present (Arg) and then Chars (Arg) = No_Name then
6256 ("too many positional associations for pragma%", Arg);
6259 -- Process named parameters if any are present
6261 while Present (Arg) loop
6262 if Chars (Arg) = No_Name then
6264 ("positional association cannot follow named association",
6268 for Index in Names'Range loop
6269 if Names (Index) = Chars (Arg) then
6270 if Present (Args (Index)) then
6272 ("duplicate argument association for pragma%", Arg);
6274 Args (Index) := Get_Pragma_Arg (Arg);
6279 if Index = Names'Last then
6280 Error_Msg_Name_1 := Pname;
6281 Error_Msg_N ("pragma% does not allow & argument", Arg);
6283 -- Check for possible misspelling
6285 for Index1 in Names'Range loop
6286 if Is_Bad_Spelling_Of
6287 (Chars (Arg), Names (Index1))
6289 Error_Msg_Name_1 := Names (Index1);
6290 Error_Msg_N -- CODEFIX
6291 ("\possible misspelling of%", Arg);
6303 end Gather_Associations;
6309 procedure GNAT_Pragma is
6311 -- We need to check the No_Implementation_Pragmas restriction for
6312 -- the case of a pragma from source. Note that the case of aspects
6313 -- generating corresponding pragmas marks these pragmas as not being
6314 -- from source, so this test also catches that case.
6316 if Comes_From_Source (N) then
6317 Check_Restriction (No_Implementation_Pragmas, N);
6321 --------------------------
6322 -- Is_Before_First_Decl --
6323 --------------------------
6325 function Is_Before_First_Decl
6326 (Pragma_Node : Node_Id;
6327 Decls : List_Id) return Boolean
6329 Item : Node_Id := First (Decls);
6332 -- Only other pragmas can come before this pragma
6335 if No (Item) or else Nkind (Item) /= N_Pragma then
6338 elsif Item = Pragma_Node then
6344 end Is_Before_First_Decl;
6346 -----------------------------
6347 -- Is_Configuration_Pragma --
6348 -----------------------------
6350 -- A configuration pragma must appear in the context clause of a
6351 -- compilation unit, and only other pragmas may precede it. Note that
6352 -- the test below also permits use in a configuration pragma file.
6354 function Is_Configuration_Pragma return Boolean is
6355 Lis : constant List_Id := List_Containing (N);
6356 Par : constant Node_Id := Parent (N);
6360 -- If no parent, then we are in the configuration pragma file,
6361 -- so the placement is definitely appropriate.
6366 -- Otherwise we must be in the context clause of a compilation unit
6367 -- and the only thing allowed before us in the context list is more
6368 -- configuration pragmas.
6370 elsif Nkind (Par) = N_Compilation_Unit
6371 and then Context_Items (Par) = Lis
6378 elsif Nkind (Prg) /= N_Pragma then
6388 end Is_Configuration_Pragma;
6390 --------------------------
6391 -- Is_In_Context_Clause --
6392 --------------------------
6394 function Is_In_Context_Clause return Boolean is
6396 Parent_Node : Node_Id;
6399 if not Is_List_Member (N) then
6403 Plist := List_Containing (N);
6404 Parent_Node := Parent (Plist);
6406 if Parent_Node = Empty
6407 or else Nkind (Parent_Node) /= N_Compilation_Unit
6408 or else Context_Items (Parent_Node) /= Plist
6415 end Is_In_Context_Clause;
6417 ---------------------------------
6418 -- Is_Static_String_Expression --
6419 ---------------------------------
6421 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6422 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6423 Lit : constant Boolean := Nkind (Argx) = N_String_Literal;
6426 Analyze_And_Resolve (Argx);
6428 -- Special case Ada 83, where the expression will never be static,
6429 -- but we will return true if we had a string literal to start with.
6431 if Ada_Version = Ada_83 then
6434 -- Normal case, true only if we end up with a string literal that
6435 -- is marked as being the result of evaluating a static expression.
6438 return Is_OK_Static_Expression (Argx)
6439 and then Nkind (Argx) = N_String_Literal;
6442 end Is_Static_String_Expression;
6444 ----------------------
6445 -- Pragma_Misplaced --
6446 ----------------------
6448 procedure Pragma_Misplaced is
6450 Error_Pragma ("incorrect placement of pragma%");
6451 end Pragma_Misplaced;
6453 ------------------------------------------------
6454 -- Process_Atomic_Independent_Shared_Volatile --
6455 ------------------------------------------------
6457 procedure Process_Atomic_Independent_Shared_Volatile is
6458 procedure Set_Atomic_VFA (E : Entity_Id);
6459 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6460 -- no explicit alignment was given, set alignment to unknown, since
6461 -- back end knows what the alignment requirements are for atomic and
6462 -- full access arrays. Note: this is necessary for derived types.
6464 --------------------
6465 -- Set_Atomic_VFA --
6466 --------------------
6468 procedure Set_Atomic_VFA (E : Entity_Id) is
6470 if Prag_Id = Pragma_Volatile_Full_Access then
6471 Set_Is_Volatile_Full_Access (E);
6476 if not Has_Alignment_Clause (E) then
6477 Set_Alignment (E, Uint_0);
6487 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6490 Check_Ada_83_Warning;
6491 Check_No_Identifiers;
6492 Check_Arg_Count (1);
6493 Check_Arg_Is_Local_Name (Arg1);
6494 E_Arg := Get_Pragma_Arg (Arg1);
6496 if Etype (E_Arg) = Any_Type then
6500 E := Entity (E_Arg);
6501 Decl := Declaration_Node (E);
6503 -- A pragma that applies to a Ghost entity becomes Ghost for the
6504 -- purposes of legality checks and removal of ignored Ghost code.
6506 Mark_Pragma_As_Ghost (N, E);
6508 -- Check duplicate before we chain ourselves
6510 Check_Duplicate_Pragma (E);
6512 -- Check Atomic and VFA used together
6514 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6515 or else (Is_Volatile_Full_Access (E)
6516 and then (Prag_Id = Pragma_Atomic
6518 Prag_Id = Pragma_Shared))
6521 ("cannot have Volatile_Full_Access and Atomic for same entity");
6524 -- Check for applying VFA to an entity which has aliased component
6526 if Prag_Id = Pragma_Volatile_Full_Access then
6529 Aliased_Comp : Boolean := False;
6530 -- Set True if aliased component present
6533 if Is_Array_Type (Etype (E)) then
6534 Aliased_Comp := Has_Aliased_Components (Etype (E));
6536 -- Record case, too bad Has_Aliased_Components is not also
6537 -- set for records, should it be ???
6539 elsif Is_Record_Type (Etype (E)) then
6540 Comp := First_Component_Or_Discriminant (Etype (E));
6541 while Present (Comp) loop
6542 if Is_Aliased (Comp)
6543 or else Is_Aliased (Etype (Comp))
6545 Aliased_Comp := True;
6549 Next_Component_Or_Discriminant (Comp);
6553 if Aliased_Comp then
6555 ("cannot apply Volatile_Full_Access (aliased component "
6561 -- Now check appropriateness of the entity
6564 if Rep_Item_Too_Early (E, N)
6566 Rep_Item_Too_Late (E, N)
6570 Check_First_Subtype (Arg1);
6573 -- Attribute belongs on the base type. If the view of the type is
6574 -- currently private, it also belongs on the underlying type.
6576 if Prag_Id = Pragma_Atomic
6578 Prag_Id = Pragma_Shared
6580 Prag_Id = Pragma_Volatile_Full_Access
6583 Set_Atomic_VFA (Base_Type (E));
6584 Set_Atomic_VFA (Underlying_Type (E));
6587 -- Atomic/Shared/Volatile_Full_Access imply Independent
6589 if Prag_Id /= Pragma_Volatile then
6590 Set_Is_Independent (E);
6591 Set_Is_Independent (Base_Type (E));
6592 Set_Is_Independent (Underlying_Type (E));
6594 if Prag_Id = Pragma_Independent then
6595 Record_Independence_Check (N, Base_Type (E));
6599 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6601 if Prag_Id /= Pragma_Independent then
6602 Set_Is_Volatile (E);
6603 Set_Is_Volatile (Base_Type (E));
6604 Set_Is_Volatile (Underlying_Type (E));
6606 Set_Treat_As_Volatile (E);
6607 Set_Treat_As_Volatile (Underlying_Type (E));
6610 elsif Nkind (Decl) = N_Object_Declaration
6611 or else (Nkind (Decl) = N_Component_Declaration
6612 and then Original_Record_Component (E) = E)
6614 if Rep_Item_Too_Late (E, N) then
6618 if Prag_Id = Pragma_Atomic
6620 Prag_Id = Pragma_Shared
6622 Prag_Id = Pragma_Volatile_Full_Access
6624 if Prag_Id = Pragma_Volatile_Full_Access then
6625 Set_Is_Volatile_Full_Access (E);
6630 -- If the object declaration has an explicit initialization, a
6631 -- temporary may have to be created to hold the expression, to
6632 -- ensure that access to the object remain atomic.
6634 if Nkind (Parent (E)) = N_Object_Declaration
6635 and then Present (Expression (Parent (E)))
6637 Set_Has_Delayed_Freeze (E);
6641 -- Atomic/Shared/Volatile_Full_Access imply Independent
6643 if Prag_Id /= Pragma_Volatile then
6644 Set_Is_Independent (E);
6646 if Prag_Id = Pragma_Independent then
6647 Record_Independence_Check (N, E);
6651 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6653 if Prag_Id /= Pragma_Independent then
6654 Set_Is_Volatile (E);
6655 Set_Treat_As_Volatile (E);
6659 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6662 -- The following check is only relevant when SPARK_Mode is on as
6663 -- this is not a standard Ada legality rule. Pragma Volatile can
6664 -- only apply to a full type declaration or an object declaration
6665 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6666 -- untagged derived types that are rewritten as subtypes of their
6667 -- respective root types.
6670 and then Prag_Id = Pragma_Volatile
6672 not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
6673 N_Object_Declaration)
6676 ("argument of pragma % must denote a full type or object "
6677 & "declaration", Arg1);
6679 end Process_Atomic_Independent_Shared_Volatile;
6681 -------------------------------------------
6682 -- Process_Compile_Time_Warning_Or_Error --
6683 -------------------------------------------
6685 procedure Process_Compile_Time_Warning_Or_Error is
6686 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
6689 Check_Arg_Count (2);
6690 Check_No_Identifiers;
6691 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
6692 Analyze_And_Resolve (Arg1x, Standard_Boolean);
6694 if Compile_Time_Known_Value (Arg1x) then
6695 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
6697 Str : constant String_Id :=
6698 Strval (Get_Pragma_Arg (Arg2));
6699 Len : constant Nat := String_Length (Str);
6704 Cent : constant Entity_Id :=
6705 Cunit_Entity (Current_Sem_Unit);
6707 Force : constant Boolean :=
6708 Prag_Id = Pragma_Compile_Time_Warning
6710 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
6711 and then (Ekind (Cent) /= E_Package
6712 or else not In_Private_Part (Cent));
6713 -- Set True if this is the warning case, and we are in the
6714 -- visible part of a package spec, or in a subprogram spec,
6715 -- in which case we want to force the client to see the
6716 -- warning, even though it is not in the main unit.
6719 -- Loop through segments of message separated by line feeds.
6720 -- We output these segments as separate messages with
6721 -- continuation marks for all but the first.
6726 Error_Msg_Strlen := 0;
6728 -- Loop to copy characters from argument to error message
6732 exit when Ptr > Len;
6733 CC := Get_String_Char (Str, Ptr);
6736 -- Ignore wide chars ??? else store character
6738 if In_Character_Range (CC) then
6739 C := Get_Character (CC);
6740 exit when C = ASCII.LF;
6741 Error_Msg_Strlen := Error_Msg_Strlen + 1;
6742 Error_Msg_String (Error_Msg_Strlen) := C;
6746 -- Here with one line ready to go
6748 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
6750 -- If this is a warning in a spec, then we want clients
6751 -- to see the warning, so mark the message with the
6752 -- special sequence !! to force the warning. In the case
6753 -- of a package spec, we do not force this if we are in
6754 -- the private part of the spec.
6757 if Cont = False then
6758 Error_Msg_N ("<<~!!", Arg1);
6761 Error_Msg_N ("\<<~!!", Arg1);
6764 -- Error, rather than warning, or in a body, so we do not
6765 -- need to force visibility for client (error will be
6766 -- output in any case, and this is the situation in which
6767 -- we do not want a client to get a warning, since the
6768 -- warning is in the body or the spec private part).
6771 if Cont = False then
6772 Error_Msg_N ("<<~", Arg1);
6775 Error_Msg_N ("\<<~", Arg1);
6779 exit when Ptr > Len;
6784 end Process_Compile_Time_Warning_Or_Error;
6786 ------------------------
6787 -- Process_Convention --
6788 ------------------------
6790 procedure Process_Convention
6791 (C : out Convention_Id;
6792 Ent : out Entity_Id)
6796 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
6797 -- Called if we have more than one Export/Import/Convention pragma.
6798 -- This is generally illegal, but we have a special case of allowing
6799 -- Import and Interface to coexist if they specify the convention in
6800 -- a consistent manner. We are allowed to do this, since Interface is
6801 -- an implementation defined pragma, and we choose to do it since we
6802 -- know Rational allows this combination. S is the entity id of the
6803 -- subprogram in question. This procedure also sets the special flag
6804 -- Import_Interface_Present in both pragmas in the case where we do
6805 -- have matching Import and Interface pragmas.
6807 procedure Set_Convention_From_Pragma (E : Entity_Id);
6808 -- Set convention in entity E, and also flag that the entity has a
6809 -- convention pragma. If entity is for a private or incomplete type,
6810 -- also set convention and flag on underlying type. This procedure
6811 -- also deals with the special case of C_Pass_By_Copy convention,
6812 -- and error checks for inappropriate convention specification.
6814 -------------------------------
6815 -- Diagnose_Multiple_Pragmas --
6816 -------------------------------
6818 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
6819 Pdec : constant Node_Id := Declaration_Node (S);
6823 function Same_Convention (Decl : Node_Id) return Boolean;
6824 -- Decl is a pragma node. This function returns True if this
6825 -- pragma has a first argument that is an identifier with a
6826 -- Chars field corresponding to the Convention_Id C.
6828 function Same_Name (Decl : Node_Id) return Boolean;
6829 -- Decl is a pragma node. This function returns True if this
6830 -- pragma has a second argument that is an identifier with a
6831 -- Chars field that matches the Chars of the current subprogram.
6833 ---------------------
6834 -- Same_Convention --
6835 ---------------------
6837 function Same_Convention (Decl : Node_Id) return Boolean is
6838 Arg1 : constant Node_Id :=
6839 First (Pragma_Argument_Associations (Decl));
6842 if Present (Arg1) then
6844 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
6846 if Nkind (Arg) = N_Identifier
6847 and then Is_Convention_Name (Chars (Arg))
6848 and then Get_Convention_Id (Chars (Arg)) = C
6856 end Same_Convention;
6862 function Same_Name (Decl : Node_Id) return Boolean is
6863 Arg1 : constant Node_Id :=
6864 First (Pragma_Argument_Associations (Decl));
6872 Arg2 := Next (Arg1);
6879 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
6881 if Nkind (Arg) = N_Identifier
6882 and then Chars (Arg) = Chars (S)
6891 -- Start of processing for Diagnose_Multiple_Pragmas
6896 -- Definitely give message if we have Convention/Export here
6898 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
6901 -- If we have an Import or Export, scan back from pragma to
6902 -- find any previous pragma applying to the same procedure.
6903 -- The scan will be terminated by the start of the list, or
6904 -- hitting the subprogram declaration. This won't allow one
6905 -- pragma to appear in the public part and one in the private
6906 -- part, but that seems very unlikely in practice.
6910 while Present (Decl) and then Decl /= Pdec loop
6912 -- Look for pragma with same name as us
6914 if Nkind (Decl) = N_Pragma
6915 and then Same_Name (Decl)
6917 -- Give error if same as our pragma or Export/Convention
6919 if Nam_In (Pragma_Name (Decl), Name_Export,
6925 -- Case of Import/Interface or the other way round
6927 elsif Nam_In (Pragma_Name (Decl), Name_Interface,
6930 -- Here we know that we have Import and Interface. It
6931 -- doesn't matter which way round they are. See if
6932 -- they specify the same convention. If so, all OK,
6933 -- and set special flags to stop other messages
6935 if Same_Convention (Decl) then
6936 Set_Import_Interface_Present (N);
6937 Set_Import_Interface_Present (Decl);
6940 -- If different conventions, special message
6943 Error_Msg_Sloc := Sloc (Decl);
6945 ("convention differs from that given#", Arg1);
6955 -- Give message if needed if we fall through those tests
6956 -- except on Relaxed_RM_Semantics where we let go: either this
6957 -- is a case accepted/ignored by other Ada compilers (e.g.
6958 -- a mix of Convention and Import), or another error will be
6959 -- generated later (e.g. using both Import and Export).
6961 if Err and not Relaxed_RM_Semantics then
6963 ("at most one Convention/Export/Import pragma is allowed",
6966 end Diagnose_Multiple_Pragmas;
6968 --------------------------------
6969 -- Set_Convention_From_Pragma --
6970 --------------------------------
6972 procedure Set_Convention_From_Pragma (E : Entity_Id) is
6974 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6975 -- for an overridden dispatching operation. Technically this is
6976 -- an amendment and should only be done in Ada 2005 mode. However,
6977 -- this is clearly a mistake, since the problem that is addressed
6978 -- by this AI is that there is a clear gap in the RM.
6980 if Is_Dispatching_Operation (E)
6981 and then Present (Overridden_Operation (E))
6982 and then C /= Convention (Overridden_Operation (E))
6985 ("cannot change convention for overridden dispatching "
6986 & "operation", Arg1);
6989 -- Special checks for Convention_Stdcall
6991 if C = Convention_Stdcall then
6993 -- A dispatching call is not allowed. A dispatching subprogram
6994 -- cannot be used to interface to the Win32 API, so in fact
6995 -- this check does not impose any effective restriction.
6997 if Is_Dispatching_Operation (E) then
6998 Error_Msg_Sloc := Sloc (E);
7000 -- Note: make this unconditional so that if there is more
7001 -- than one call to which the pragma applies, we get a
7002 -- message for each call. Also don't use Error_Pragma,
7003 -- so that we get multiple messages.
7006 ("dispatching subprogram# cannot use Stdcall convention!",
7009 -- Subprograms are not allowed
7011 elsif not Is_Subprogram_Or_Generic_Subprogram (E)
7015 and then Ekind (E) /= E_Variable
7017 -- An access to subprogram is also allowed
7021 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7023 -- Allow internal call to set convention of subprogram type
7025 and then not (Ekind (E) = E_Subprogram_Type)
7028 ("second argument of pragma% must be subprogram (type)",
7033 -- Set the convention
7035 Set_Convention (E, C);
7036 Set_Has_Convention_Pragma (E);
7038 -- For the case of a record base type, also set the convention of
7039 -- any anonymous access types declared in the record which do not
7040 -- currently have a specified convention.
7042 if Is_Record_Type (E) and then Is_Base_Type (E) then
7047 Comp := First_Component (E);
7048 while Present (Comp) loop
7049 if Present (Etype (Comp))
7050 and then Ekind_In (Etype (Comp),
7051 E_Anonymous_Access_Type,
7052 E_Anonymous_Access_Subprogram_Type)
7053 and then not Has_Convention_Pragma (Comp)
7055 Set_Convention (Comp, C);
7058 Next_Component (Comp);
7063 -- Deal with incomplete/private type case, where underlying type
7064 -- is available, so set convention of that underlying type.
7066 if Is_Incomplete_Or_Private_Type (E)
7067 and then Present (Underlying_Type (E))
7069 Set_Convention (Underlying_Type (E), C);
7070 Set_Has_Convention_Pragma (Underlying_Type (E), True);
7073 -- A class-wide type should inherit the convention of the specific
7074 -- root type (although this isn't specified clearly by the RM).
7076 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7077 Set_Convention (Class_Wide_Type (E), C);
7080 -- If the entity is a record type, then check for special case of
7081 -- C_Pass_By_Copy, which is treated the same as C except that the
7082 -- special record flag is set. This convention is only permitted
7083 -- on record types (see AI95-00131).
7085 if Cname = Name_C_Pass_By_Copy then
7086 if Is_Record_Type (E) then
7087 Set_C_Pass_By_Copy (Base_Type (E));
7088 elsif Is_Incomplete_Or_Private_Type (E)
7089 and then Is_Record_Type (Underlying_Type (E))
7091 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7094 ("C_Pass_By_Copy convention allowed only for record type",
7099 -- If the entity is a derived boolean type, check for the special
7100 -- case of convention C, C++, or Fortran, where we consider any
7101 -- nonzero value to represent true.
7103 if Is_Discrete_Type (E)
7104 and then Root_Type (Etype (E)) = Standard_Boolean
7110 C = Convention_Fortran)
7112 Set_Nonzero_Is_True (Base_Type (E));
7114 end Set_Convention_From_Pragma;
7118 Comp_Unit : Unit_Number_Type;
7123 -- Start of processing for Process_Convention
7126 Check_At_Least_N_Arguments (2);
7127 Check_Optional_Identifier (Arg1, Name_Convention);
7128 Check_Arg_Is_Identifier (Arg1);
7129 Cname := Chars (Get_Pragma_Arg (Arg1));
7131 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7132 -- tested again below to set the critical flag).
7134 if Cname = Name_C_Pass_By_Copy then
7137 -- Otherwise we must have something in the standard convention list
7139 elsif Is_Convention_Name (Cname) then
7140 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7142 -- Otherwise warn on unrecognized convention
7145 if Warn_On_Export_Import then
7147 ("??unrecognized convention name, C assumed",
7148 Get_Pragma_Arg (Arg1));
7154 Check_Optional_Identifier (Arg2, Name_Entity);
7155 Check_Arg_Is_Local_Name (Arg2);
7157 Id := Get_Pragma_Arg (Arg2);
7160 if not Is_Entity_Name (Id) then
7161 Error_Pragma_Arg ("entity name required", Arg2);
7166 -- Set entity to return
7170 -- Ada_Pass_By_Copy special checking
7172 if C = Convention_Ada_Pass_By_Copy then
7173 if not Is_First_Subtype (E) then
7175 ("convention `Ada_Pass_By_Copy` only allowed for types",
7179 if Is_By_Reference_Type (E) then
7181 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7185 -- Ada_Pass_By_Reference special checking
7187 elsif C = Convention_Ada_Pass_By_Reference then
7188 if not Is_First_Subtype (E) then
7190 ("convention `Ada_Pass_By_Reference` only allowed for types",
7194 if Is_By_Copy_Type (E) then
7196 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7201 -- Go to renamed subprogram if present, since convention applies to
7202 -- the actual renamed entity, not to the renaming entity. If the
7203 -- subprogram is inherited, go to parent subprogram.
7205 if Is_Subprogram (E)
7206 and then Present (Alias (E))
7208 if Nkind (Parent (Declaration_Node (E))) =
7209 N_Subprogram_Renaming_Declaration
7211 if Scope (E) /= Scope (Alias (E)) then
7213 ("cannot apply pragma% to non-local entity&#", E);
7218 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7219 N_Private_Extension_Declaration)
7220 and then Scope (E) = Scope (Alias (E))
7224 -- Return the parent subprogram the entity was inherited from
7230 -- Check that we are not applying this to a specless body. Relax this
7231 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7233 if Is_Subprogram (E)
7234 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7235 and then not Relaxed_RM_Semantics
7238 ("pragma% requires separate spec and must come before body");
7241 -- Check that we are not applying this to a named constant
7243 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7244 Error_Msg_Name_1 := Pname;
7246 ("cannot apply pragma% to named constant!",
7247 Get_Pragma_Arg (Arg2));
7249 ("\supply appropriate type for&!", Arg2);
7252 if Ekind (E) = E_Enumeration_Literal then
7253 Error_Pragma ("enumeration literal not allowed for pragma%");
7256 -- Check for rep item appearing too early or too late
7258 if Etype (E) = Any_Type
7259 or else Rep_Item_Too_Early (E, N)
7263 elsif Present (Underlying_Type (E)) then
7264 E := Underlying_Type (E);
7267 if Rep_Item_Too_Late (E, N) then
7271 if Has_Convention_Pragma (E) then
7272 Diagnose_Multiple_Pragmas (E);
7274 elsif Convention (E) = Convention_Protected
7275 or else Ekind (Scope (E)) = E_Protected_Type
7278 ("a protected operation cannot be given a different convention",
7282 -- For Intrinsic, a subprogram is required
7284 if C = Convention_Intrinsic
7285 and then not Is_Subprogram_Or_Generic_Subprogram (E)
7287 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7289 if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7291 ("second argument of pragma% must be a subprogram", Arg2);
7295 -- Deal with non-subprogram cases
7297 if not Is_Subprogram_Or_Generic_Subprogram (E) then
7298 Set_Convention_From_Pragma (E);
7302 -- The pragma must apply to a first subtype, but it can also
7303 -- apply to a generic type in a generic formal part, in which
7304 -- case it will also appear in the corresponding instance.
7306 if Is_Generic_Type (E) or else In_Instance then
7309 Check_First_Subtype (Arg2);
7312 Set_Convention_From_Pragma (Base_Type (E));
7314 -- For access subprograms, we must set the convention on the
7315 -- internally generated directly designated type as well.
7317 if Ekind (E) = E_Access_Subprogram_Type then
7318 Set_Convention_From_Pragma (Directly_Designated_Type (E));
7322 -- For the subprogram case, set proper convention for all homonyms
7323 -- in same scope and the same declarative part, i.e. the same
7324 -- compilation unit.
7327 Comp_Unit := Get_Source_Unit (E);
7328 Set_Convention_From_Pragma (E);
7330 -- Treat a pragma Import as an implicit body, and pragma import
7331 -- as implicit reference (for navigation in GPS).
7333 if Prag_Id = Pragma_Import then
7334 Generate_Reference (E, Id, 'b');
7336 -- For exported entities we restrict the generation of references
7337 -- to entities exported to foreign languages since entities
7338 -- exported to Ada do not provide further information to GPS and
7339 -- add undesired references to the output of the gnatxref tool.
7341 elsif Prag_Id = Pragma_Export
7342 and then Convention (E) /= Convention_Ada
7344 Generate_Reference (E, Id, 'i');
7347 -- If the pragma comes from an aspect, it only applies to the
7348 -- given entity, not its homonyms.
7350 if From_Aspect_Specification (N) then
7354 -- Otherwise Loop through the homonyms of the pragma argument's
7355 -- entity, an apply convention to those in the current scope.
7361 exit when No (E1) or else Scope (E1) /= Current_Scope;
7363 -- Ignore entry for which convention is already set
7365 if Has_Convention_Pragma (E1) then
7369 -- Do not set the pragma on inherited operations or on formal
7372 if Comes_From_Source (E1)
7373 and then Comp_Unit = Get_Source_Unit (E1)
7374 and then not Is_Formal_Subprogram (E1)
7375 and then Nkind (Original_Node (Parent (E1))) /=
7376 N_Full_Type_Declaration
7378 if Present (Alias (E1))
7379 and then Scope (E1) /= Scope (Alias (E1))
7382 ("cannot apply pragma% to non-local entity& declared#",
7386 Set_Convention_From_Pragma (E1);
7388 if Prag_Id = Pragma_Import then
7389 Generate_Reference (E1, Id, 'b');
7397 end Process_Convention;
7399 ----------------------------------------
7400 -- Process_Disable_Enable_Atomic_Sync --
7401 ----------------------------------------
7403 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7405 Check_No_Identifiers;
7406 Check_At_Most_N_Arguments (1);
7408 -- Modeled internally as
7409 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7413 Pragma_Identifier =>
7414 Make_Identifier (Loc, Nam),
7415 Pragma_Argument_Associations => New_List (
7416 Make_Pragma_Argument_Association (Loc,
7418 Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7420 if Present (Arg1) then
7421 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7425 end Process_Disable_Enable_Atomic_Sync;
7427 -------------------------------------------------
7428 -- Process_Extended_Import_Export_Internal_Arg --
7429 -------------------------------------------------
7431 procedure Process_Extended_Import_Export_Internal_Arg
7432 (Arg_Internal : Node_Id := Empty)
7435 if No (Arg_Internal) then
7436 Error_Pragma ("Internal parameter required for pragma%");
7439 if Nkind (Arg_Internal) = N_Identifier then
7442 elsif Nkind (Arg_Internal) = N_Operator_Symbol
7443 and then (Prag_Id = Pragma_Import_Function
7445 Prag_Id = Pragma_Export_Function)
7451 ("wrong form for Internal parameter for pragma%", Arg_Internal);
7454 Check_Arg_Is_Local_Name (Arg_Internal);
7455 end Process_Extended_Import_Export_Internal_Arg;
7457 --------------------------------------------------
7458 -- Process_Extended_Import_Export_Object_Pragma --
7459 --------------------------------------------------
7461 procedure Process_Extended_Import_Export_Object_Pragma
7462 (Arg_Internal : Node_Id;
7463 Arg_External : Node_Id;
7469 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7470 Def_Id := Entity (Arg_Internal);
7472 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7474 ("pragma% must designate an object", Arg_Internal);
7477 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7479 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7482 ("previous Common/Psect_Object applies, pragma % not permitted",
7486 if Rep_Item_Too_Late (Def_Id, N) then
7490 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7492 if Present (Arg_Size) then
7493 Check_Arg_Is_External_Name (Arg_Size);
7496 -- Export_Object case
7498 if Prag_Id = Pragma_Export_Object then
7499 if not Is_Library_Level_Entity (Def_Id) then
7501 ("argument for pragma% must be library level entity",
7505 if Ekind (Current_Scope) = E_Generic_Package then
7506 Error_Pragma ("pragma& cannot appear in a generic unit");
7509 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7511 ("exported object must have compile time known size",
7515 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7516 Error_Msg_N ("??duplicate Export_Object pragma", N);
7518 Set_Exported (Def_Id, Arg_Internal);
7521 -- Import_Object case
7524 if Is_Concurrent_Type (Etype (Def_Id)) then
7526 ("cannot use pragma% for task/protected object",
7530 if Ekind (Def_Id) = E_Constant then
7532 ("cannot import a constant", Arg_Internal);
7535 if Warn_On_Export_Import
7536 and then Has_Discriminants (Etype (Def_Id))
7539 ("imported value must be initialized??", Arg_Internal);
7542 if Warn_On_Export_Import
7543 and then Is_Access_Type (Etype (Def_Id))
7546 ("cannot import object of an access type??", Arg_Internal);
7549 if Warn_On_Export_Import
7550 and then Is_Imported (Def_Id)
7552 Error_Msg_N ("??duplicate Import_Object pragma", N);
7554 -- Check for explicit initialization present. Note that an
7555 -- initialization generated by the code generator, e.g. for an
7556 -- access type, does not count here.
7558 elsif Present (Expression (Parent (Def_Id)))
7561 (Original_Node (Expression (Parent (Def_Id))))
7563 Error_Msg_Sloc := Sloc (Def_Id);
7565 ("imported entities cannot be initialized (RM B.1(24))",
7566 "\no initialization allowed for & declared#", Arg1);
7568 Set_Imported (Def_Id);
7569 Note_Possible_Modification (Arg_Internal, Sure => False);
7572 end Process_Extended_Import_Export_Object_Pragma;
7574 ------------------------------------------------------
7575 -- Process_Extended_Import_Export_Subprogram_Pragma --
7576 ------------------------------------------------------
7578 procedure Process_Extended_Import_Export_Subprogram_Pragma
7579 (Arg_Internal : Node_Id;
7580 Arg_External : Node_Id;
7581 Arg_Parameter_Types : Node_Id;
7582 Arg_Result_Type : Node_Id := Empty;
7583 Arg_Mechanism : Node_Id;
7584 Arg_Result_Mechanism : Node_Id := Empty)
7590 Ambiguous : Boolean;
7593 function Same_Base_Type
7595 Formal : Entity_Id) return Boolean;
7596 -- Determines if Ptype references the type of Formal. Note that only
7597 -- the base types need to match according to the spec. Ptype here is
7598 -- the argument from the pragma, which is either a type name, or an
7599 -- access attribute.
7601 --------------------
7602 -- Same_Base_Type --
7603 --------------------
7605 function Same_Base_Type
7607 Formal : Entity_Id) return Boolean
7609 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7613 -- Case where pragma argument is typ'Access
7615 if Nkind (Ptype) = N_Attribute_Reference
7616 and then Attribute_Name (Ptype) = Name_Access
7618 Pref := Prefix (Ptype);
7621 if not Is_Entity_Name (Pref)
7622 or else Entity (Pref) = Any_Type
7627 -- We have a match if the corresponding argument is of an
7628 -- anonymous access type, and its designated type matches the
7629 -- type of the prefix of the access attribute
7631 return Ekind (Ftyp) = E_Anonymous_Access_Type
7632 and then Base_Type (Entity (Pref)) =
7633 Base_Type (Etype (Designated_Type (Ftyp)));
7635 -- Case where pragma argument is a type name
7640 if not Is_Entity_Name (Ptype)
7641 or else Entity (Ptype) = Any_Type
7646 -- We have a match if the corresponding argument is of the type
7647 -- given in the pragma (comparing base types)
7649 return Base_Type (Entity (Ptype)) = Ftyp;
7653 -- Start of processing for
7654 -- Process_Extended_Import_Export_Subprogram_Pragma
7657 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7661 -- Loop through homonyms (overloadings) of the entity
7663 Hom_Id := Entity (Arg_Internal);
7664 while Present (Hom_Id) loop
7665 Def_Id := Get_Base_Subprogram (Hom_Id);
7667 -- We need a subprogram in the current scope
7669 if not Is_Subprogram (Def_Id)
7670 or else Scope (Def_Id) /= Current_Scope
7677 -- Pragma cannot apply to subprogram body
7679 if Is_Subprogram (Def_Id)
7680 and then Nkind (Parent (Declaration_Node (Def_Id))) =
7684 ("pragma% requires separate spec"
7685 & " and must come before body");
7688 -- Test result type if given, note that the result type
7689 -- parameter can only be present for the function cases.
7691 if Present (Arg_Result_Type)
7692 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
7696 elsif Etype (Def_Id) /= Standard_Void_Type
7698 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
7702 -- Test parameter types if given. Note that this parameter
7703 -- has not been analyzed (and must not be, since it is
7704 -- semantic nonsense), so we get it as the parser left it.
7706 elsif Present (Arg_Parameter_Types) then
7707 Check_Matching_Types : declare
7712 Formal := First_Formal (Def_Id);
7714 if Nkind (Arg_Parameter_Types) = N_Null then
7715 if Present (Formal) then
7719 -- A list of one type, e.g. (List) is parsed as
7720 -- a parenthesized expression.
7722 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
7723 and then Paren_Count (Arg_Parameter_Types) = 1
7726 or else Present (Next_Formal (Formal))
7731 Same_Base_Type (Arg_Parameter_Types, Formal);
7734 -- A list of more than one type is parsed as a aggregate
7736 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
7737 and then Paren_Count (Arg_Parameter_Types) = 0
7739 Ptype := First (Expressions (Arg_Parameter_Types));
7740 while Present (Ptype) or else Present (Formal) loop
7743 or else not Same_Base_Type (Ptype, Formal)
7748 Next_Formal (Formal);
7753 -- Anything else is of the wrong form
7757 ("wrong form for Parameter_Types parameter",
7758 Arg_Parameter_Types);
7760 end Check_Matching_Types;
7763 -- Match is now False if the entry we found did not match
7764 -- either a supplied Parameter_Types or Result_Types argument
7770 -- Ambiguous case, the flag Ambiguous shows if we already
7771 -- detected this and output the initial messages.
7774 if not Ambiguous then
7776 Error_Msg_Name_1 := Pname;
7778 ("pragma% does not uniquely identify subprogram!",
7780 Error_Msg_Sloc := Sloc (Ent);
7781 Error_Msg_N ("matching subprogram #!", N);
7785 Error_Msg_Sloc := Sloc (Def_Id);
7786 Error_Msg_N ("matching subprogram #!", N);
7791 Hom_Id := Homonym (Hom_Id);
7794 -- See if we found an entry
7797 if not Ambiguous then
7798 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
7800 ("pragma% cannot be given for generic subprogram");
7803 ("pragma% does not identify local subprogram");
7810 -- Import pragmas must be for imported entities
7812 if Prag_Id = Pragma_Import_Function
7814 Prag_Id = Pragma_Import_Procedure
7816 Prag_Id = Pragma_Import_Valued_Procedure
7818 if not Is_Imported (Ent) then
7820 ("pragma Import or Interface must precede pragma%");
7823 -- Here we have the Export case which can set the entity as exported
7825 -- But does not do so if the specified external name is null, since
7826 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7827 -- compatible) to request no external name.
7829 elsif Nkind (Arg_External) = N_String_Literal
7830 and then String_Length (Strval (Arg_External)) = 0
7834 -- In all other cases, set entity as exported
7837 Set_Exported (Ent, Arg_Internal);
7840 -- Special processing for Valued_Procedure cases
7842 if Prag_Id = Pragma_Import_Valued_Procedure
7844 Prag_Id = Pragma_Export_Valued_Procedure
7846 Formal := First_Formal (Ent);
7849 Error_Pragma ("at least one parameter required for pragma%");
7851 elsif Ekind (Formal) /= E_Out_Parameter then
7852 Error_Pragma ("first parameter must have mode out for pragma%");
7855 Set_Is_Valued_Procedure (Ent);
7859 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
7861 -- Process Result_Mechanism argument if present. We have already
7862 -- checked that this is only allowed for the function case.
7864 if Present (Arg_Result_Mechanism) then
7865 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
7868 -- Process Mechanism parameter if present. Note that this parameter
7869 -- is not analyzed, and must not be analyzed since it is semantic
7870 -- nonsense, so we get it in exactly as the parser left it.
7872 if Present (Arg_Mechanism) then
7880 -- A single mechanism association without a formal parameter
7881 -- name is parsed as a parenthesized expression. All other
7882 -- cases are parsed as aggregates, so we rewrite the single
7883 -- parameter case as an aggregate for consistency.
7885 if Nkind (Arg_Mechanism) /= N_Aggregate
7886 and then Paren_Count (Arg_Mechanism) = 1
7888 Rewrite (Arg_Mechanism,
7889 Make_Aggregate (Sloc (Arg_Mechanism),
7890 Expressions => New_List (
7891 Relocate_Node (Arg_Mechanism))));
7894 -- Case of only mechanism name given, applies to all formals
7896 if Nkind (Arg_Mechanism) /= N_Aggregate then
7897 Formal := First_Formal (Ent);
7898 while Present (Formal) loop
7899 Set_Mechanism_Value (Formal, Arg_Mechanism);
7900 Next_Formal (Formal);
7903 -- Case of list of mechanism associations given
7906 if Null_Record_Present (Arg_Mechanism) then
7908 ("inappropriate form for Mechanism parameter",
7912 -- Deal with positional ones first
7914 Formal := First_Formal (Ent);
7916 if Present (Expressions (Arg_Mechanism)) then
7917 Mname := First (Expressions (Arg_Mechanism));
7918 while Present (Mname) loop
7921 ("too many mechanism associations", Mname);
7924 Set_Mechanism_Value (Formal, Mname);
7925 Next_Formal (Formal);
7930 -- Deal with named entries
7932 if Present (Component_Associations (Arg_Mechanism)) then
7933 Massoc := First (Component_Associations (Arg_Mechanism));
7934 while Present (Massoc) loop
7935 Choice := First (Choices (Massoc));
7937 if Nkind (Choice) /= N_Identifier
7938 or else Present (Next (Choice))
7941 ("incorrect form for mechanism association",
7945 Formal := First_Formal (Ent);
7949 ("parameter name & not present", Choice);
7952 if Chars (Choice) = Chars (Formal) then
7954 (Formal, Expression (Massoc));
7956 -- Set entity on identifier (needed by ASIS)
7958 Set_Entity (Choice, Formal);
7963 Next_Formal (Formal);
7972 end Process_Extended_Import_Export_Subprogram_Pragma;
7974 --------------------------
7975 -- Process_Generic_List --
7976 --------------------------
7978 procedure Process_Generic_List is
7983 Check_No_Identifiers;
7984 Check_At_Least_N_Arguments (1);
7986 -- Check all arguments are names of generic units or instances
7989 while Present (Arg) loop
7990 Exp := Get_Pragma_Arg (Arg);
7993 if not Is_Entity_Name (Exp)
7995 (not Is_Generic_Instance (Entity (Exp))
7997 not Is_Generic_Unit (Entity (Exp)))
8000 ("pragma% argument must be name of generic unit/instance",
8006 end Process_Generic_List;
8008 ------------------------------------
8009 -- Process_Import_Predefined_Type --
8010 ------------------------------------
8012 procedure Process_Import_Predefined_Type is
8013 Loc : constant Source_Ptr := Sloc (N);
8015 Ftyp : Node_Id := Empty;
8021 String_To_Name_Buffer (Strval (Expression (Arg3)));
8024 Elmt := First_Elmt (Predefined_Float_Types);
8025 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8029 Ftyp := Node (Elmt);
8031 if Present (Ftyp) then
8033 -- Don't build a derived type declaration, because predefined C
8034 -- types have no declaration anywhere, so cannot really be named.
8035 -- Instead build a full type declaration, starting with an
8036 -- appropriate type definition is built
8038 if Is_Floating_Point_Type (Ftyp) then
8039 Def := Make_Floating_Point_Definition (Loc,
8040 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8041 Make_Real_Range_Specification (Loc,
8042 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8043 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8045 -- Should never have a predefined type we cannot handle
8048 raise Program_Error;
8051 -- Build and insert a Full_Type_Declaration, which will be
8052 -- analyzed as soon as this list entry has been analyzed.
8054 Decl := Make_Full_Type_Declaration (Loc,
8055 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8056 Type_Definition => Def);
8058 Insert_After (N, Decl);
8059 Mark_Rewrite_Insertion (Decl);
8062 Error_Pragma_Arg ("no matching type found for pragma%",
8065 end Process_Import_Predefined_Type;
8067 ---------------------------------
8068 -- Process_Import_Or_Interface --
8069 ---------------------------------
8071 procedure Process_Import_Or_Interface is
8077 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8078 -- pragma Import (Entity, "external name");
8080 if Relaxed_RM_Semantics
8081 and then Arg_Count = 2
8082 and then Prag_Id = Pragma_Import
8083 and then Nkind (Expression (Arg2)) = N_String_Literal
8086 Def_Id := Get_Pragma_Arg (Arg1);
8089 if not Is_Entity_Name (Def_Id) then
8090 Error_Pragma_Arg ("entity name required", Arg1);
8093 Def_Id := Entity (Def_Id);
8094 Kill_Size_Check_Code (Def_Id);
8095 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8098 Process_Convention (C, Def_Id);
8100 -- A pragma that applies to a Ghost entity becomes Ghost for the
8101 -- purposes of legality checks and removal of ignored Ghost code.
8103 Mark_Pragma_As_Ghost (N, Def_Id);
8104 Kill_Size_Check_Code (Def_Id);
8105 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8108 -- Various error checks
8110 if Ekind_In (Def_Id, E_Variable, E_Constant) then
8112 -- We do not permit Import to apply to a renaming declaration
8114 if Present (Renamed_Object (Def_Id)) then
8116 ("pragma% not allowed for object renaming", Arg2);
8118 -- User initialization is not allowed for imported object, but
8119 -- the object declaration may contain a default initialization,
8120 -- that will be discarded. Note that an explicit initialization
8121 -- only counts if it comes from source, otherwise it is simply
8122 -- the code generator making an implicit initialization explicit.
8124 elsif Present (Expression (Parent (Def_Id)))
8125 and then Comes_From_Source
8126 (Original_Node (Expression (Parent (Def_Id))))
8128 -- Set imported flag to prevent cascaded errors
8130 Set_Is_Imported (Def_Id);
8132 Error_Msg_Sloc := Sloc (Def_Id);
8134 ("no initialization allowed for declaration of& #",
8135 "\imported entities cannot be initialized (RM B.1(24))",
8139 -- If the pragma comes from an aspect specification the
8140 -- Is_Imported flag has already been set.
8142 if not From_Aspect_Specification (N) then
8143 Set_Imported (Def_Id);
8146 Process_Interface_Name (Def_Id, Arg3, Arg4);
8148 -- Note that we do not set Is_Public here. That's because we
8149 -- only want to set it if there is no address clause, and we
8150 -- don't know that yet, so we delay that processing till
8153 -- pragma Import completes deferred constants
8155 if Ekind (Def_Id) = E_Constant then
8156 Set_Has_Completion (Def_Id);
8159 -- It is not possible to import a constant of an unconstrained
8160 -- array type (e.g. string) because there is no simple way to
8161 -- write a meaningful subtype for it.
8163 if Is_Array_Type (Etype (Def_Id))
8164 and then not Is_Constrained (Etype (Def_Id))
8167 ("imported constant& must have a constrained subtype",
8172 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8174 -- If the name is overloaded, pragma applies to all of the denoted
8175 -- entities in the same declarative part, unless the pragma comes
8176 -- from an aspect specification or was generated by the compiler
8177 -- (such as for pragma Provide_Shift_Operators).
8180 while Present (Hom_Id) loop
8182 Def_Id := Get_Base_Subprogram (Hom_Id);
8184 -- Ignore inherited subprograms because the pragma will apply
8185 -- to the parent operation, which is the one called.
8187 if Is_Overloadable (Def_Id)
8188 and then Present (Alias (Def_Id))
8192 -- If it is not a subprogram, it must be in an outer scope and
8193 -- pragma does not apply.
8195 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8198 -- The pragma does not apply to primitives of interfaces
8200 elsif Is_Dispatching_Operation (Def_Id)
8201 and then Present (Find_Dispatching_Type (Def_Id))
8202 and then Is_Interface (Find_Dispatching_Type (Def_Id))
8206 -- Verify that the homonym is in the same declarative part (not
8207 -- just the same scope). If the pragma comes from an aspect
8208 -- specification we know that it is part of the declaration.
8210 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8211 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8212 and then not From_Aspect_Specification (N)
8217 -- If the pragma comes from an aspect specification the
8218 -- Is_Imported flag has already been set.
8220 if not From_Aspect_Specification (N) then
8221 Set_Imported (Def_Id);
8224 -- Reject an Import applied to an abstract subprogram
8226 if Is_Subprogram (Def_Id)
8227 and then Is_Abstract_Subprogram (Def_Id)
8229 Error_Msg_Sloc := Sloc (Def_Id);
8231 ("cannot import abstract subprogram& declared#",
8235 -- Special processing for Convention_Intrinsic
8237 if C = Convention_Intrinsic then
8239 -- Link_Name argument not allowed for intrinsic
8243 Set_Is_Intrinsic_Subprogram (Def_Id);
8245 -- If no external name is present, then check that this
8246 -- is a valid intrinsic subprogram. If an external name
8247 -- is present, then this is handled by the back end.
8250 Check_Intrinsic_Subprogram
8251 (Def_Id, Get_Pragma_Arg (Arg2));
8255 -- Verify that the subprogram does not have a completion
8256 -- through a renaming declaration. For other completions the
8257 -- pragma appears as a too late representation.
8260 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8264 and then Nkind (Decl) = N_Subprogram_Declaration
8265 and then Present (Corresponding_Body (Decl))
8266 and then Nkind (Unit_Declaration_Node
8267 (Corresponding_Body (Decl))) =
8268 N_Subprogram_Renaming_Declaration
8270 Error_Msg_Sloc := Sloc (Def_Id);
8272 ("cannot import&, renaming already provided for "
8273 & "declaration #", N, Def_Id);
8277 -- If the pragma comes from an aspect specification, there
8278 -- must be an Import aspect specified as well. In the rare
8279 -- case where Import is set to False, the suprogram needs to
8280 -- have a local completion.
8283 Imp_Aspect : constant Node_Id :=
8284 Find_Aspect (Def_Id, Aspect_Import);
8288 if Present (Imp_Aspect)
8289 and then Present (Expression (Imp_Aspect))
8291 Expr := Expression (Imp_Aspect);
8292 Analyze_And_Resolve (Expr, Standard_Boolean);
8294 if Is_Entity_Name (Expr)
8295 and then Entity (Expr) = Standard_True
8297 Set_Has_Completion (Def_Id);
8300 -- If there is no expression, the default is True, as for
8301 -- all boolean aspects. Same for the older pragma.
8304 Set_Has_Completion (Def_Id);
8308 Process_Interface_Name (Def_Id, Arg3, Arg4);
8311 if Is_Compilation_Unit (Hom_Id) then
8313 -- Its possible homonyms are not affected by the pragma.
8314 -- Such homonyms might be present in the context of other
8315 -- units being compiled.
8319 elsif From_Aspect_Specification (N) then
8322 -- If the pragma was created by the compiler, then we don't
8323 -- want it to apply to other homonyms. This kind of case can
8324 -- occur when using pragma Provide_Shift_Operators, which
8325 -- generates implicit shift and rotate operators with Import
8326 -- pragmas that might apply to earlier explicit or implicit
8327 -- declarations marked with Import (for example, coming from
8328 -- an earlier pragma Provide_Shift_Operators for another type),
8329 -- and we don't generally want other homonyms being treated
8330 -- as imported or the pragma flagged as an illegal duplicate.
8332 elsif not Comes_From_Source (N) then
8336 Hom_Id := Homonym (Hom_Id);
8340 -- Import a CPP class
8342 elsif C = Convention_CPP
8343 and then (Is_Record_Type (Def_Id)
8344 or else Ekind (Def_Id) = E_Incomplete_Type)
8346 if Ekind (Def_Id) = E_Incomplete_Type then
8347 if Present (Full_View (Def_Id)) then
8348 Def_Id := Full_View (Def_Id);
8352 ("cannot import 'C'P'P type before full declaration seen",
8353 Get_Pragma_Arg (Arg2));
8355 -- Although we have reported the error we decorate it as
8356 -- CPP_Class to avoid reporting spurious errors
8358 Set_Is_CPP_Class (Def_Id);
8363 -- Types treated as CPP classes must be declared limited (note:
8364 -- this used to be a warning but there is no real benefit to it
8365 -- since we did effectively intend to treat the type as limited
8368 if not Is_Limited_Type (Def_Id) then
8370 ("imported 'C'P'P type must be limited",
8371 Get_Pragma_Arg (Arg2));
8374 if Etype (Def_Id) /= Def_Id
8375 and then not Is_CPP_Class (Root_Type (Def_Id))
8377 Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8380 Set_Is_CPP_Class (Def_Id);
8382 -- Imported CPP types must not have discriminants (because C++
8383 -- classes do not have discriminants).
8385 if Has_Discriminants (Def_Id) then
8387 ("imported 'C'P'P type cannot have discriminants",
8388 First (Discriminant_Specifications
8389 (Declaration_Node (Def_Id))));
8392 -- Check that components of imported CPP types do not have default
8393 -- expressions. For private types this check is performed when the
8394 -- full view is analyzed (see Process_Full_View).
8396 if not Is_Private_Type (Def_Id) then
8397 Check_CPP_Type_Has_No_Defaults (Def_Id);
8400 -- Import a CPP exception
8402 elsif C = Convention_CPP
8403 and then Ekind (Def_Id) = E_Exception
8407 ("'External_'Name arguments is required for 'Cpp exception",
8410 -- As only a string is allowed, Check_Arg_Is_External_Name
8413 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8416 if Present (Arg4) then
8418 ("Link_Name argument not allowed for imported Cpp exception",
8422 -- Do not call Set_Interface_Name as the name of the exception
8423 -- shouldn't be modified (and in particular it shouldn't be
8424 -- the External_Name). For exceptions, the External_Name is the
8425 -- name of the RTTI structure.
8427 -- ??? Emit an error if pragma Import/Export_Exception is present
8429 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8431 Check_Arg_Count (3);
8432 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8434 Process_Import_Predefined_Type;
8438 ("second argument of pragma% must be object, subprogram "
8439 & "or incomplete type",
8443 -- If this pragma applies to a compilation unit, then the unit, which
8444 -- is a subprogram, does not require (or allow) a body. We also do
8445 -- not need to elaborate imported procedures.
8447 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8449 Cunit : constant Node_Id := Parent (Parent (N));
8451 Set_Body_Required (Cunit, False);
8454 end Process_Import_Or_Interface;
8456 --------------------
8457 -- Process_Inline --
8458 --------------------
8460 procedure Process_Inline (Status : Inline_Status) is
8467 Ghost_Error_Posted : Boolean := False;
8468 -- Flag set when an error concerning the illegal mix of Ghost and
8469 -- non-Ghost subprograms is emitted.
8471 Ghost_Id : Entity_Id := Empty;
8472 -- The entity of the first Ghost subprogram encountered while
8473 -- processing the arguments of the pragma.
8475 procedure Make_Inline (Subp : Entity_Id);
8476 -- Subp is the defining unit name of the subprogram declaration. Set
8477 -- the flag, as well as the flag in the corresponding body, if there
8480 procedure Set_Inline_Flags (Subp : Entity_Id);
8481 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8482 -- Has_Pragma_Inline_Always for the Inline_Always case.
8484 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8485 -- Returns True if it can be determined at this stage that inlining
8486 -- is not possible, for example if the body is available and contains
8487 -- exception handlers, we prevent inlining, since otherwise we can
8488 -- get undefined symbols at link time. This function also emits a
8489 -- warning if front-end inlining is enabled and the pragma appears
8492 -- ??? is business with link symbols still valid, or does it relate
8493 -- to front end ZCX which is being phased out ???
8495 ---------------------------
8496 -- Inlining_Not_Possible --
8497 ---------------------------
8499 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8500 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8504 if Nkind (Decl) = N_Subprogram_Body then
8505 Stats := Handled_Statement_Sequence (Decl);
8506 return Present (Exception_Handlers (Stats))
8507 or else Present (At_End_Proc (Stats));
8509 elsif Nkind (Decl) = N_Subprogram_Declaration
8510 and then Present (Corresponding_Body (Decl))
8512 if Front_End_Inlining
8513 and then Analyzed (Corresponding_Body (Decl))
8515 Error_Msg_N ("pragma appears too late, ignored??", N);
8518 -- If the subprogram is a renaming as body, the body is just a
8519 -- call to the renamed subprogram, and inlining is trivially
8523 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8524 N_Subprogram_Renaming_Declaration
8530 Handled_Statement_Sequence
8531 (Unit_Declaration_Node (Corresponding_Body (Decl)));
8534 Present (Exception_Handlers (Stats))
8535 or else Present (At_End_Proc (Stats));
8539 -- If body is not available, assume the best, the check is
8540 -- performed again when compiling enclosing package bodies.
8544 end Inlining_Not_Possible;
8550 procedure Make_Inline (Subp : Entity_Id) is
8551 Kind : constant Entity_Kind := Ekind (Subp);
8552 Inner_Subp : Entity_Id := Subp;
8555 -- Ignore if bad type, avoid cascaded error
8557 if Etype (Subp) = Any_Type then
8561 -- If inlining is not possible, for now do not treat as an error
8563 elsif Status /= Suppressed
8564 and then Inlining_Not_Possible (Subp)
8569 -- Here we have a candidate for inlining, but we must exclude
8570 -- derived operations. Otherwise we would end up trying to inline
8571 -- a phantom declaration, and the result would be to drag in a
8572 -- body which has no direct inlining associated with it. That
8573 -- would not only be inefficient but would also result in the
8574 -- backend doing cross-unit inlining in cases where it was
8575 -- definitely inappropriate to do so.
8577 -- However, a simple Comes_From_Source test is insufficient, since
8578 -- we do want to allow inlining of generic instances which also do
8579 -- not come from source. We also need to recognize specs generated
8580 -- by the front-end for bodies that carry the pragma. Finally,
8581 -- predefined operators do not come from source but are not
8582 -- inlineable either.
8584 elsif Is_Generic_Instance (Subp)
8585 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8589 elsif not Comes_From_Source (Subp)
8590 and then Scope (Subp) /= Standard_Standard
8596 -- The referenced entity must either be the enclosing entity, or
8597 -- an entity declared within the current open scope.
8599 if Present (Scope (Subp))
8600 and then Scope (Subp) /= Current_Scope
8601 and then Subp /= Current_Scope
8604 ("argument of% must be entity in current scope", Assoc);
8608 -- Processing for procedure, operator or function. If subprogram
8609 -- is aliased (as for an instance) indicate that the renamed
8610 -- entity (if declared in the same unit) is inlined.
8611 -- If this is the anonymous subprogram created for a subprogram
8612 -- instance, the inlining applies to it directly. Otherwise we
8613 -- retrieve it as the alias of the visible subprogram instance.
8615 if Is_Subprogram (Subp) then
8616 if Is_Wrapper_Package (Scope (Subp)) then
8619 Inner_Subp := Ultimate_Alias (Inner_Subp);
8622 if In_Same_Source_Unit (Subp, Inner_Subp) then
8623 Set_Inline_Flags (Inner_Subp);
8625 Decl := Parent (Parent (Inner_Subp));
8627 if Nkind (Decl) = N_Subprogram_Declaration
8628 and then Present (Corresponding_Body (Decl))
8630 Set_Inline_Flags (Corresponding_Body (Decl));
8632 elsif Is_Generic_Instance (Subp)
8633 and then Comes_From_Source (Subp)
8635 -- Indicate that the body needs to be created for
8636 -- inlining subsequent calls. The instantiation node
8637 -- follows the declaration of the wrapper package
8638 -- created for it. The subprogram that requires the
8639 -- body is the anonymous one in the wrapper package.
8641 if Scope (Subp) /= Standard_Standard
8643 Need_Subprogram_Instance_Body
8644 (Next (Unit_Declaration_Node
8645 (Scope (Alias (Subp)))), Subp)
8650 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8651 -- appear in a formal part to apply to a formal subprogram.
8652 -- Do not apply check within an instance or a formal package
8653 -- the test will have been applied to the original generic.
8655 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8656 and then List_Containing (Decl) = List_Containing (N)
8657 and then not In_Instance
8660 ("Inline cannot apply to a formal subprogram", N);
8662 -- If Subp is a renaming, it is the renamed entity that
8663 -- will appear in any call, and be inlined. However, for
8664 -- ASIS uses it is convenient to indicate that the renaming
8665 -- itself is an inlined subprogram, so that some gnatcheck
8666 -- rules can be applied in the absence of expansion.
8668 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8669 Set_Inline_Flags (Subp);
8675 -- For a generic subprogram set flag as well, for use at the point
8676 -- of instantiation, to determine whether the body should be
8679 elsif Is_Generic_Subprogram (Subp) then
8680 Set_Inline_Flags (Subp);
8683 -- Literals are by definition inlined
8685 elsif Kind = E_Enumeration_Literal then
8688 -- Anything else is an error
8692 ("expect subprogram name for pragma%", Assoc);
8696 ----------------------
8697 -- Set_Inline_Flags --
8698 ----------------------
8700 procedure Set_Inline_Flags (Subp : Entity_Id) is
8702 -- First set the Has_Pragma_XXX flags and issue the appropriate
8703 -- errors and warnings for suspicious combinations.
8705 if Prag_Id = Pragma_No_Inline then
8706 if Has_Pragma_Inline_Always (Subp) then
8708 ("Inline_Always and No_Inline are mutually exclusive", N);
8709 elsif Has_Pragma_Inline (Subp) then
8711 ("Inline and No_Inline both specified for& ??",
8712 N, Entity (Subp_Id));
8715 Set_Has_Pragma_No_Inline (Subp);
8717 if Prag_Id = Pragma_Inline_Always then
8718 if Has_Pragma_No_Inline (Subp) then
8720 ("Inline_Always and No_Inline are mutually exclusive",
8724 Set_Has_Pragma_Inline_Always (Subp);
8726 if Has_Pragma_No_Inline (Subp) then
8728 ("Inline and No_Inline both specified for& ??",
8729 N, Entity (Subp_Id));
8733 if not Has_Pragma_Inline (Subp) then
8734 Set_Has_Pragma_Inline (Subp);
8738 -- Then adjust the Is_Inlined flag. It can never be set if the
8739 -- subprogram is subject to pragma No_Inline.
8743 Set_Is_Inlined (Subp, False);
8747 if not Has_Pragma_No_Inline (Subp) then
8748 Set_Is_Inlined (Subp, True);
8752 -- A pragma that applies to a Ghost entity becomes Ghost for the
8753 -- purposes of legality checks and removal of ignored Ghost code.
8755 Mark_Pragma_As_Ghost (N, Subp);
8757 -- Capture the entity of the first Ghost subprogram being
8758 -- processed for error detection purposes.
8760 if Is_Ghost_Entity (Subp) then
8761 if No (Ghost_Id) then
8765 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8766 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8768 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
8769 Ghost_Error_Posted := True;
8771 Error_Msg_Name_1 := Pname;
8773 ("pragma % cannot mention ghost and non-ghost subprograms",
8776 Error_Msg_Sloc := Sloc (Ghost_Id);
8777 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
8779 Error_Msg_Sloc := Sloc (Subp);
8780 Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
8782 end Set_Inline_Flags;
8784 -- Start of processing for Process_Inline
8787 Check_No_Identifiers;
8788 Check_At_Least_N_Arguments (1);
8790 if Status = Enabled then
8791 Inline_Processing_Required := True;
8795 while Present (Assoc) loop
8796 Subp_Id := Get_Pragma_Arg (Assoc);
8800 if Is_Entity_Name (Subp_Id) then
8801 Subp := Entity (Subp_Id);
8803 if Subp = Any_Id then
8805 -- If previous error, avoid cascaded errors
8807 Check_Error_Detected;
8813 -- For the pragma case, climb homonym chain. This is
8814 -- what implements allowing the pragma in the renaming
8815 -- case, with the result applying to the ancestors, and
8816 -- also allows Inline to apply to all previous homonyms.
8818 if not From_Aspect_Specification (N) then
8819 while Present (Homonym (Subp))
8820 and then Scope (Homonym (Subp)) = Current_Scope
8822 Make_Inline (Homonym (Subp));
8823 Subp := Homonym (Subp);
8830 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
8837 ----------------------------
8838 -- Process_Interface_Name --
8839 ----------------------------
8841 procedure Process_Interface_Name
8842 (Subprogram_Def : Entity_Id;
8848 String_Val : String_Id;
8850 procedure Check_Form_Of_Interface_Name (SN : Node_Id);
8851 -- SN is a string literal node for an interface name. This routine
8852 -- performs some minimal checks that the name is reasonable. In
8853 -- particular that no spaces or other obviously incorrect characters
8854 -- appear. This is only a warning, since any characters are allowed.
8856 ----------------------------------
8857 -- Check_Form_Of_Interface_Name --
8858 ----------------------------------
8860 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
8861 S : constant String_Id := Strval (Expr_Value_S (SN));
8862 SL : constant Nat := String_Length (S);
8867 Error_Msg_N ("interface name cannot be null string", SN);
8870 for J in 1 .. SL loop
8871 C := Get_String_Char (S, J);
8873 -- Look for dubious character and issue unconditional warning.
8874 -- Definitely dubious if not in character range.
8876 if not In_Character_Range (C)
8878 -- Commas, spaces and (back)slashes are dubious
8880 or else Get_Character (C) = ','
8881 or else Get_Character (C) = '\'
8882 or else Get_Character (C) = ' '
8883 or else Get_Character (C) = '/'
8886 ("??interface name contains illegal character",
8887 Sloc (SN) + Source_Ptr (J));
8890 end Check_Form_Of_Interface_Name;
8892 -- Start of processing for Process_Interface_Name
8895 if No (Link_Arg) then
8896 if No (Ext_Arg) then
8899 elsif Chars (Ext_Arg) = Name_Link_Name then
8901 Link_Nam := Expression (Ext_Arg);
8904 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8905 Ext_Nam := Expression (Ext_Arg);
8910 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
8911 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
8912 Ext_Nam := Expression (Ext_Arg);
8913 Link_Nam := Expression (Link_Arg);
8916 -- Check expressions for external name and link name are static
8918 if Present (Ext_Nam) then
8919 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
8920 Check_Form_Of_Interface_Name (Ext_Nam);
8922 -- Verify that external name is not the name of a local entity,
8923 -- which would hide the imported one and could lead to run-time
8924 -- surprises. The problem can only arise for entities declared in
8925 -- a package body (otherwise the external name is fully qualified
8926 -- and will not conflict).
8934 if Prag_Id = Pragma_Import then
8935 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
8937 E := Entity_Id (Get_Name_Table_Int (Nam));
8939 if Nam /= Chars (Subprogram_Def)
8940 and then Present (E)
8941 and then not Is_Overloadable (E)
8942 and then Is_Immediately_Visible (E)
8943 and then not Is_Imported (E)
8944 and then Ekind (Scope (E)) = E_Package
8947 while Present (Par) loop
8948 if Nkind (Par) = N_Package_Body then
8949 Error_Msg_Sloc := Sloc (E);
8951 ("imported entity is hidden by & declared#",
8956 Par := Parent (Par);
8963 if Present (Link_Nam) then
8964 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
8965 Check_Form_Of_Interface_Name (Link_Nam);
8968 -- If there is no link name, just set the external name
8970 if No (Link_Nam) then
8971 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
8973 -- For the Link_Name case, the given literal is preceded by an
8974 -- asterisk, which indicates to GCC that the given name should be
8975 -- taken literally, and in particular that no prepending of
8976 -- underlines should occur, even in systems where this is the
8981 Store_String_Char (Get_Char_Code ('*'));
8982 String_Val := Strval (Expr_Value_S (Link_Nam));
8983 Store_String_Chars (String_Val);
8985 Make_String_Literal (Sloc (Link_Nam),
8986 Strval => End_String);
8989 -- Set the interface name. If the entity is a generic instance, use
8990 -- its alias, which is the callable entity.
8992 if Is_Generic_Instance (Subprogram_Def) then
8993 Set_Encoded_Interface_Name
8994 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
8996 Set_Encoded_Interface_Name
8997 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9000 Check_Duplicated_Export_Name (Link_Nam);
9001 end Process_Interface_Name;
9003 -----------------------------------------
9004 -- Process_Interrupt_Or_Attach_Handler --
9005 -----------------------------------------
9007 procedure Process_Interrupt_Or_Attach_Handler is
9008 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9009 Prot_Typ : constant Entity_Id := Scope (Handler);
9012 -- A pragma that applies to a Ghost entity becomes Ghost for the
9013 -- purposes of legality checks and removal of ignored Ghost code.
9015 Mark_Pragma_As_Ghost (N, Handler);
9016 Set_Is_Interrupt_Handler (Handler);
9018 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9020 Record_Rep_Item (Prot_Typ, N);
9022 -- Chain the pragma on the contract for completeness
9024 Add_Contract_Item (N, Handler);
9025 end Process_Interrupt_Or_Attach_Handler;
9027 --------------------------------------------------
9028 -- Process_Restrictions_Or_Restriction_Warnings --
9029 --------------------------------------------------
9031 -- Note: some of the simple identifier cases were handled in par-prag,
9032 -- but it is harmless (and more straightforward) to simply handle all
9033 -- cases here, even if it means we repeat a bit of work in some cases.
9035 procedure Process_Restrictions_Or_Restriction_Warnings
9039 R_Id : Restriction_Id;
9045 -- Ignore all Restrictions pragmas in CodePeer mode
9047 if CodePeer_Mode then
9051 Check_Ada_83_Warning;
9052 Check_At_Least_N_Arguments (1);
9053 Check_Valid_Configuration_Pragma;
9056 while Present (Arg) loop
9058 Expr := Get_Pragma_Arg (Arg);
9060 -- Case of no restriction identifier present
9062 if Id = No_Name then
9063 if Nkind (Expr) /= N_Identifier then
9065 ("invalid form for restriction", Arg);
9070 (Process_Restriction_Synonyms (Expr));
9072 if R_Id not in All_Boolean_Restrictions then
9073 Error_Msg_Name_1 := Pname;
9075 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9077 -- Check for possible misspelling
9079 for J in Restriction_Id loop
9081 Rnm : constant String := Restriction_Id'Image (J);
9084 Name_Buffer (1 .. Rnm'Length) := Rnm;
9085 Name_Len := Rnm'Length;
9086 Set_Casing (All_Lower_Case);
9088 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9090 (Identifier_Casing (Current_Source_File));
9091 Error_Msg_String (1 .. Rnm'Length) :=
9092 Name_Buffer (1 .. Name_Len);
9093 Error_Msg_Strlen := Rnm'Length;
9094 Error_Msg_N -- CODEFIX
9095 ("\possible misspelling of ""~""",
9096 Get_Pragma_Arg (Arg));
9105 if Implementation_Restriction (R_Id) then
9106 Check_Restriction (No_Implementation_Restrictions, Arg);
9109 -- Special processing for No_Elaboration_Code restriction
9111 if R_Id = No_Elaboration_Code then
9113 -- Restriction is only recognized within a configuration
9114 -- pragma file, or within a unit of the main extended
9115 -- program. Note: the test for Main_Unit is needed to
9116 -- properly include the case of configuration pragma files.
9118 if not (Current_Sem_Unit = Main_Unit
9119 or else In_Extended_Main_Source_Unit (N))
9123 -- Don't allow in a subunit unless already specified in
9126 elsif Nkind (Parent (N)) = N_Compilation_Unit
9127 and then Nkind (Unit (Parent (N))) = N_Subunit
9128 and then not Restriction_Active (No_Elaboration_Code)
9131 ("invalid specification of ""No_Elaboration_Code""",
9134 ("\restriction cannot be specified in a subunit", N);
9136 ("\unless also specified in body or spec", N);
9139 -- If we accept a No_Elaboration_Code restriction, then it
9140 -- needs to be added to the configuration restriction set so
9141 -- that we get proper application to other units in the main
9142 -- extended source as required.
9145 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9149 -- If this is a warning, then set the warning unless we already
9150 -- have a real restriction active (we never want a warning to
9151 -- override a real restriction).
9154 if not Restriction_Active (R_Id) then
9155 Set_Restriction (R_Id, N);
9156 Restriction_Warnings (R_Id) := True;
9159 -- If real restriction case, then set it and make sure that the
9160 -- restriction warning flag is off, since a real restriction
9161 -- always overrides a warning.
9164 Set_Restriction (R_Id, N);
9165 Restriction_Warnings (R_Id) := False;
9168 -- Check for obsolescent restrictions in Ada 2005 mode
9171 and then Ada_Version >= Ada_2005
9172 and then (R_Id = No_Asynchronous_Control
9174 R_Id = No_Unchecked_Deallocation
9176 R_Id = No_Unchecked_Conversion)
9178 Check_Restriction (No_Obsolescent_Features, N);
9181 -- A very special case that must be processed here: pragma
9182 -- Restrictions (No_Exceptions) turns off all run-time
9183 -- checking. This is a bit dubious in terms of the formal
9184 -- language definition, but it is what is intended by RM
9185 -- H.4(12). Restriction_Warnings never affects generated code
9186 -- so this is done only in the real restriction case.
9188 -- Atomic_Synchronization is not a real check, so it is not
9189 -- affected by this processing).
9191 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9192 -- run-time checks in CodePeer and GNATprove modes: we want to
9193 -- generate checks for analysis purposes, as set respectively
9194 -- by -gnatC and -gnatd.F
9197 and then not (CodePeer_Mode or GNATprove_Mode)
9198 and then R_Id = No_Exceptions
9200 for J in Scope_Suppress.Suppress'Range loop
9201 if J /= Atomic_Synchronization then
9202 Scope_Suppress.Suppress (J) := True;
9207 -- Case of No_Dependence => unit-name. Note that the parser
9208 -- already made the necessary entry in the No_Dependence table.
9210 elsif Id = Name_No_Dependence then
9211 if not OK_No_Dependence_Unit_Name (Expr) then
9215 -- Case of No_Specification_Of_Aspect => aspect-identifier
9217 elsif Id = Name_No_Specification_Of_Aspect then
9222 if Nkind (Expr) /= N_Identifier then
9225 A_Id := Get_Aspect_Id (Chars (Expr));
9228 if A_Id = No_Aspect then
9229 Error_Pragma_Arg ("invalid restriction name", Arg);
9231 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9235 -- Case of No_Use_Of_Attribute => attribute-identifier
9237 elsif Id = Name_No_Use_Of_Attribute then
9238 if Nkind (Expr) /= N_Identifier
9239 or else not Is_Attribute_Name (Chars (Expr))
9241 Error_Msg_N ("unknown attribute name??", Expr);
9244 Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9247 -- Case of No_Use_Of_Entity => fully-qualified-name
9249 elsif Id = Name_No_Use_Of_Entity then
9251 -- Restriction is only recognized within a configuration
9252 -- pragma file, or within a unit of the main extended
9253 -- program. Note: the test for Main_Unit is needed to
9254 -- properly include the case of configuration pragma files.
9256 if Current_Sem_Unit = Main_Unit
9257 or else In_Extended_Main_Source_Unit (N)
9259 if not OK_No_Dependence_Unit_Name (Expr) then
9260 Error_Msg_N ("wrong form for entity name", Expr);
9262 Set_Restriction_No_Use_Of_Entity
9263 (Expr, Warn, No_Profile);
9267 -- Case of No_Use_Of_Pragma => pragma-identifier
9269 elsif Id = Name_No_Use_Of_Pragma then
9270 if Nkind (Expr) /= N_Identifier
9271 or else not Is_Pragma_Name (Chars (Expr))
9273 Error_Msg_N ("unknown pragma name??", Expr);
9275 Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9278 -- All other cases of restriction identifier present
9281 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9282 Analyze_And_Resolve (Expr, Any_Integer);
9284 if R_Id not in All_Parameter_Restrictions then
9286 ("invalid restriction parameter identifier", Arg);
9288 elsif not Is_OK_Static_Expression (Expr) then
9289 Flag_Non_Static_Expr
9290 ("value must be static expression!", Expr);
9293 elsif not Is_Integer_Type (Etype (Expr))
9294 or else Expr_Value (Expr) < 0
9297 ("value must be non-negative integer", Arg);
9300 -- Restriction pragma is active
9302 Val := Expr_Value (Expr);
9304 if not UI_Is_In_Int_Range (Val) then
9306 ("pragma ignored, value too large??", Arg);
9309 -- Warning case. If the real restriction is active, then we
9310 -- ignore the request, since warning never overrides a real
9311 -- restriction. Otherwise we set the proper warning. Note that
9312 -- this circuit sets the warning again if it is already set,
9313 -- which is what we want, since the constant may have changed.
9316 if not Restriction_Active (R_Id) then
9318 (R_Id, N, Integer (UI_To_Int (Val)));
9319 Restriction_Warnings (R_Id) := True;
9322 -- Real restriction case, set restriction and make sure warning
9323 -- flag is off since real restriction always overrides warning.
9326 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9327 Restriction_Warnings (R_Id) := False;
9333 end Process_Restrictions_Or_Restriction_Warnings;
9335 ---------------------------------
9336 -- Process_Suppress_Unsuppress --
9337 ---------------------------------
9339 -- Note: this procedure makes entries in the check suppress data
9340 -- structures managed by Sem. See spec of package Sem for full
9341 -- details on how we handle recording of check suppression.
9343 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9348 In_Package_Spec : constant Boolean :=
9349 Is_Package_Or_Generic_Package (Current_Scope)
9350 and then not In_Package_Body (Current_Scope);
9352 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9353 -- Used to suppress a single check on the given entity
9355 --------------------------------
9356 -- Suppress_Unsuppress_Echeck --
9357 --------------------------------
9359 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9361 -- Check for error of trying to set atomic synchronization for
9362 -- a non-atomic variable.
9364 if C = Atomic_Synchronization
9365 and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9368 ("pragma & requires atomic type or variable",
9369 Pragma_Identifier (Original_Node (N)));
9372 Set_Checks_May_Be_Suppressed (E);
9374 if In_Package_Spec then
9375 Push_Global_Suppress_Stack_Entry
9378 Suppress => Suppress_Case);
9380 Push_Local_Suppress_Stack_Entry
9383 Suppress => Suppress_Case);
9386 -- If this is a first subtype, and the base type is distinct,
9387 -- then also set the suppress flags on the base type.
9389 if Is_First_Subtype (E) and then Etype (E) /= E then
9390 Suppress_Unsuppress_Echeck (Etype (E), C);
9392 end Suppress_Unsuppress_Echeck;
9394 -- Start of processing for Process_Suppress_Unsuppress
9397 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9398 -- on user code: we want to generate checks for analysis purposes, as
9399 -- set respectively by -gnatC and -gnatd.F
9401 if Comes_From_Source (N)
9402 and then (CodePeer_Mode or GNATprove_Mode)
9407 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9408 -- declarative part or a package spec (RM 11.5(5)).
9410 if not Is_Configuration_Pragma then
9411 Check_Is_In_Decl_Part_Or_Package_Spec;
9414 Check_At_Least_N_Arguments (1);
9415 Check_At_Most_N_Arguments (2);
9416 Check_No_Identifier (Arg1);
9417 Check_Arg_Is_Identifier (Arg1);
9419 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9421 if C = No_Check_Id then
9423 ("argument of pragma% is not valid check name", Arg1);
9426 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9428 if C = Elaboration_Check and then SPARK_Mode = On then
9430 ("Suppress of Elaboration_Check ignored in SPARK??",
9431 "\elaboration checking rules are statically enforced "
9432 & "(SPARK RM 7.7)", Arg1);
9435 -- One-argument case
9437 if Arg_Count = 1 then
9439 -- Make an entry in the local scope suppress table. This is the
9440 -- table that directly shows the current value of the scope
9441 -- suppress check for any check id value.
9443 if C = All_Checks then
9445 -- For All_Checks, we set all specific predefined checks with
9446 -- the exception of Elaboration_Check, which is handled
9447 -- specially because of not wanting All_Checks to have the
9448 -- effect of deactivating static elaboration order processing.
9449 -- Atomic_Synchronization is also not affected, since this is
9450 -- not a real check.
9452 for J in Scope_Suppress.Suppress'Range loop
9453 if J /= Elaboration_Check
9455 J /= Atomic_Synchronization
9457 Scope_Suppress.Suppress (J) := Suppress_Case;
9461 -- If not All_Checks, and predefined check, then set appropriate
9462 -- scope entry. Note that we will set Elaboration_Check if this
9463 -- is explicitly specified. Atomic_Synchronization is allowed
9464 -- only if internally generated and entity is atomic.
9466 elsif C in Predefined_Check_Id
9467 and then (not Comes_From_Source (N)
9468 or else C /= Atomic_Synchronization)
9470 Scope_Suppress.Suppress (C) := Suppress_Case;
9473 -- Also make an entry in the Local_Entity_Suppress table
9475 Push_Local_Suppress_Stack_Entry
9478 Suppress => Suppress_Case);
9480 -- Case of two arguments present, where the check is suppressed for
9481 -- a specified entity (given as the second argument of the pragma)
9484 -- This is obsolescent in Ada 2005 mode
9486 if Ada_Version >= Ada_2005 then
9487 Check_Restriction (No_Obsolescent_Features, Arg2);
9490 Check_Optional_Identifier (Arg2, Name_On);
9491 E_Id := Get_Pragma_Arg (Arg2);
9494 if not Is_Entity_Name (E_Id) then
9496 ("second argument of pragma% must be entity name", Arg2);
9505 -- A pragma that applies to a Ghost entity becomes Ghost for the
9506 -- purposes of legality checks and removal of ignored Ghost code.
9508 Mark_Pragma_As_Ghost (N, E);
9510 -- Enforce RM 11.5(7) which requires that for a pragma that
9511 -- appears within a package spec, the named entity must be
9512 -- within the package spec. We allow the package name itself
9513 -- to be mentioned since that makes sense, although it is not
9514 -- strictly allowed by 11.5(7).
9517 and then E /= Current_Scope
9518 and then Scope (E) /= Current_Scope
9521 ("entity in pragma% is not in package spec (RM 11.5(7))",
9525 -- Loop through homonyms. As noted below, in the case of a package
9526 -- spec, only homonyms within the package spec are considered.
9529 Suppress_Unsuppress_Echeck (E, C);
9531 if Is_Generic_Instance (E)
9532 and then Is_Subprogram (E)
9533 and then Present (Alias (E))
9535 Suppress_Unsuppress_Echeck (Alias (E), C);
9538 -- Move to next homonym if not aspect spec case
9540 exit when From_Aspect_Specification (N);
9544 -- If we are within a package specification, the pragma only
9545 -- applies to homonyms in the same scope.
9547 exit when In_Package_Spec
9548 and then Scope (E) /= Current_Scope;
9551 end Process_Suppress_Unsuppress;
9553 -------------------------------
9554 -- Record_Independence_Check --
9555 -------------------------------
9557 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9559 -- For GCC back ends the validation is done a priori
9561 if not AAMP_On_Target then
9565 Independence_Checks.Append ((N, E));
9566 end Record_Independence_Check;
9572 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9574 if Is_Imported (E) then
9576 ("cannot export entity& that was previously imported", Arg);
9578 elsif Present (Address_Clause (E))
9579 and then not Relaxed_RM_Semantics
9582 ("cannot export entity& that has an address clause", Arg);
9585 Set_Is_Exported (E);
9587 -- Generate a reference for entity explicitly, because the
9588 -- identifier may be overloaded and name resolution will not
9591 Generate_Reference (E, Arg);
9593 -- Deal with exporting non-library level entity
9595 if not Is_Library_Level_Entity (E) then
9597 -- Not allowed at all for subprograms
9599 if Is_Subprogram (E) then
9600 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9602 -- Otherwise set public and statically allocated
9606 Set_Is_Statically_Allocated (E);
9608 -- Warn if the corresponding W flag is set
9610 if Warn_On_Export_Import
9612 -- Only do this for something that was in the source. Not
9613 -- clear if this can be False now (there used for sure to be
9614 -- cases on some systems where it was False), but anyway the
9615 -- test is harmless if not needed, so it is retained.
9617 and then Comes_From_Source (Arg)
9620 ("?x?& has been made static as a result of Export",
9623 ("\?x?this usage is non-standard and non-portable",
9629 if Warn_On_Export_Import and then Is_Type (E) then
9630 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9633 if Warn_On_Export_Import and Inside_A_Generic then
9635 ("all instances of& will have the same external name?x?",
9640 ----------------------------------------------
9641 -- Set_Extended_Import_Export_External_Name --
9642 ----------------------------------------------
9644 procedure Set_Extended_Import_Export_External_Name
9645 (Internal_Ent : Entity_Id;
9646 Arg_External : Node_Id)
9648 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9652 if No (Arg_External) then
9656 Check_Arg_Is_External_Name (Arg_External);
9658 if Nkind (Arg_External) = N_String_Literal then
9659 if String_Length (Strval (Arg_External)) = 0 then
9662 New_Name := Adjust_External_Name_Case (Arg_External);
9665 elsif Nkind (Arg_External) = N_Identifier then
9666 New_Name := Get_Default_External_Name (Arg_External);
9668 -- Check_Arg_Is_External_Name should let through only identifiers and
9669 -- string literals or static string expressions (which are folded to
9670 -- string literals).
9673 raise Program_Error;
9676 -- If we already have an external name set (by a prior normal Import
9677 -- or Export pragma), then the external names must match
9679 if Present (Interface_Name (Internal_Ent)) then
9681 -- Ignore mismatching names in CodePeer mode, to support some
9682 -- old compilers which would export the same procedure under
9683 -- different names, e.g:
9685 -- pragma Export_Procedure (P, "a");
9686 -- pragma Export_Procedure (P, "b");
9688 if CodePeer_Mode then
9692 Check_Matching_Internal_Names : declare
9693 S1 : constant String_Id := Strval (Old_Name);
9694 S2 : constant String_Id := Strval (New_Name);
9697 pragma No_Return (Mismatch);
9698 -- Called if names do not match
9704 procedure Mismatch is
9706 Error_Msg_Sloc := Sloc (Old_Name);
9708 ("external name does not match that given #",
9712 -- Start of processing for Check_Matching_Internal_Names
9715 if String_Length (S1) /= String_Length (S2) then
9719 for J in 1 .. String_Length (S1) loop
9720 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
9725 end Check_Matching_Internal_Names;
9727 -- Otherwise set the given name
9730 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
9731 Check_Duplicated_Export_Name (New_Name);
9733 end Set_Extended_Import_Export_External_Name;
9739 procedure Set_Imported (E : Entity_Id) is
9741 -- Error message if already imported or exported
9743 if Is_Exported (E) or else Is_Imported (E) then
9745 -- Error if being set Exported twice
9747 if Is_Exported (E) then
9748 Error_Msg_NE ("entity& was previously exported", N, E);
9750 -- Ignore error in CodePeer mode where we treat all imported
9751 -- subprograms as unknown.
9753 elsif CodePeer_Mode then
9756 -- OK if Import/Interface case
9758 elsif Import_Interface_Present (N) then
9761 -- Error if being set Imported twice
9764 Error_Msg_NE ("entity& was previously imported", N, E);
9767 Error_Msg_Name_1 := Pname;
9769 ("\(pragma% applies to all previous entities)", N);
9771 Error_Msg_Sloc := Sloc (E);
9772 Error_Msg_NE ("\import not allowed for& declared#", N, E);
9774 -- Here if not previously imported or exported, OK to import
9777 Set_Is_Imported (E);
9779 -- For subprogram, set Import_Pragma field
9781 if Is_Subprogram (E) then
9782 Set_Import_Pragma (E, N);
9785 -- If the entity is an object that is not at the library level,
9786 -- then it is statically allocated. We do not worry about objects
9787 -- with address clauses in this context since they are not really
9788 -- imported in the linker sense.
9791 and then not Is_Library_Level_Entity (E)
9792 and then No (Address_Clause (E))
9794 Set_Is_Statically_Allocated (E);
9801 -------------------------
9802 -- Set_Mechanism_Value --
9803 -------------------------
9805 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9806 -- analyzed, since it is semantic nonsense), so we get it in the exact
9807 -- form created by the parser.
9809 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
9810 procedure Bad_Mechanism;
9811 pragma No_Return (Bad_Mechanism);
9812 -- Signal bad mechanism name
9814 -------------------------
9815 -- Bad_Mechanism_Value --
9816 -------------------------
9818 procedure Bad_Mechanism is
9820 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
9823 -- Start of processing for Set_Mechanism_Value
9826 if Mechanism (Ent) /= Default_Mechanism then
9828 ("mechanism for & has already been set", Mech_Name, Ent);
9831 -- MECHANISM_NAME ::= value | reference
9833 if Nkind (Mech_Name) = N_Identifier then
9834 if Chars (Mech_Name) = Name_Value then
9835 Set_Mechanism (Ent, By_Copy);
9838 elsif Chars (Mech_Name) = Name_Reference then
9839 Set_Mechanism (Ent, By_Reference);
9842 elsif Chars (Mech_Name) = Name_Copy then
9844 ("bad mechanism name, Value assumed", Mech_Name);
9853 end Set_Mechanism_Value;
9855 --------------------------
9856 -- Set_Rational_Profile --
9857 --------------------------
9859 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9860 -- extension to the semantics of renaming declarations.
9862 procedure Set_Rational_Profile is
9864 Implicit_Packing := True;
9865 Overriding_Renamings := True;
9866 Use_VADS_Size := True;
9867 end Set_Rational_Profile;
9869 ---------------------------
9870 -- Set_Ravenscar_Profile --
9871 ---------------------------
9873 -- The tasks to be done here are
9875 -- Set required policies
9877 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9878 -- pragma Locking_Policy (Ceiling_Locking)
9880 -- Set Detect_Blocking mode
9882 -- Set required restrictions (see System.Rident for detailed list)
9884 -- Set the No_Dependence rules
9885 -- No_Dependence => Ada.Asynchronous_Task_Control
9886 -- No_Dependence => Ada.Calendar
9887 -- No_Dependence => Ada.Execution_Time.Group_Budget
9888 -- No_Dependence => Ada.Execution_Time.Timers
9889 -- No_Dependence => Ada.Task_Attributes
9890 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9892 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
9893 procedure Set_Error_Msg_To_Profile_Name;
9894 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
9897 -----------------------------------
9898 -- Set_Error_Msg_To_Profile_Name --
9899 -----------------------------------
9901 procedure Set_Error_Msg_To_Profile_Name is
9902 Prof_Nam : constant Node_Id :=
9904 (First (Pragma_Argument_Associations (N)));
9907 Get_Name_String (Chars (Prof_Nam));
9908 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
9909 Error_Msg_Strlen := Name_Len;
9910 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
9911 end Set_Error_Msg_To_Profile_Name;
9920 -- Start of processing for Set_Ravenscar_Profile
9923 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9925 if Task_Dispatching_Policy /= ' '
9926 and then Task_Dispatching_Policy /= 'F'
9928 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9929 Set_Error_Msg_To_Profile_Name;
9930 Error_Pragma ("Profile (~) incompatible with policy#");
9932 -- Set the FIFO_Within_Priorities policy, but always preserve
9933 -- System_Location since we like the error message with the run time
9937 Task_Dispatching_Policy := 'F';
9939 if Task_Dispatching_Policy_Sloc /= System_Location then
9940 Task_Dispatching_Policy_Sloc := Loc;
9944 -- pragma Locking_Policy (Ceiling_Locking)
9946 if Locking_Policy /= ' '
9947 and then Locking_Policy /= 'C'
9949 Error_Msg_Sloc := Locking_Policy_Sloc;
9950 Set_Error_Msg_To_Profile_Name;
9951 Error_Pragma ("Profile (~) incompatible with policy#");
9953 -- Set the Ceiling_Locking policy, but preserve System_Location since
9954 -- we like the error message with the run time name.
9957 Locking_Policy := 'C';
9959 if Locking_Policy_Sloc /= System_Location then
9960 Locking_Policy_Sloc := Loc;
9964 -- pragma Detect_Blocking
9966 Detect_Blocking := True;
9968 -- Set the corresponding restrictions
9970 Set_Profile_Restrictions
9971 (Profile, N, Warn => Treat_Restrictions_As_Warnings);
9973 -- Set the No_Dependence restrictions
9975 -- The following No_Dependence restrictions:
9976 -- No_Dependence => Ada.Asynchronous_Task_Control
9977 -- No_Dependence => Ada.Calendar
9978 -- No_Dependence => Ada.Task_Attributes
9979 -- are already set by previous call to Set_Profile_Restrictions.
9981 -- Set the following restrictions which were added to Ada 2005:
9982 -- No_Dependence => Ada.Execution_Time.Group_Budget
9983 -- No_Dependence => Ada.Execution_Time.Timers
9985 -- ??? The use of Name_Buffer here is suspicious. The names should
9986 -- be registered in snames.ads-tmpl and used to build the qualified
9989 if Ada_Version >= Ada_2005 then
9990 Name_Buffer (1 .. 3) := "ada";
9993 Pref_Id := Make_Identifier (Loc, Name_Find);
9995 Name_Buffer (1 .. 14) := "execution_time";
9998 Sel_Id := Make_Identifier (Loc, Name_Find);
10001 Make_Selected_Component
10004 Selector_Name => Sel_Id);
10006 Name_Buffer (1 .. 13) := "group_budgets";
10009 Sel_Id := Make_Identifier (Loc, Name_Find);
10012 Make_Selected_Component
10015 Selector_Name => Sel_Id);
10017 Set_Restriction_No_Dependence
10019 Warn => Treat_Restrictions_As_Warnings,
10020 Profile => Ravenscar);
10022 Name_Buffer (1 .. 6) := "timers";
10025 Sel_Id := Make_Identifier (Loc, Name_Find);
10028 Make_Selected_Component
10031 Selector_Name => Sel_Id);
10033 Set_Restriction_No_Dependence
10035 Warn => Treat_Restrictions_As_Warnings,
10036 Profile => Ravenscar);
10039 -- Set the following restriction which was added to Ada 2012 (see
10041 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10043 if Ada_Version >= Ada_2012 then
10044 Name_Buffer (1 .. 6) := "system";
10047 Pref_Id := Make_Identifier (Loc, Name_Find);
10049 Name_Buffer (1 .. 15) := "multiprocessors";
10052 Sel_Id := Make_Identifier (Loc, Name_Find);
10055 Make_Selected_Component
10058 Selector_Name => Sel_Id);
10060 Name_Buffer (1 .. 19) := "dispatching_domains";
10063 Sel_Id := Make_Identifier (Loc, Name_Find);
10066 Make_Selected_Component
10069 Selector_Name => Sel_Id);
10071 Set_Restriction_No_Dependence
10073 Warn => Treat_Restrictions_As_Warnings,
10074 Profile => Ravenscar);
10076 end Set_Ravenscar_Profile;
10078 -- Start of processing for Analyze_Pragma
10081 -- The following code is a defense against recursion. Not clear that
10082 -- this can happen legitimately, but perhaps some error situations can
10083 -- cause it, and we did see this recursion during testing.
10085 if Analyzed (N) then
10091 Check_Restriction_No_Use_Of_Pragma (N);
10093 -- Deal with unrecognized pragma
10095 Pname := Pragma_Name (N);
10097 if not Is_Pragma_Name (Pname) then
10098 if Warn_On_Unrecognized_Pragma then
10099 Error_Msg_Name_1 := Pname;
10100 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10102 for PN in First_Pragma_Name .. Last_Pragma_Name loop
10103 if Is_Bad_Spelling_Of (Pname, PN) then
10104 Error_Msg_Name_1 := PN;
10105 Error_Msg_N -- CODEFIX
10106 ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10115 -- Ignore pragma if Ignore_Pragma applies
10117 if Get_Name_Table_Boolean3 (Pname) then
10121 -- Here to start processing for recognized pragma
10123 Prag_Id := Get_Pragma_Id (Pname);
10124 Pname := Original_Aspect_Pragma_Name (N);
10126 -- Capture setting of Opt.Uneval_Old
10128 case Opt.Uneval_Old is
10130 Set_Uneval_Old_Accept (N);
10134 Set_Uneval_Old_Warn (N);
10136 raise Program_Error;
10139 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10140 -- is already set, indicating that we have already checked the policy
10141 -- at the right point. This happens for example in the case of a pragma
10142 -- that is derived from an Aspect.
10144 if Is_Ignored (N) or else Is_Checked (N) then
10147 -- For a pragma that is a rewriting of another pragma, copy the
10148 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10150 elsif Is_Rewrite_Substitution (N)
10151 and then Nkind (Original_Node (N)) = N_Pragma
10152 and then Original_Node (N) /= N
10154 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10155 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10157 -- Otherwise query the applicable policy at this point
10160 Check_Applicable_Policy (N);
10162 -- If pragma is disabled, rewrite as NULL and skip analysis
10164 if Is_Disabled (N) then
10165 Rewrite (N, Make_Null_Statement (Loc));
10171 -- Preset arguments
10179 if Present (Pragma_Argument_Associations (N)) then
10180 Arg_Count := List_Length (Pragma_Argument_Associations (N));
10181 Arg1 := First (Pragma_Argument_Associations (N));
10183 if Present (Arg1) then
10184 Arg2 := Next (Arg1);
10186 if Present (Arg2) then
10187 Arg3 := Next (Arg2);
10189 if Present (Arg3) then
10190 Arg4 := Next (Arg3);
10196 -- An enumeration type defines the pragmas that are supported by the
10197 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10198 -- into the corresponding enumeration value for the following case.
10206 -- pragma Abort_Defer;
10208 when Pragma_Abort_Defer =>
10210 Check_Arg_Count (0);
10212 -- The only required semantic processing is to check the
10213 -- placement. This pragma must appear at the start of the
10214 -- statement sequence of a handled sequence of statements.
10216 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10217 or else N /= First (Statements (Parent (N)))
10222 --------------------
10223 -- Abstract_State --
10224 --------------------
10226 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10228 -- ABSTRACT_STATE_LIST ::=
10230 -- | STATE_NAME_WITH_OPTIONS
10231 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10233 -- STATE_NAME_WITH_OPTIONS ::=
10235 -- | (STATE_NAME with OPTION_LIST)
10237 -- OPTION_LIST ::= OPTION {, OPTION}
10241 -- | NAME_VALUE_OPTION
10243 -- SIMPLE_OPTION ::= Ghost | Synchronous
10245 -- NAME_VALUE_OPTION ::=
10246 -- Part_Of => ABSTRACT_STATE
10247 -- | External [=> EXTERNAL_PROPERTY_LIST]
10249 -- EXTERNAL_PROPERTY_LIST ::=
10250 -- EXTERNAL_PROPERTY
10251 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10253 -- EXTERNAL_PROPERTY ::=
10254 -- Async_Readers [=> boolean_EXPRESSION]
10255 -- | Async_Writers [=> boolean_EXPRESSION]
10256 -- | Effective_Reads [=> boolean_EXPRESSION]
10257 -- | Effective_Writes [=> boolean_EXPRESSION]
10258 -- others => boolean_EXPRESSION
10260 -- STATE_NAME ::= defining_identifier
10262 -- ABSTRACT_STATE ::= name
10264 -- Characteristics:
10266 -- * Analysis - The annotation is fully analyzed immediately upon
10267 -- elaboration as it cannot forward reference entities.
10269 -- * Expansion - None.
10271 -- * Template - The annotation utilizes the generic template of the
10272 -- related package declaration.
10274 -- * Globals - The annotation cannot reference global entities.
10276 -- * Instance - The annotation is instantiated automatically when
10277 -- the related generic package is instantiated.
10279 when Pragma_Abstract_State => Abstract_State : declare
10280 Missing_Parentheses : Boolean := False;
10281 -- Flag set when a state declaration with options is not properly
10284 -- Flags used to verify the consistency of states
10286 Non_Null_Seen : Boolean := False;
10287 Null_Seen : Boolean := False;
10289 procedure Analyze_Abstract_State
10291 Pack_Id : Entity_Id);
10292 -- Verify the legality of a single state declaration. Create and
10293 -- decorate a state abstraction entity and introduce it into the
10294 -- visibility chain. Pack_Id denotes the entity or the related
10295 -- package where pragma Abstract_State appears.
10297 procedure Malformed_State_Error (State : Node_Id);
10298 -- Emit an error concerning the illegal declaration of abstract
10299 -- state State. This routine diagnoses syntax errors that lead to
10300 -- a different parse tree. The error is issued regardless of the
10301 -- SPARK mode in effect.
10303 ----------------------------
10304 -- Analyze_Abstract_State --
10305 ----------------------------
10307 procedure Analyze_Abstract_State
10309 Pack_Id : Entity_Id)
10311 -- Flags used to verify the consistency of options
10313 AR_Seen : Boolean := False;
10314 AW_Seen : Boolean := False;
10315 ER_Seen : Boolean := False;
10316 EW_Seen : Boolean := False;
10317 External_Seen : Boolean := False;
10318 Ghost_Seen : Boolean := False;
10319 Others_Seen : Boolean := False;
10320 Part_Of_Seen : Boolean := False;
10321 Synchronous_Seen : Boolean := False;
10323 -- Flags used to store the static value of all external states'
10326 AR_Val : Boolean := False;
10327 AW_Val : Boolean := False;
10328 ER_Val : Boolean := False;
10329 EW_Val : Boolean := False;
10331 State_Id : Entity_Id := Empty;
10332 -- The entity to be generated for the current state declaration
10334 procedure Analyze_External_Option (Opt : Node_Id);
10335 -- Verify the legality of option External
10337 procedure Analyze_External_Property
10339 Expr : Node_Id := Empty);
10340 -- Verify the legailty of a single external property. Prop
10341 -- denotes the external property. Expr is the expression used
10342 -- to set the property.
10344 procedure Analyze_Part_Of_Option (Opt : Node_Id);
10345 -- Verify the legality of option Part_Of
10347 procedure Check_Duplicate_Option
10349 Status : in out Boolean);
10350 -- Flag Status denotes whether a particular option has been
10351 -- seen while processing a state. This routine verifies that
10352 -- Opt is not a duplicate option and sets the flag Status
10353 -- (SPARK RM 7.1.4(1)).
10355 procedure Check_Duplicate_Property
10357 Status : in out Boolean);
10358 -- Flag Status denotes whether a particular property has been
10359 -- seen while processing option External. This routine verifies
10360 -- that Prop is not a duplicate property and sets flag Status.
10361 -- Opt is not a duplicate property and sets the flag Status.
10362 -- (SPARK RM 7.1.4(2))
10364 procedure Check_Ghost_Synchronous;
10365 -- Ensure that the abstract state is not subject to both Ghost
10366 -- and Synchronous simple options. Emit an error if this is the
10369 procedure Create_Abstract_State
10373 Is_Null : Boolean);
10374 -- Generate an abstract state entity with name Nam and enter it
10375 -- into visibility. Decl is the "declaration" of the state as
10376 -- it appears in pragma Abstract_State. Loc is the location of
10377 -- the related state "declaration". Flag Is_Null should be set
10378 -- when the associated Abstract_State pragma defines a null
10381 -----------------------------
10382 -- Analyze_External_Option --
10383 -----------------------------
10385 procedure Analyze_External_Option (Opt : Node_Id) is
10386 Errors : constant Nat := Serious_Errors_Detected;
10388 Props : Node_Id := Empty;
10391 if Nkind (Opt) = N_Component_Association then
10392 Props := Expression (Opt);
10395 -- External state with properties
10397 if Present (Props) then
10399 -- Multiple properties appear as an aggregate
10401 if Nkind (Props) = N_Aggregate then
10403 -- Simple property form
10405 Prop := First (Expressions (Props));
10406 while Present (Prop) loop
10407 Analyze_External_Property (Prop);
10411 -- Property with expression form
10413 Prop := First (Component_Associations (Props));
10414 while Present (Prop) loop
10415 Analyze_External_Property
10416 (Prop => First (Choices (Prop)),
10417 Expr => Expression (Prop));
10425 Analyze_External_Property (Props);
10428 -- An external state defined without any properties defaults
10429 -- all properties to True.
10438 -- Once all external properties have been processed, verify
10439 -- their mutual interaction. Do not perform the check when
10440 -- at least one of the properties is illegal as this will
10441 -- produce a bogus error.
10443 if Errors = Serious_Errors_Detected then
10444 Check_External_Properties
10445 (State, AR_Val, AW_Val, ER_Val, EW_Val);
10447 end Analyze_External_Option;
10449 -------------------------------
10450 -- Analyze_External_Property --
10451 -------------------------------
10453 procedure Analyze_External_Property
10455 Expr : Node_Id := Empty)
10457 Expr_Val : Boolean;
10460 -- Check the placement of "others" (if available)
10462 if Nkind (Prop) = N_Others_Choice then
10463 if Others_Seen then
10465 ("only one others choice allowed in option External",
10468 Others_Seen := True;
10471 elsif Others_Seen then
10473 ("others must be the last property in option External",
10476 -- The only remaining legal options are the four predefined
10477 -- external properties.
10479 elsif Nkind (Prop) = N_Identifier
10480 and then Nam_In (Chars (Prop), Name_Async_Readers,
10481 Name_Async_Writers,
10482 Name_Effective_Reads,
10483 Name_Effective_Writes)
10487 -- Otherwise the construct is not a valid property
10490 SPARK_Msg_N ("invalid external state property", Prop);
10494 -- Ensure that the expression of the external state property
10495 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10497 if Present (Expr) then
10498 Analyze_And_Resolve (Expr, Standard_Boolean);
10500 if Is_OK_Static_Expression (Expr) then
10501 Expr_Val := Is_True (Expr_Value (Expr));
10504 ("expression of external state property must be "
10508 -- The lack of expression defaults the property to True
10514 -- Named properties
10516 if Nkind (Prop) = N_Identifier then
10517 if Chars (Prop) = Name_Async_Readers then
10518 Check_Duplicate_Property (Prop, AR_Seen);
10519 AR_Val := Expr_Val;
10521 elsif Chars (Prop) = Name_Async_Writers then
10522 Check_Duplicate_Property (Prop, AW_Seen);
10523 AW_Val := Expr_Val;
10525 elsif Chars (Prop) = Name_Effective_Reads then
10526 Check_Duplicate_Property (Prop, ER_Seen);
10527 ER_Val := Expr_Val;
10530 Check_Duplicate_Property (Prop, EW_Seen);
10531 EW_Val := Expr_Val;
10534 -- The handling of property "others" must take into account
10535 -- all other named properties that have been encountered so
10536 -- far. Only those that have not been seen are affected by
10540 if not AR_Seen then
10541 AR_Val := Expr_Val;
10544 if not AW_Seen then
10545 AW_Val := Expr_Val;
10548 if not ER_Seen then
10549 ER_Val := Expr_Val;
10552 if not EW_Seen then
10553 EW_Val := Expr_Val;
10556 end Analyze_External_Property;
10558 ----------------------------
10559 -- Analyze_Part_Of_Option --
10560 ----------------------------
10562 procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10563 Encap : constant Node_Id := Expression (Opt);
10564 Constits : Elist_Id;
10565 Encap_Id : Entity_Id;
10569 Check_Duplicate_Option (Opt, Part_Of_Seen);
10572 (Indic => First (Choices (Opt)),
10573 Item_Id => State_Id,
10575 Encap_Id => Encap_Id,
10578 -- The Part_Of indicator transforms the abstract state into
10579 -- a constituent of the encapsulating state or single
10580 -- concurrent type.
10583 pragma Assert (Present (Encap_Id));
10584 Constits := Part_Of_Constituents (Encap_Id);
10586 if No (Constits) then
10587 Constits := New_Elmt_List;
10588 Set_Part_Of_Constituents (Encap_Id, Constits);
10591 Append_Elmt (State_Id, Constits);
10592 Set_Encapsulating_State (State_Id, Encap_Id);
10594 end Analyze_Part_Of_Option;
10596 ----------------------------
10597 -- Check_Duplicate_Option --
10598 ----------------------------
10600 procedure Check_Duplicate_Option
10602 Status : in out Boolean)
10606 SPARK_Msg_N ("duplicate state option", Opt);
10610 end Check_Duplicate_Option;
10612 ------------------------------
10613 -- Check_Duplicate_Property --
10614 ------------------------------
10616 procedure Check_Duplicate_Property
10618 Status : in out Boolean)
10622 SPARK_Msg_N ("duplicate external property", Prop);
10626 end Check_Duplicate_Property;
10628 -----------------------------
10629 -- Check_Ghost_Synchronous --
10630 -----------------------------
10632 procedure Check_Ghost_Synchronous is
10634 -- A synchronized abstract state cannot be Ghost and vice
10635 -- versa (SPARK RM 6.9(19)).
10637 if Ghost_Seen and Synchronous_Seen then
10638 SPARK_Msg_N ("synchronized state cannot be ghost", State);
10640 end Check_Ghost_Synchronous;
10642 ---------------------------
10643 -- Create_Abstract_State --
10644 ---------------------------
10646 procedure Create_Abstract_State
10653 -- The abstract state may be semi-declared when the related
10654 -- package was withed through a limited with clause. In that
10655 -- case reuse the entity to fully declare the state.
10657 if Present (Decl) and then Present (Entity (Decl)) then
10658 State_Id := Entity (Decl);
10660 -- Otherwise the elaboration of pragma Abstract_State
10661 -- declares the state.
10664 State_Id := Make_Defining_Identifier (Loc, Nam);
10666 if Present (Decl) then
10667 Set_Entity (Decl, State_Id);
10671 -- Null states never come from source
10673 Set_Comes_From_Source (State_Id, not Is_Null);
10674 Set_Parent (State_Id, State);
10675 Set_Ekind (State_Id, E_Abstract_State);
10676 Set_Etype (State_Id, Standard_Void_Type);
10677 Set_Encapsulating_State (State_Id, Empty);
10679 -- An abstract state declared within a Ghost region becomes
10680 -- Ghost (SPARK RM 6.9(2)).
10682 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
10683 Set_Is_Ghost_Entity (State_Id);
10686 -- Establish a link between the state declaration and the
10687 -- abstract state entity. Note that a null state remains as
10688 -- N_Null and does not carry any linkages.
10690 if not Is_Null then
10691 if Present (Decl) then
10692 Set_Entity (Decl, State_Id);
10693 Set_Etype (Decl, Standard_Void_Type);
10696 -- Every non-null state must be defined, nameable and
10699 Push_Scope (Pack_Id);
10700 Generate_Definition (State_Id);
10701 Enter_Name (State_Id);
10704 end Create_Abstract_State;
10711 -- Start of processing for Analyze_Abstract_State
10714 -- A package with a null abstract state is not allowed to
10715 -- declare additional states.
10719 ("package & has null abstract state", State, Pack_Id);
10721 -- Null states appear as internally generated entities
10723 elsif Nkind (State) = N_Null then
10724 Create_Abstract_State
10725 (Nam => New_Internal_Name ('S'),
10727 Loc => Sloc (State),
10731 -- Catch a case where a null state appears in a list of
10732 -- non-null states.
10734 if Non_Null_Seen then
10736 ("package & has non-null abstract state",
10740 -- Simple state declaration
10742 elsif Nkind (State) = N_Identifier then
10743 Create_Abstract_State
10744 (Nam => Chars (State),
10746 Loc => Sloc (State),
10748 Non_Null_Seen := True;
10750 -- State declaration with various options. This construct
10751 -- appears as an extension aggregate in the tree.
10753 elsif Nkind (State) = N_Extension_Aggregate then
10754 if Nkind (Ancestor_Part (State)) = N_Identifier then
10755 Create_Abstract_State
10756 (Nam => Chars (Ancestor_Part (State)),
10757 Decl => Ancestor_Part (State),
10758 Loc => Sloc (Ancestor_Part (State)),
10760 Non_Null_Seen := True;
10763 ("state name must be an identifier",
10764 Ancestor_Part (State));
10767 -- Options External, Ghost and Synchronous appear as
10770 Opt := First (Expressions (State));
10771 while Present (Opt) loop
10772 if Nkind (Opt) = N_Identifier then
10776 if Chars (Opt) = Name_External then
10777 Check_Duplicate_Option (Opt, External_Seen);
10778 Analyze_External_Option (Opt);
10782 elsif Chars (Opt) = Name_Ghost then
10783 Check_Duplicate_Option (Opt, Ghost_Seen);
10784 Check_Ghost_Synchronous;
10786 if Present (State_Id) then
10787 Set_Is_Ghost_Entity (State_Id);
10792 elsif Chars (Opt) = Name_Synchronous then
10793 Check_Duplicate_Option (Opt, Synchronous_Seen);
10794 Check_Ghost_Synchronous;
10796 -- Option Part_Of without an encapsulating state is
10797 -- illegal (SPARK RM 7.1.4(9)).
10799 elsif Chars (Opt) = Name_Part_Of then
10801 ("indicator Part_Of must denote abstract state, "
10802 & "single protected type or single task type",
10805 -- Do not emit an error message when a previous state
10806 -- declaration with options was not parenthesized as
10807 -- the option is actually another state declaration.
10809 -- with Abstract_State
10810 -- (State_1 with ..., -- missing parentheses
10811 -- (State_2 with ...),
10812 -- State_3) -- ok state declaration
10814 elsif Missing_Parentheses then
10817 -- Otherwise the option is not allowed. Note that it
10818 -- is not possible to distinguish between an option
10819 -- and a state declaration when a previous state with
10820 -- options not properly parentheses.
10822 -- with Abstract_State
10823 -- (State_1 with ..., -- missing parentheses
10824 -- State_2); -- could be an option
10828 ("simple option not allowed in state declaration",
10832 -- Catch a case where missing parentheses around a state
10833 -- declaration with options cause a subsequent state
10834 -- declaration with options to be treated as an option.
10836 -- with Abstract_State
10837 -- (State_1 with ..., -- missing parentheses
10838 -- (State_2 with ...))
10840 elsif Nkind (Opt) = N_Extension_Aggregate then
10841 Missing_Parentheses := True;
10843 ("state declaration must be parenthesized",
10844 Ancestor_Part (State));
10846 -- Otherwise the option is malformed
10849 SPARK_Msg_N ("malformed option", Opt);
10855 -- Options External and Part_Of appear as component
10858 Opt := First (Component_Associations (State));
10859 while Present (Opt) loop
10860 Opt_Nam := First (Choices (Opt));
10862 if Nkind (Opt_Nam) = N_Identifier then
10863 if Chars (Opt_Nam) = Name_External then
10864 Analyze_External_Option (Opt);
10866 elsif Chars (Opt_Nam) = Name_Part_Of then
10867 Analyze_Part_Of_Option (Opt);
10870 SPARK_Msg_N ("invalid state option", Opt);
10873 SPARK_Msg_N ("invalid state option", Opt);
10879 -- Any other attempt to declare a state is illegal
10882 Malformed_State_Error (State);
10886 -- Guard against a junk state. In such cases no entity is
10887 -- generated and the subsequent checks cannot be applied.
10889 if Present (State_Id) then
10891 -- Verify whether the state does not introduce an illegal
10892 -- hidden state within a package subject to a null abstract
10895 Check_No_Hidden_State (State_Id);
10897 -- Check whether the lack of option Part_Of agrees with the
10898 -- placement of the abstract state with respect to the state
10901 if not Part_Of_Seen then
10902 Check_Missing_Part_Of (State_Id);
10905 -- Associate the state with its related package
10907 if No (Abstract_States (Pack_Id)) then
10908 Set_Abstract_States (Pack_Id, New_Elmt_List);
10911 Append_Elmt (State_Id, Abstract_States (Pack_Id));
10913 end Analyze_Abstract_State;
10915 ---------------------------
10916 -- Malformed_State_Error --
10917 ---------------------------
10919 procedure Malformed_State_Error (State : Node_Id) is
10921 Error_Msg_N ("malformed abstract state declaration", State);
10923 -- An abstract state with a simple option is being declared
10924 -- with "=>" rather than the legal "with". The state appears
10925 -- as a component association.
10927 if Nkind (State) = N_Component_Association then
10928 Error_Msg_N ("\use WITH to specify simple option", State);
10930 end Malformed_State_Error;
10934 Pack_Decl : Node_Id;
10935 Pack_Id : Entity_Id;
10939 -- Start of processing for Abstract_State
10943 Check_No_Identifiers;
10944 Check_Arg_Count (1);
10946 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
10948 -- Ensure the proper placement of the pragma. Abstract states must
10949 -- be associated with a package declaration.
10951 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
10952 N_Package_Declaration)
10956 -- Otherwise the pragma is associated with an illegal construct
10963 Pack_Id := Defining_Entity (Pack_Decl);
10965 -- Chain the pragma on the contract for completeness
10967 Add_Contract_Item (N, Pack_Id);
10969 -- The legality checks of pragmas Abstract_State, Initializes, and
10970 -- Initial_Condition are affected by the SPARK mode in effect. In
10971 -- addition, these three pragmas are subject to an inherent order:
10973 -- 1) Abstract_State
10975 -- 3) Initial_Condition
10977 -- Analyze all these pragmas in the order outlined above
10979 Analyze_If_Present (Pragma_SPARK_Mode);
10981 -- A pragma that applies to a Ghost entity becomes Ghost for the
10982 -- purposes of legality checks and removal of ignored Ghost code.
10984 Mark_Pragma_As_Ghost (N, Pack_Id);
10985 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
10987 States := Expression (Get_Argument (N, Pack_Id));
10989 -- Multiple non-null abstract states appear as an aggregate
10991 if Nkind (States) = N_Aggregate then
10992 State := First (Expressions (States));
10993 while Present (State) loop
10994 Analyze_Abstract_State (State, Pack_Id);
10998 -- An abstract state with a simple option is being illegaly
10999 -- declared with "=>" rather than "with". In this case the
11000 -- state declaration appears as a component association.
11002 if Present (Component_Associations (States)) then
11003 State := First (Component_Associations (States));
11004 while Present (State) loop
11005 Malformed_State_Error (State);
11010 -- Various forms of a single abstract state. Note that these may
11011 -- include malformed state declarations.
11014 Analyze_Abstract_State (States, Pack_Id);
11017 Analyze_If_Present (Pragma_Initializes);
11018 Analyze_If_Present (Pragma_Initial_Condition);
11019 end Abstract_State;
11027 -- Note: this pragma also has some specific processing in Par.Prag
11028 -- because we want to set the Ada version mode during parsing.
11030 when Pragma_Ada_83 =>
11032 Check_Arg_Count (0);
11034 -- We really should check unconditionally for proper configuration
11035 -- pragma placement, since we really don't want mixed Ada modes
11036 -- within a single unit, and the GNAT reference manual has always
11037 -- said this was a configuration pragma, but we did not check and
11038 -- are hesitant to add the check now.
11040 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11041 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11042 -- or Ada 2012 mode.
11044 if Ada_Version >= Ada_2005 then
11045 Check_Valid_Configuration_Pragma;
11048 -- Now set Ada 83 mode
11050 if not Latest_Ada_Only then
11051 Ada_Version := Ada_83;
11052 Ada_Version_Explicit := Ada_83;
11053 Ada_Version_Pragma := N;
11062 -- Note: this pragma also has some specific processing in Par.Prag
11063 -- because we want to set the Ada 83 version mode during parsing.
11065 when Pragma_Ada_95 =>
11067 Check_Arg_Count (0);
11069 -- We really should check unconditionally for proper configuration
11070 -- pragma placement, since we really don't want mixed Ada modes
11071 -- within a single unit, and the GNAT reference manual has always
11072 -- said this was a configuration pragma, but we did not check and
11073 -- are hesitant to add the check now.
11075 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11076 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11078 if Ada_Version >= Ada_2005 then
11079 Check_Valid_Configuration_Pragma;
11082 -- Now set Ada 95 mode
11084 if not Latest_Ada_Only then
11085 Ada_Version := Ada_95;
11086 Ada_Version_Explicit := Ada_95;
11087 Ada_Version_Pragma := N;
11090 ---------------------
11091 -- Ada_05/Ada_2005 --
11092 ---------------------
11095 -- pragma Ada_05 (LOCAL_NAME);
11097 -- pragma Ada_2005;
11098 -- pragma Ada_2005 (LOCAL_NAME):
11100 -- Note: these pragmas also have some specific processing in Par.Prag
11101 -- because we want to set the Ada 2005 version mode during parsing.
11103 -- The one argument form is used for managing the transition from
11104 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11105 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11106 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11107 -- mode, a preference rule is established which does not choose
11108 -- such an entity unless it is unambiguously specified. This avoids
11109 -- extra subprograms marked this way from generating ambiguities in
11110 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11111 -- intended for exclusive use in the GNAT run-time library.
11113 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
11119 if Arg_Count = 1 then
11120 Check_Arg_Is_Local_Name (Arg1);
11121 E_Id := Get_Pragma_Arg (Arg1);
11123 if Etype (E_Id) = Any_Type then
11127 Set_Is_Ada_2005_Only (Entity (E_Id));
11128 Record_Rep_Item (Entity (E_Id), N);
11131 Check_Arg_Count (0);
11133 -- For Ada_2005 we unconditionally enforce the documented
11134 -- configuration pragma placement, since we do not want to
11135 -- tolerate mixed modes in a unit involving Ada 2005. That
11136 -- would cause real difficulties for those cases where there
11137 -- are incompatibilities between Ada 95 and Ada 2005.
11139 Check_Valid_Configuration_Pragma;
11141 -- Now set appropriate Ada mode
11143 if not Latest_Ada_Only then
11144 Ada_Version := Ada_2005;
11145 Ada_Version_Explicit := Ada_2005;
11146 Ada_Version_Pragma := N;
11151 ---------------------
11152 -- Ada_12/Ada_2012 --
11153 ---------------------
11156 -- pragma Ada_12 (LOCAL_NAME);
11158 -- pragma Ada_2012;
11159 -- pragma Ada_2012 (LOCAL_NAME):
11161 -- Note: these pragmas also have some specific processing in Par.Prag
11162 -- because we want to set the Ada 2012 version mode during parsing.
11164 -- The one argument form is used for managing the transition from Ada
11165 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11166 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11167 -- mode will generate a warning. In addition, in any pre-Ada_2012
11168 -- mode, a preference rule is established which does not choose
11169 -- such an entity unless it is unambiguously specified. This avoids
11170 -- extra subprograms marked this way from generating ambiguities in
11171 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11172 -- intended for exclusive use in the GNAT run-time library.
11174 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11180 if Arg_Count = 1 then
11181 Check_Arg_Is_Local_Name (Arg1);
11182 E_Id := Get_Pragma_Arg (Arg1);
11184 if Etype (E_Id) = Any_Type then
11188 Set_Is_Ada_2012_Only (Entity (E_Id));
11189 Record_Rep_Item (Entity (E_Id), N);
11192 Check_Arg_Count (0);
11194 -- For Ada_2012 we unconditionally enforce the documented
11195 -- configuration pragma placement, since we do not want to
11196 -- tolerate mixed modes in a unit involving Ada 2012. That
11197 -- would cause real difficulties for those cases where there
11198 -- are incompatibilities between Ada 95 and Ada 2012. We could
11199 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11201 Check_Valid_Configuration_Pragma;
11203 -- Now set appropriate Ada mode
11205 Ada_Version := Ada_2012;
11206 Ada_Version_Explicit := Ada_2012;
11207 Ada_Version_Pragma := N;
11211 ----------------------
11212 -- All_Calls_Remote --
11213 ----------------------
11215 -- pragma All_Calls_Remote [(library_package_NAME)];
11217 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11218 Lib_Entity : Entity_Id;
11221 Check_Ada_83_Warning;
11222 Check_Valid_Library_Unit_Pragma;
11224 if Nkind (N) = N_Null_Statement then
11228 Lib_Entity := Find_Lib_Unit_Name;
11230 -- A pragma that applies to a Ghost entity becomes Ghost for the
11231 -- purposes of legality checks and removal of ignored Ghost code.
11233 Mark_Pragma_As_Ghost (N, Lib_Entity);
11235 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11237 if Present (Lib_Entity) and then not Debug_Flag_U then
11238 if not Is_Remote_Call_Interface (Lib_Entity) then
11239 Error_Pragma ("pragma% only apply to rci unit");
11241 -- Set flag for entity of the library unit
11244 Set_Has_All_Calls_Remote (Lib_Entity);
11247 end All_Calls_Remote;
11249 ---------------------------
11250 -- Allow_Integer_Address --
11251 ---------------------------
11253 -- pragma Allow_Integer_Address;
11255 when Pragma_Allow_Integer_Address =>
11257 Check_Valid_Configuration_Pragma;
11258 Check_Arg_Count (0);
11260 -- If Address is a private type, then set the flag to allow
11261 -- integer address values. If Address is not private, then this
11262 -- pragma has no purpose, so it is simply ignored. Not clear if
11263 -- there are any such targets now.
11265 if Opt.Address_Is_Private then
11266 Opt.Allow_Integer_Address := True;
11274 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11275 -- ARG ::= NAME | EXPRESSION
11277 -- The first two arguments are by convention intended to refer to an
11278 -- external tool and a tool-specific function. These arguments are
11281 when Pragma_Annotate => Annotate : declare
11288 Check_At_Least_N_Arguments (1);
11290 Nam_Arg := Last (Pragma_Argument_Associations (N));
11292 -- Determine whether the last argument is "Entity => local_NAME"
11293 -- and if it is, perform the required semantic checks. Remove the
11294 -- argument from further processing.
11296 if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11297 and then Chars (Nam_Arg) = Name_Entity
11299 Check_Arg_Is_Local_Name (Nam_Arg);
11300 Arg_Count := Arg_Count - 1;
11302 -- A pragma that applies to a Ghost entity becomes Ghost for
11303 -- the purposes of legality checks and removal of ignored Ghost
11306 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11307 and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11309 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11312 -- Not allowed in compiler units (bootstrap issues)
11314 Check_Compiler_Unit ("Entity for pragma Annotate", N);
11317 -- Continue the processing with last argument removed for now
11319 Check_Arg_Is_Identifier (Arg1);
11320 Check_No_Identifiers;
11323 -- The second parameter is optional, it is never analyzed
11328 -- Otherwise there is a second parameter
11331 -- The second parameter must be an identifier
11333 Check_Arg_Is_Identifier (Arg2);
11335 -- Process the remaining parameters (if any)
11337 Arg := Next (Arg2);
11338 while Present (Arg) loop
11339 Expr := Get_Pragma_Arg (Arg);
11342 if Is_Entity_Name (Expr) then
11345 -- For string literals, we assume Standard_String as the
11346 -- type, unless the string contains wide or wide_wide
11349 elsif Nkind (Expr) = N_String_Literal then
11350 if Has_Wide_Wide_Character (Expr) then
11351 Resolve (Expr, Standard_Wide_Wide_String);
11352 elsif Has_Wide_Character (Expr) then
11353 Resolve (Expr, Standard_Wide_String);
11355 Resolve (Expr, Standard_String);
11358 elsif Is_Overloaded (Expr) then
11359 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11370 -------------------------------------------------
11371 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11372 -------------------------------------------------
11375 -- ( [Check => ] Boolean_EXPRESSION
11376 -- [, [Message =>] Static_String_EXPRESSION]);
11378 -- pragma Assert_And_Cut
11379 -- ( [Check => ] Boolean_EXPRESSION
11380 -- [, [Message =>] Static_String_EXPRESSION]);
11383 -- ( [Check => ] Boolean_EXPRESSION
11384 -- [, [Message =>] Static_String_EXPRESSION]);
11386 -- pragma Loop_Invariant
11387 -- ( [Check => ] Boolean_EXPRESSION
11388 -- [, [Message =>] Static_String_EXPRESSION]);
11390 when Pragma_Assert |
11391 Pragma_Assert_And_Cut |
11393 Pragma_Loop_Invariant =>
11395 function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11396 -- Determine whether expression Expr contains a Loop_Entry
11397 -- attribute reference.
11399 -------------------------
11400 -- Contains_Loop_Entry --
11401 -------------------------
11403 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11404 Has_Loop_Entry : Boolean := False;
11406 function Process (N : Node_Id) return Traverse_Result;
11407 -- Process function for traversal to look for Loop_Entry
11413 function Process (N : Node_Id) return Traverse_Result is
11415 if Nkind (N) = N_Attribute_Reference
11416 and then Attribute_Name (N) = Name_Loop_Entry
11418 Has_Loop_Entry := True;
11425 procedure Traverse is new Traverse_Proc (Process);
11427 -- Start of processing for Contains_Loop_Entry
11431 return Has_Loop_Entry;
11432 end Contains_Loop_Entry;
11437 New_Args : List_Id;
11439 -- Start of processing for Assert
11442 -- Assert is an Ada 2005 RM-defined pragma
11444 if Prag_Id = Pragma_Assert then
11447 -- The remaining ones are GNAT pragmas
11453 Check_At_Least_N_Arguments (1);
11454 Check_At_Most_N_Arguments (2);
11455 Check_Arg_Order ((Name_Check, Name_Message));
11456 Check_Optional_Identifier (Arg1, Name_Check);
11457 Expr := Get_Pragma_Arg (Arg1);
11459 -- Special processing for Loop_Invariant, Loop_Variant or for
11460 -- other cases where a Loop_Entry attribute is present. If the
11461 -- assertion pragma contains attribute Loop_Entry, ensure that
11462 -- the related pragma is within a loop.
11464 if Prag_Id = Pragma_Loop_Invariant
11465 or else Prag_Id = Pragma_Loop_Variant
11466 or else Contains_Loop_Entry (Expr)
11468 Check_Loop_Pragma_Placement;
11470 -- Perform preanalysis to deal with embedded Loop_Entry
11473 Preanalyze_Assert_Expression (Expr, Any_Boolean);
11476 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11477 -- a corresponding Check pragma:
11479 -- pragma Check (name, condition [, msg]);
11481 -- Where name is the identifier matching the pragma name. So
11482 -- rewrite pragma in this manner, transfer the message argument
11483 -- if present, and analyze the result
11485 -- Note: When dealing with a semantically analyzed tree, the
11486 -- information that a Check node N corresponds to a source Assert,
11487 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11488 -- pragma kind of Original_Node(N).
11490 New_Args := New_List (
11491 Make_Pragma_Argument_Association (Loc,
11492 Expression => Make_Identifier (Loc, Pname)),
11493 Make_Pragma_Argument_Association (Sloc (Expr),
11494 Expression => Expr));
11496 if Arg_Count > 1 then
11497 Check_Optional_Identifier (Arg2, Name_Message);
11499 -- Provide semantic annnotations for optional argument, for
11500 -- ASIS use, before rewriting.
11502 Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11503 Append_To (New_Args, New_Copy_Tree (Arg2));
11506 -- Rewrite as Check pragma
11510 Chars => Name_Check,
11511 Pragma_Argument_Associations => New_Args));
11516 ----------------------
11517 -- Assertion_Policy --
11518 ----------------------
11520 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11522 -- The following form is Ada 2012 only, but we allow it in all modes
11524 -- Pragma Assertion_Policy (
11525 -- ASSERTION_KIND => POLICY_IDENTIFIER
11526 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11528 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11530 -- RM_ASSERTION_KIND ::= Assert |
11531 -- Static_Predicate |
11532 -- Dynamic_Predicate |
11537 -- Type_Invariant |
11538 -- Type_Invariant'Class
11540 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11542 -- Contract_Cases |
11544 -- Default_Initial_Condition |
11546 -- Initial_Condition |
11547 -- Loop_Invariant |
11553 -- Statement_Assertions
11555 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11556 -- ID_ASSERTION_KIND list contains implementation-defined additions
11557 -- recognized by GNAT. The effect is to control the behavior of
11558 -- identically named aspects and pragmas, depending on the specified
11559 -- policy identifier:
11561 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11563 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11564 -- implementation-defined addition that results in totally ignoring
11565 -- the corresponding assertion. If Disable is specified, then the
11566 -- argument of the assertion is not even analyzed. This is useful
11567 -- when the aspect/pragma argument references entities in a with'ed
11568 -- package that is replaced by a dummy package in the final build.
11570 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11571 -- and Type_Invariant'Class were recognized by the parser and
11572 -- transformed into references to the special internal identifiers
11573 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11574 -- processing is required here.
11576 when Pragma_Assertion_Policy => Assertion_Policy : declare
11585 -- This can always appear as a configuration pragma
11587 if Is_Configuration_Pragma then
11590 -- It can also appear in a declarative part or package spec in Ada
11591 -- 2012 mode. We allow this in other modes, but in that case we
11592 -- consider that we have an Ada 2012 pragma on our hands.
11595 Check_Is_In_Decl_Part_Or_Package_Spec;
11599 -- One argument case with no identifier (first form above)
11602 and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11603 or else Chars (Arg1) = No_Name)
11605 Check_Arg_Is_One_Of
11606 (Arg1, Name_Check, Name_Disable, Name_Ignore);
11608 -- Treat one argument Assertion_Policy as equivalent to:
11610 -- pragma Check_Policy (Assertion, policy)
11612 -- So rewrite pragma in that manner and link on to the chain
11613 -- of Check_Policy pragmas, marking the pragma as analyzed.
11615 Policy := Get_Pragma_Arg (Arg1);
11619 Chars => Name_Check_Policy,
11620 Pragma_Argument_Associations => New_List (
11621 Make_Pragma_Argument_Association (Loc,
11622 Expression => Make_Identifier (Loc, Name_Assertion)),
11624 Make_Pragma_Argument_Association (Loc,
11626 Make_Identifier (Sloc (Policy), Chars (Policy))))));
11629 -- Here if we have two or more arguments
11632 Check_At_Least_N_Arguments (1);
11635 -- Loop through arguments
11638 while Present (Arg) loop
11639 LocP := Sloc (Arg);
11641 -- Kind must be specified
11643 if Nkind (Arg) /= N_Pragma_Argument_Association
11644 or else Chars (Arg) = No_Name
11647 ("missing assertion kind for pragma%", Arg);
11650 -- Check Kind and Policy have allowed forms
11652 Kind := Chars (Arg);
11653 Policy := Get_Pragma_Arg (Arg);
11655 if not Is_Valid_Assertion_Kind (Kind) then
11657 ("invalid assertion kind for pragma%", Arg);
11660 Check_Arg_Is_One_Of
11661 (Arg, Name_Check, Name_Disable, Name_Ignore);
11663 if Kind = Name_Ghost then
11665 -- The Ghost policy must be either Check or Ignore
11666 -- (SPARK RM 6.9(6)).
11668 if not Nam_In (Chars (Policy), Name_Check,
11672 ("argument of pragma % Ghost must be Check or "
11673 & "Ignore", Policy);
11676 -- Pragma Assertion_Policy specifying a Ghost policy
11677 -- cannot occur within a Ghost subprogram or package
11678 -- (SPARK RM 6.9(14)).
11680 if Ghost_Mode > None then
11682 ("pragma % cannot appear within ghost subprogram or "
11687 -- Rewrite the Assertion_Policy pragma as a series of
11688 -- Check_Policy pragmas of the form:
11690 -- Check_Policy (Kind, Policy);
11692 -- Note: the insertion of the pragmas cannot be done with
11693 -- Insert_Action because in the configuration case, there
11694 -- are no scopes on the scope stack and the mechanism will
11697 Insert_Before_And_Analyze (N,
11699 Chars => Name_Check_Policy,
11700 Pragma_Argument_Associations => New_List (
11701 Make_Pragma_Argument_Association (LocP,
11702 Expression => Make_Identifier (LocP, Kind)),
11703 Make_Pragma_Argument_Association (LocP,
11704 Expression => Policy))));
11709 -- Rewrite the Assertion_Policy pragma as null since we have
11710 -- now inserted all the equivalent Check pragmas.
11712 Rewrite (N, Make_Null_Statement (Loc));
11715 end Assertion_Policy;
11717 ------------------------------
11718 -- Assume_No_Invalid_Values --
11719 ------------------------------
11721 -- pragma Assume_No_Invalid_Values (On | Off);
11723 when Pragma_Assume_No_Invalid_Values =>
11725 Check_Valid_Configuration_Pragma;
11726 Check_Arg_Count (1);
11727 Check_No_Identifiers;
11728 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11730 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
11731 Assume_No_Invalid_Values := True;
11733 Assume_No_Invalid_Values := False;
11736 --------------------------
11737 -- Attribute_Definition --
11738 --------------------------
11740 -- pragma Attribute_Definition
11741 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11742 -- [Entity =>] LOCAL_NAME,
11743 -- [Expression =>] EXPRESSION | NAME);
11745 when Pragma_Attribute_Definition => Attribute_Definition : declare
11746 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
11751 Check_Arg_Count (3);
11752 Check_Optional_Identifier (Arg1, "attribute");
11753 Check_Optional_Identifier (Arg2, "entity");
11754 Check_Optional_Identifier (Arg3, "expression");
11756 if Nkind (Attribute_Designator) /= N_Identifier then
11757 Error_Msg_N ("attribute name expected", Attribute_Designator);
11761 Check_Arg_Is_Local_Name (Arg2);
11763 -- If the attribute is not recognized, then issue a warning (not
11764 -- an error), and ignore the pragma.
11766 Aname := Chars (Attribute_Designator);
11768 if not Is_Attribute_Name (Aname) then
11769 Bad_Attribute (Attribute_Designator, Aname, Warn => True);
11773 -- Otherwise, rewrite the pragma as an attribute definition clause
11776 Make_Attribute_Definition_Clause (Loc,
11777 Name => Get_Pragma_Arg (Arg2),
11779 Expression => Get_Pragma_Arg (Arg3)));
11781 end Attribute_Definition;
11783 ------------------------------------------------------------------
11784 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11785 ------------------------------------------------------------------
11787 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11788 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11789 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11790 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11792 when Pragma_Async_Readers |
11793 Pragma_Async_Writers |
11794 Pragma_Effective_Reads |
11795 Pragma_Effective_Writes =>
11796 Async_Effective : declare
11797 Obj_Decl : Node_Id;
11798 Obj_Id : Entity_Id;
11802 Check_No_Identifiers;
11803 Check_At_Most_N_Arguments (1);
11805 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
11807 -- Object declaration
11809 if Nkind (Obj_Decl) = N_Object_Declaration then
11812 -- Otherwise the pragma is associated with an illegal construact
11819 Obj_Id := Defining_Entity (Obj_Decl);
11821 -- Perform minimal verification to ensure that the argument is at
11822 -- least a variable. Subsequent finer grained checks will be done
11823 -- at the end of the declarative region the contains the pragma.
11825 if Ekind (Obj_Id) = E_Variable then
11827 -- Chain the pragma on the contract for further processing by
11828 -- Analyze_External_Property_In_Decl_Part.
11830 Add_Contract_Item (N, Obj_Id);
11832 -- A pragma that applies to a Ghost entity becomes Ghost for
11833 -- the purposes of legality checks and removal of ignored Ghost
11836 Mark_Pragma_As_Ghost (N, Obj_Id);
11838 -- Analyze the Boolean expression (if any)
11840 if Present (Arg1) then
11841 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
11844 -- Otherwise the external property applies to a constant
11847 Error_Pragma ("pragma % must apply to a volatile object");
11849 end Async_Effective;
11855 -- pragma Asynchronous (LOCAL_NAME);
11857 when Pragma_Asynchronous => Asynchronous : declare
11860 Formal : Entity_Id;
11865 procedure Process_Async_Pragma;
11866 -- Common processing for procedure and access-to-procedure case
11868 --------------------------
11869 -- Process_Async_Pragma --
11870 --------------------------
11872 procedure Process_Async_Pragma is
11875 Set_Is_Asynchronous (Nm);
11879 -- The formals should be of mode IN (RM E.4.1(6))
11882 while Present (S) loop
11883 Formal := Defining_Identifier (S);
11885 if Nkind (Formal) = N_Defining_Identifier
11886 and then Ekind (Formal) /= E_In_Parameter
11889 ("pragma% procedure can only have IN parameter",
11896 Set_Is_Asynchronous (Nm);
11897 end Process_Async_Pragma;
11899 -- Start of processing for pragma Asynchronous
11902 Check_Ada_83_Warning;
11903 Check_No_Identifiers;
11904 Check_Arg_Count (1);
11905 Check_Arg_Is_Local_Name (Arg1);
11907 if Debug_Flag_U then
11911 C_Ent := Cunit_Entity (Current_Sem_Unit);
11912 Analyze (Get_Pragma_Arg (Arg1));
11913 Nm := Entity (Get_Pragma_Arg (Arg1));
11915 -- A pragma that applies to a Ghost entity becomes Ghost for the
11916 -- purposes of legality checks and removal of ignored Ghost code.
11918 Mark_Pragma_As_Ghost (N, Nm);
11920 if not Is_Remote_Call_Interface (C_Ent)
11921 and then not Is_Remote_Types (C_Ent)
11923 -- This pragma should only appear in an RCI or Remote Types
11924 -- unit (RM E.4.1(4)).
11927 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11930 if Ekind (Nm) = E_Procedure
11931 and then Nkind (Parent (Nm)) = N_Procedure_Specification
11933 if not Is_Remote_Call_Interface (Nm) then
11935 ("pragma% cannot be applied on non-remote procedure",
11939 L := Parameter_Specifications (Parent (Nm));
11940 Process_Async_Pragma;
11943 elsif Ekind (Nm) = E_Function then
11945 ("pragma% cannot be applied to function", Arg1);
11947 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
11948 if Is_Record_Type (Nm) then
11950 -- A record type that is the Equivalent_Type for a remote
11951 -- access-to-subprogram type.
11953 Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
11956 -- A non-expanded RAS type (distribution is not enabled)
11958 Decl := Declaration_Node (Nm);
11961 if Nkind (Decl) = N_Full_Type_Declaration
11962 and then Nkind (Type_Definition (Decl)) =
11963 N_Access_Procedure_Definition
11965 L := Parameter_Specifications (Type_Definition (Decl));
11966 Process_Async_Pragma;
11968 if Is_Asynchronous (Nm)
11969 and then Expander_Active
11970 and then Get_PCS_Name /= Name_No_DSA
11972 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
11977 ("pragma% cannot reference access-to-function type",
11981 -- Only other possibility is Access-to-class-wide type
11983 elsif Is_Access_Type (Nm)
11984 and then Is_Class_Wide_Type (Designated_Type (Nm))
11986 Check_First_Subtype (Arg1);
11987 Set_Is_Asynchronous (Nm);
11988 if Expander_Active then
11989 RACW_Type_Is_Asynchronous (Nm);
11993 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12001 -- pragma Atomic (LOCAL_NAME);
12003 when Pragma_Atomic =>
12004 Process_Atomic_Independent_Shared_Volatile;
12006 -----------------------
12007 -- Atomic_Components --
12008 -----------------------
12010 -- pragma Atomic_Components (array_LOCAL_NAME);
12012 -- This processing is shared by Volatile_Components
12014 when Pragma_Atomic_Components |
12015 Pragma_Volatile_Components =>
12016 Atomic_Components : declare
12023 Check_Ada_83_Warning;
12024 Check_No_Identifiers;
12025 Check_Arg_Count (1);
12026 Check_Arg_Is_Local_Name (Arg1);
12027 E_Id := Get_Pragma_Arg (Arg1);
12029 if Etype (E_Id) = Any_Type then
12033 E := Entity (E_Id);
12035 -- A pragma that applies to a Ghost entity becomes Ghost for the
12036 -- purposes of legality checks and removal of ignored Ghost code.
12038 Mark_Pragma_As_Ghost (N, E);
12039 Check_Duplicate_Pragma (E);
12041 if Rep_Item_Too_Early (E, N)
12043 Rep_Item_Too_Late (E, N)
12048 D := Declaration_Node (E);
12051 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12053 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12054 and then Nkind (D) = N_Object_Declaration
12055 and then Nkind (Object_Definition (D)) =
12056 N_Constrained_Array_Definition)
12058 -- The flag is set on the object, or on the base type
12060 if Nkind (D) /= N_Object_Declaration then
12061 E := Base_Type (E);
12064 -- Atomic implies both Independent and Volatile
12066 if Prag_Id = Pragma_Atomic_Components then
12067 Set_Has_Atomic_Components (E);
12068 Set_Has_Independent_Components (E);
12071 Set_Has_Volatile_Components (E);
12074 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12076 end Atomic_Components;
12078 --------------------
12079 -- Attach_Handler --
12080 --------------------
12082 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12084 when Pragma_Attach_Handler =>
12085 Check_Ada_83_Warning;
12086 Check_No_Identifiers;
12087 Check_Arg_Count (2);
12089 if No_Run_Time_Mode then
12090 Error_Msg_CRT ("Attach_Handler pragma", N);
12092 Check_Interrupt_Or_Attach_Handler;
12094 -- The expression that designates the attribute may depend on a
12095 -- discriminant, and is therefore a per-object expression, to
12096 -- be expanded in the init proc. If expansion is enabled, then
12097 -- perform semantic checks on a copy only.
12102 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12105 -- In Relaxed_RM_Semantics mode, we allow any static
12106 -- integer value, for compatibility with other compilers.
12108 if Relaxed_RM_Semantics
12109 and then Nkind (Parg2) = N_Integer_Literal
12111 Typ := Standard_Integer;
12113 Typ := RTE (RE_Interrupt_ID);
12116 if Expander_Active then
12117 Temp := New_Copy_Tree (Parg2);
12118 Set_Parent (Temp, N);
12119 Preanalyze_And_Resolve (Temp, Typ);
12122 Resolve (Parg2, Typ);
12126 Process_Interrupt_Or_Attach_Handler;
12129 --------------------
12130 -- C_Pass_By_Copy --
12131 --------------------
12133 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12135 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12141 Check_Valid_Configuration_Pragma;
12142 Check_Arg_Count (1);
12143 Check_Optional_Identifier (Arg1, "max_size");
12145 Arg := Get_Pragma_Arg (Arg1);
12146 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12148 Val := Expr_Value (Arg);
12152 ("maximum size for pragma% must be positive", Arg1);
12154 elsif UI_Is_In_Int_Range (Val) then
12155 Default_C_Record_Mechanism := UI_To_Int (Val);
12157 -- If a giant value is given, Int'Last will do well enough.
12158 -- If sometime someone complains that a record larger than
12159 -- two gigabytes is not copied, we will worry about it then.
12162 Default_C_Record_Mechanism := Mechanism_Type'Last;
12164 end C_Pass_By_Copy;
12170 -- pragma Check ([Name =>] CHECK_KIND,
12171 -- [Check =>] Boolean_EXPRESSION
12172 -- [,[Message =>] String_EXPRESSION]);
12174 -- CHECK_KIND ::= IDENTIFIER |
12177 -- Invariant'Class |
12178 -- Type_Invariant'Class
12180 -- The identifiers Assertions and Statement_Assertions are not
12181 -- allowed, since they have special meaning for Check_Policy.
12183 when Pragma_Check => Check : declare
12189 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
12192 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12193 -- the mode now to ensure that any nodes generated during analysis
12194 -- and expansion are marked as Ghost.
12196 Set_Ghost_Mode (N);
12199 Check_At_Least_N_Arguments (2);
12200 Check_At_Most_N_Arguments (3);
12201 Check_Optional_Identifier (Arg1, Name_Name);
12202 Check_Optional_Identifier (Arg2, Name_Check);
12204 if Arg_Count = 3 then
12205 Check_Optional_Identifier (Arg3, Name_Message);
12206 Str := Get_Pragma_Arg (Arg3);
12209 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12210 Check_Arg_Is_Identifier (Arg1);
12211 Cname := Chars (Get_Pragma_Arg (Arg1));
12213 -- Check forbidden name Assertions or Statement_Assertions
12216 when Name_Assertions =>
12218 ("""Assertions"" is not allowed as a check kind for "
12219 & "pragma%", Arg1);
12221 when Name_Statement_Assertions =>
12223 ("""Statement_Assertions"" is not allowed as a check kind "
12224 & "for pragma%", Arg1);
12230 -- Check applicable policy. We skip this if Checked/Ignored status
12231 -- is already set (e.g. in the case of a pragma from an aspect).
12233 if Is_Checked (N) or else Is_Ignored (N) then
12236 -- For a non-source pragma that is a rewriting of another pragma,
12237 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12239 elsif Is_Rewrite_Substitution (N)
12240 and then Nkind (Original_Node (N)) = N_Pragma
12241 and then Original_Node (N) /= N
12243 Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12244 Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12246 -- Otherwise query the applicable policy at this point
12249 case Check_Kind (Cname) is
12250 when Name_Ignore =>
12251 Set_Is_Ignored (N, True);
12252 Set_Is_Checked (N, False);
12255 Set_Is_Ignored (N, False);
12256 Set_Is_Checked (N, True);
12258 -- For disable, rewrite pragma as null statement and skip
12259 -- rest of the analysis of the pragma.
12261 when Name_Disable =>
12262 Rewrite (N, Make_Null_Statement (Loc));
12266 -- No other possibilities
12269 raise Program_Error;
12273 -- If check kind was not Disable, then continue pragma analysis
12275 Expr := Get_Pragma_Arg (Arg2);
12277 -- Deal with SCO generation
12281 -- Nothing to do for predicates as the checks occur in the
12282 -- client units. The SCO for the aspect in the declaration
12283 -- unit is conservatively always enabled.
12285 when Name_Predicate =>
12288 -- Otherwise mark aspect/pragma SCO as enabled
12291 if Is_Checked (N) and then not Split_PPC (N) then
12292 Set_SCO_Pragma_Enabled (Loc);
12296 -- Deal with analyzing the string argument
12298 if Arg_Count = 3 then
12300 -- If checks are not on we don't want any expansion (since
12301 -- such expansion would not get properly deleted) but
12302 -- we do want to analyze (to get proper references).
12303 -- The Preanalyze_And_Resolve routine does just what we want
12305 if Is_Ignored (N) then
12306 Preanalyze_And_Resolve (Str, Standard_String);
12308 -- Otherwise we need a proper analysis and expansion
12311 Analyze_And_Resolve (Str, Standard_String);
12315 -- Now you might think we could just do the same with the Boolean
12316 -- expression if checks are off (and expansion is on) and then
12317 -- rewrite the check as a null statement. This would work but we
12318 -- would lose the useful warnings about an assertion being bound
12319 -- to fail even if assertions are turned off.
12321 -- So instead we wrap the boolean expression in an if statement
12322 -- that looks like:
12324 -- if False and then condition then
12328 -- The reason we do this rewriting during semantic analysis rather
12329 -- than as part of normal expansion is that we cannot analyze and
12330 -- expand the code for the boolean expression directly, or it may
12331 -- cause insertion of actions that would escape the attempt to
12332 -- suppress the check code.
12334 -- Note that the Sloc for the if statement corresponds to the
12335 -- argument condition, not the pragma itself. The reason for
12336 -- this is that we may generate a warning if the condition is
12337 -- False at compile time, and we do not want to delete this
12338 -- warning when we delete the if statement.
12340 if Expander_Active and Is_Ignored (N) then
12341 Eloc := Sloc (Expr);
12344 Make_If_Statement (Eloc,
12346 Make_And_Then (Eloc,
12347 Left_Opnd => Make_Identifier (Eloc, Name_False),
12348 Right_Opnd => Expr),
12349 Then_Statements => New_List (
12350 Make_Null_Statement (Eloc))));
12352 -- Now go ahead and analyze the if statement
12354 In_Assertion_Expr := In_Assertion_Expr + 1;
12356 -- One rather special treatment. If we are now in Eliminated
12357 -- overflow mode, then suppress overflow checking since we do
12358 -- not want to drag in the bignum stuff if we are in Ignore
12359 -- mode anyway. This is particularly important if we are using
12360 -- a configurable run time that does not support bignum ops.
12362 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12364 Svo : constant Boolean :=
12365 Scope_Suppress.Suppress (Overflow_Check);
12367 Scope_Suppress.Overflow_Mode_Assertions := Strict;
12368 Scope_Suppress.Suppress (Overflow_Check) := True;
12370 Scope_Suppress.Suppress (Overflow_Check) := Svo;
12371 Scope_Suppress.Overflow_Mode_Assertions := Eliminated;
12374 -- Not that special case
12380 -- All done with this check
12382 In_Assertion_Expr := In_Assertion_Expr - 1;
12384 -- Check is active or expansion not active. In these cases we can
12385 -- just go ahead and analyze the boolean with no worries.
12388 In_Assertion_Expr := In_Assertion_Expr + 1;
12389 Analyze_And_Resolve (Expr, Any_Boolean);
12390 In_Assertion_Expr := In_Assertion_Expr - 1;
12393 Ghost_Mode := Save_Ghost_Mode;
12396 --------------------------
12397 -- Check_Float_Overflow --
12398 --------------------------
12400 -- pragma Check_Float_Overflow;
12402 when Pragma_Check_Float_Overflow =>
12404 Check_Valid_Configuration_Pragma;
12405 Check_Arg_Count (0);
12406 Check_Float_Overflow := not Machine_Overflows_On_Target;
12412 -- pragma Check_Name (check_IDENTIFIER);
12414 when Pragma_Check_Name =>
12416 Check_No_Identifiers;
12417 Check_Valid_Configuration_Pragma;
12418 Check_Arg_Count (1);
12419 Check_Arg_Is_Identifier (Arg1);
12422 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12425 for J in Check_Names.First .. Check_Names.Last loop
12426 if Check_Names.Table (J) = Nam then
12431 Check_Names.Append (Nam);
12438 -- This is the old style syntax, which is still allowed in all modes:
12440 -- pragma Check_Policy ([Name =>] CHECK_KIND
12441 -- [Policy =>] POLICY_IDENTIFIER);
12443 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12445 -- CHECK_KIND ::= IDENTIFIER |
12448 -- Type_Invariant'Class |
12451 -- This is the new style syntax, compatible with Assertion_Policy
12452 -- and also allowed in all modes.
12454 -- Pragma Check_Policy (
12455 -- CHECK_KIND => POLICY_IDENTIFIER
12456 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12458 -- Note: the identifiers Name and Policy are not allowed as
12459 -- Check_Kind values. This avoids ambiguities between the old and
12460 -- new form syntax.
12462 when Pragma_Check_Policy => Check_Policy : declare
12467 Check_At_Least_N_Arguments (1);
12469 -- A Check_Policy pragma can appear either as a configuration
12470 -- pragma, or in a declarative part or a package spec (see RM
12471 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12472 -- followed for Check_Policy).
12474 if not Is_Configuration_Pragma then
12475 Check_Is_In_Decl_Part_Or_Package_Spec;
12478 -- Figure out if we have the old or new syntax. We have the
12479 -- old syntax if the first argument has no identifier, or the
12480 -- identifier is Name.
12482 if Nkind (Arg1) /= N_Pragma_Argument_Association
12483 or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12487 Check_Arg_Count (2);
12488 Check_Optional_Identifier (Arg1, Name_Name);
12489 Kind := Get_Pragma_Arg (Arg1);
12490 Rewrite_Assertion_Kind (Kind);
12491 Check_Arg_Is_Identifier (Arg1);
12493 -- Check forbidden check kind
12495 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12496 Error_Msg_Name_2 := Chars (Kind);
12498 ("pragma% does not allow% as check name", Arg1);
12503 Check_Optional_Identifier (Arg2, Name_Policy);
12504 Check_Arg_Is_One_Of
12506 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12508 -- And chain pragma on the Check_Policy_List for search
12510 Set_Next_Pragma (N, Opt.Check_Policy_List);
12511 Opt.Check_Policy_List := N;
12513 -- For the new syntax, what we do is to convert each argument to
12514 -- an old syntax equivalent. We do that because we want to chain
12515 -- old style Check_Policy pragmas for the search (we don't want
12516 -- to have to deal with multiple arguments in the search).
12527 while Present (Arg) loop
12528 LocP := Sloc (Arg);
12529 Argx := Get_Pragma_Arg (Arg);
12531 -- Kind must be specified
12533 if Nkind (Arg) /= N_Pragma_Argument_Association
12534 or else Chars (Arg) = No_Name
12537 ("missing assertion kind for pragma%", Arg);
12540 -- Construct equivalent old form syntax Check_Policy
12541 -- pragma and insert it to get remaining checks.
12545 Chars => Name_Check_Policy,
12546 Pragma_Argument_Associations => New_List (
12547 Make_Pragma_Argument_Association (LocP,
12549 Make_Identifier (LocP, Chars (Arg))),
12550 Make_Pragma_Argument_Association (Sloc (Argx),
12551 Expression => Argx)));
12555 -- For a configuration pragma, insert old form in
12556 -- the corresponding file.
12558 if Is_Configuration_Pragma then
12559 Insert_After (N, New_P);
12563 Insert_Action (N, New_P);
12567 -- Rewrite original Check_Policy pragma to null, since we
12568 -- have converted it into a series of old syntax pragmas.
12570 Rewrite (N, Make_Null_Statement (Loc));
12580 -- pragma Comment (static_string_EXPRESSION)
12582 -- Processing for pragma Comment shares the circuitry for pragma
12583 -- Ident. The only differences are that Ident enforces a limit of 31
12584 -- characters on its argument, and also enforces limitations on
12585 -- placement for DEC compatibility. Pragma Comment shares neither of
12586 -- these restrictions.
12588 -------------------
12589 -- Common_Object --
12590 -------------------
12592 -- pragma Common_Object (
12593 -- [Internal =>] LOCAL_NAME
12594 -- [, [External =>] EXTERNAL_SYMBOL]
12595 -- [, [Size =>] EXTERNAL_SYMBOL]);
12597 -- Processing for this pragma is shared with Psect_Object
12599 ------------------------
12600 -- Compile_Time_Error --
12601 ------------------------
12603 -- pragma Compile_Time_Error
12604 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12606 when Pragma_Compile_Time_Error =>
12608 Process_Compile_Time_Warning_Or_Error;
12610 --------------------------
12611 -- Compile_Time_Warning --
12612 --------------------------
12614 -- pragma Compile_Time_Warning
12615 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12617 when Pragma_Compile_Time_Warning =>
12619 Process_Compile_Time_Warning_Or_Error;
12621 ---------------------------
12622 -- Compiler_Unit_Warning --
12623 ---------------------------
12625 -- pragma Compiler_Unit_Warning;
12629 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12630 -- errors not warnings. This means that we had introduced a big extra
12631 -- inertia to compiler changes, since even if we implemented a new
12632 -- feature, and even if all versions to be used for bootstrapping
12633 -- implemented this new feature, we could not use it, since old
12634 -- compilers would give errors for using this feature in units
12635 -- having Compiler_Unit pragmas.
12637 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12638 -- problem. We no longer have any units mentioning Compiler_Unit,
12639 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12640 -- and thus generates a warning which can be ignored. So that deals
12641 -- with the problem of old compilers not implementing the newer form
12644 -- Newer compilers recognize the new pragma, but generate warning
12645 -- messages instead of errors, which again can be ignored in the
12646 -- case of an old compiler which implements a wanted new feature
12647 -- but at the time felt like warning about it for older compilers.
12649 -- We retain Compiler_Unit so that new compilers can be used to build
12650 -- older run-times that use this pragma. That's an unusual case, but
12651 -- it's easy enough to handle, so why not?
12653 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12655 Check_Arg_Count (0);
12657 -- Only recognized in main unit
12659 if Current_Sem_Unit = Main_Unit then
12660 Compiler_Unit := True;
12663 -----------------------------
12664 -- Complete_Representation --
12665 -----------------------------
12667 -- pragma Complete_Representation;
12669 when Pragma_Complete_Representation =>
12671 Check_Arg_Count (0);
12673 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12675 ("pragma & must appear within record representation clause");
12678 ----------------------------
12679 -- Complex_Representation --
12680 ----------------------------
12682 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12684 when Pragma_Complex_Representation => Complex_Representation : declare
12691 Check_Arg_Count (1);
12692 Check_Optional_Identifier (Arg1, Name_Entity);
12693 Check_Arg_Is_Local_Name (Arg1);
12694 E_Id := Get_Pragma_Arg (Arg1);
12696 if Etype (E_Id) = Any_Type then
12700 E := Entity (E_Id);
12702 if not Is_Record_Type (E) then
12704 ("argument for pragma% must be record type", Arg1);
12707 Ent := First_Entity (E);
12710 or else No (Next_Entity (Ent))
12711 or else Present (Next_Entity (Next_Entity (Ent)))
12712 or else not Is_Floating_Point_Type (Etype (Ent))
12713 or else Etype (Ent) /= Etype (Next_Entity (Ent))
12716 ("record for pragma% must have two fields of the same "
12717 & "floating-point type", Arg1);
12720 Set_Has_Complex_Representation (Base_Type (E));
12722 -- We need to treat the type has having a non-standard
12723 -- representation, for back-end purposes, even though in
12724 -- general a complex will have the default representation
12725 -- of a record with two real components.
12727 Set_Has_Non_Standard_Rep (Base_Type (E));
12729 end Complex_Representation;
12731 -------------------------
12732 -- Component_Alignment --
12733 -------------------------
12735 -- pragma Component_Alignment (
12736 -- [Form =>] ALIGNMENT_CHOICE
12737 -- [, [Name =>] type_LOCAL_NAME]);
12739 -- ALIGNMENT_CHOICE ::=
12741 -- | Component_Size_4
12745 when Pragma_Component_Alignment => Component_AlignmentP : declare
12746 Args : Args_List (1 .. 2);
12747 Names : constant Name_List (1 .. 2) := (
12751 Form : Node_Id renames Args (1);
12752 Name : Node_Id renames Args (2);
12754 Atype : Component_Alignment_Kind;
12759 Gather_Associations (Names, Args);
12762 Error_Pragma ("missing Form argument for pragma%");
12765 Check_Arg_Is_Identifier (Form);
12767 -- Get proper alignment, note that Default = Component_Size on all
12768 -- machines we have so far, and we want to set this value rather
12769 -- than the default value to indicate that it has been explicitly
12770 -- set (and thus will not get overridden by the default component
12771 -- alignment for the current scope)
12773 if Chars (Form) = Name_Component_Size then
12774 Atype := Calign_Component_Size;
12776 elsif Chars (Form) = Name_Component_Size_4 then
12777 Atype := Calign_Component_Size_4;
12779 elsif Chars (Form) = Name_Default then
12780 Atype := Calign_Component_Size;
12782 elsif Chars (Form) = Name_Storage_Unit then
12783 Atype := Calign_Storage_Unit;
12787 ("invalid Form parameter for pragma%", Form);
12790 -- Case with no name, supplied, affects scope table entry
12794 (Scope_Stack.Last).Component_Alignment_Default := Atype;
12796 -- Case of name supplied
12799 Check_Arg_Is_Local_Name (Name);
12801 Typ := Entity (Name);
12804 or else Rep_Item_Too_Early (Typ, N)
12808 Typ := Underlying_Type (Typ);
12811 if not Is_Record_Type (Typ)
12812 and then not Is_Array_Type (Typ)
12815 ("Name parameter of pragma% must identify record or "
12816 & "array type", Name);
12819 -- An explicit Component_Alignment pragma overrides an
12820 -- implicit pragma Pack, but not an explicit one.
12822 if not Has_Pragma_Pack (Base_Type (Typ)) then
12823 Set_Is_Packed (Base_Type (Typ), False);
12824 Set_Component_Alignment (Base_Type (Typ), Atype);
12827 end Component_AlignmentP;
12829 --------------------------------
12830 -- Constant_After_Elaboration --
12831 --------------------------------
12833 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12835 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
12837 Obj_Decl : Node_Id;
12838 Obj_Id : Entity_Id;
12842 Check_No_Identifiers;
12843 Check_At_Most_N_Arguments (1);
12845 Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12847 -- Object declaration
12849 if Nkind (Obj_Decl) = N_Object_Declaration then
12852 -- Otherwise the pragma is associated with an illegal construct
12859 Obj_Id := Defining_Entity (Obj_Decl);
12861 -- The object declaration must be a library-level variable which
12862 -- is either explicitly initialized or obtains a value during the
12863 -- elaboration of a package body (SPARK RM 3.3.1).
12865 if Ekind (Obj_Id) = E_Variable then
12866 if not Is_Library_Level_Entity (Obj_Id) then
12868 ("pragma % must apply to a library level variable");
12872 -- Otherwise the pragma applies to a constant, which is illegal
12875 Error_Pragma ("pragma % must apply to a variable declaration");
12879 -- Chain the pragma on the contract for completeness
12881 Add_Contract_Item (N, Obj_Id);
12883 -- A pragma that applies to a Ghost entity becomes Ghost for the
12884 -- purposes of legality checks and removal of ignored Ghost code.
12886 Mark_Pragma_As_Ghost (N, Obj_Id);
12888 -- Analyze the Boolean expression (if any)
12890 if Present (Arg1) then
12891 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12893 end Constant_After_Elaboration;
12895 --------------------
12896 -- Contract_Cases --
12897 --------------------
12899 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12901 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12903 -- CASE_GUARD ::= boolean_EXPRESSION | others
12905 -- CONSEQUENCE ::= boolean_EXPRESSION
12907 -- Characteristics:
12909 -- * Analysis - The annotation undergoes initial checks to verify
12910 -- the legal placement and context. Secondary checks preanalyze the
12913 -- Analyze_Contract_Cases_In_Decl_Part
12915 -- * Expansion - The annotation is expanded during the expansion of
12916 -- the related subprogram [body] contract as performed in:
12918 -- Expand_Subprogram_Contract
12920 -- * Template - The annotation utilizes the generic template of the
12921 -- related subprogram [body] when it is:
12923 -- aspect on subprogram declaration
12924 -- aspect on stand alone subprogram body
12925 -- pragma on stand alone subprogram body
12927 -- The annotation must prepare its own template when it is:
12929 -- pragma on subprogram declaration
12931 -- * Globals - Capture of global references must occur after full
12934 -- * Instance - The annotation is instantiated automatically when
12935 -- the related generic subprogram [body] is instantiated except for
12936 -- the "pragma on subprogram declaration" case. In that scenario
12937 -- the annotation must instantiate itself.
12939 when Pragma_Contract_Cases => Contract_Cases : declare
12940 Spec_Id : Entity_Id;
12941 Subp_Decl : Node_Id;
12945 Check_No_Identifiers;
12946 Check_Arg_Count (1);
12948 -- Ensure the proper placement of the pragma. Contract_Cases must
12949 -- be associated with a subprogram declaration or a body that acts
12953 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
12957 if Nkind (Subp_Decl) = N_Entry_Declaration then
12960 -- Generic subprogram
12962 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
12965 -- Body acts as spec
12967 elsif Nkind (Subp_Decl) = N_Subprogram_Body
12968 and then No (Corresponding_Spec (Subp_Decl))
12972 -- Body stub acts as spec
12974 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
12975 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
12981 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
12989 Spec_Id := Unique_Defining_Entity (Subp_Decl);
12991 -- Chain the pragma on the contract for further processing by
12992 -- Analyze_Contract_Cases_In_Decl_Part.
12994 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
12996 -- A pragma that applies to a Ghost entity becomes Ghost for the
12997 -- purposes of legality checks and removal of ignored Ghost code.
12999 Mark_Pragma_As_Ghost (N, Spec_Id);
13000 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13002 -- Fully analyze the pragma when it appears inside an entry
13003 -- or subprogram body because it cannot benefit from forward
13006 if Nkind_In (Subp_Decl, N_Entry_Body,
13008 N_Subprogram_Body_Stub)
13010 -- The legality checks of pragma Contract_Cases are affected by
13011 -- the SPARK mode in effect and the volatility of the context.
13012 -- Analyze all pragmas in a specific order.
13014 Analyze_If_Present (Pragma_SPARK_Mode);
13015 Analyze_If_Present (Pragma_Volatile_Function);
13016 Analyze_Contract_Cases_In_Decl_Part (N);
13018 end Contract_Cases;
13024 -- pragma Controlled (first_subtype_LOCAL_NAME);
13026 when Pragma_Controlled => Controlled : declare
13030 Check_No_Identifiers;
13031 Check_Arg_Count (1);
13032 Check_Arg_Is_Local_Name (Arg1);
13033 Arg := Get_Pragma_Arg (Arg1);
13035 if not Is_Entity_Name (Arg)
13036 or else not Is_Access_Type (Entity (Arg))
13038 Error_Pragma_Arg ("pragma% requires access type", Arg1);
13040 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13048 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13049 -- [Entity =>] LOCAL_NAME);
13051 when Pragma_Convention => Convention : declare
13054 pragma Warnings (Off, C);
13055 pragma Warnings (Off, E);
13057 Check_Arg_Order ((Name_Convention, Name_Entity));
13058 Check_Ada_83_Warning;
13059 Check_Arg_Count (2);
13060 Process_Convention (C, E);
13062 -- A pragma that applies to a Ghost entity becomes Ghost for the
13063 -- purposes of legality checks and removal of ignored Ghost code.
13065 Mark_Pragma_As_Ghost (N, E);
13068 ---------------------------
13069 -- Convention_Identifier --
13070 ---------------------------
13072 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13073 -- [Convention =>] convention_IDENTIFIER);
13075 when Pragma_Convention_Identifier => Convention_Identifier : declare
13081 Check_Arg_Order ((Name_Name, Name_Convention));
13082 Check_Arg_Count (2);
13083 Check_Optional_Identifier (Arg1, Name_Name);
13084 Check_Optional_Identifier (Arg2, Name_Convention);
13085 Check_Arg_Is_Identifier (Arg1);
13086 Check_Arg_Is_Identifier (Arg2);
13087 Idnam := Chars (Get_Pragma_Arg (Arg1));
13088 Cname := Chars (Get_Pragma_Arg (Arg2));
13090 if Is_Convention_Name (Cname) then
13091 Record_Convention_Identifier
13092 (Idnam, Get_Convention_Id (Cname));
13095 ("second arg for % pragma must be convention", Arg2);
13097 end Convention_Identifier;
13103 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13105 when Pragma_CPP_Class => CPP_Class : declare
13109 if Warn_On_Obsolescent_Feature then
13111 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13112 & "effect; replace it by pragma import?j?", N);
13115 Check_Arg_Count (1);
13119 Chars => Name_Import,
13120 Pragma_Argument_Associations => New_List (
13121 Make_Pragma_Argument_Association (Loc,
13122 Expression => Make_Identifier (Loc, Name_CPP)),
13123 New_Copy (First (Pragma_Argument_Associations (N))))));
13127 ---------------------
13128 -- CPP_Constructor --
13129 ---------------------
13131 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13132 -- [, [External_Name =>] static_string_EXPRESSION ]
13133 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13135 when Pragma_CPP_Constructor => CPP_Constructor : declare
13138 Def_Id : Entity_Id;
13139 Tag_Typ : Entity_Id;
13143 Check_At_Least_N_Arguments (1);
13144 Check_At_Most_N_Arguments (3);
13145 Check_Optional_Identifier (Arg1, Name_Entity);
13146 Check_Arg_Is_Local_Name (Arg1);
13148 Id := Get_Pragma_Arg (Arg1);
13149 Find_Program_Unit_Name (Id);
13151 -- If we did not find the name, we are done
13153 if Etype (Id) = Any_Type then
13157 Def_Id := Entity (Id);
13159 -- Check if already defined as constructor
13161 if Is_Constructor (Def_Id) then
13163 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13167 if Ekind (Def_Id) = E_Function
13168 and then (Is_CPP_Class (Etype (Def_Id))
13169 or else (Is_Class_Wide_Type (Etype (Def_Id))
13171 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13173 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13175 ("'C'P'P constructor must be defined in the scope of "
13176 & "its returned type", Arg1);
13179 if Arg_Count >= 2 then
13180 Set_Imported (Def_Id);
13181 Set_Is_Public (Def_Id);
13182 Process_Interface_Name (Def_Id, Arg2, Arg3);
13185 Set_Has_Completion (Def_Id);
13186 Set_Is_Constructor (Def_Id);
13187 Set_Convention (Def_Id, Convention_CPP);
13189 -- Imported C++ constructors are not dispatching primitives
13190 -- because in C++ they don't have a dispatch table slot.
13191 -- However, in Ada the constructor has the profile of a
13192 -- function that returns a tagged type and therefore it has
13193 -- been treated as a primitive operation during semantic
13194 -- analysis. We now remove it from the list of primitive
13195 -- operations of the type.
13197 if Is_Tagged_Type (Etype (Def_Id))
13198 and then not Is_Class_Wide_Type (Etype (Def_Id))
13199 and then Is_Dispatching_Operation (Def_Id)
13201 Tag_Typ := Etype (Def_Id);
13203 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13204 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13208 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13209 Set_Is_Dispatching_Operation (Def_Id, False);
13212 -- For backward compatibility, if the constructor returns a
13213 -- class wide type, and we internally change the return type to
13214 -- the corresponding root type.
13216 if Is_Class_Wide_Type (Etype (Def_Id)) then
13217 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13221 ("pragma% requires function returning a 'C'P'P_Class type",
13224 end CPP_Constructor;
13230 when Pragma_CPP_Virtual => CPP_Virtual : declare
13234 if Warn_On_Obsolescent_Feature then
13236 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13245 when Pragma_CPP_Vtable => CPP_Vtable : declare
13249 if Warn_On_Obsolescent_Feature then
13251 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13260 -- pragma CPU (EXPRESSION);
13262 when Pragma_CPU => CPU : declare
13263 P : constant Node_Id := Parent (N);
13269 Check_No_Identifiers;
13270 Check_Arg_Count (1);
13274 if Nkind (P) = N_Subprogram_Body then
13275 Check_In_Main_Program;
13277 Arg := Get_Pragma_Arg (Arg1);
13278 Analyze_And_Resolve (Arg, Any_Integer);
13280 Ent := Defining_Unit_Name (Specification (P));
13282 if Nkind (Ent) = N_Defining_Program_Unit_Name then
13283 Ent := Defining_Identifier (Ent);
13288 if not Is_OK_Static_Expression (Arg) then
13289 Flag_Non_Static_Expr
13290 ("main subprogram affinity is not static!", Arg);
13293 -- If constraint error, then we already signalled an error
13295 elsif Raises_Constraint_Error (Arg) then
13298 -- Otherwise check in range
13302 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13303 -- This is the entity System.Multiprocessors.CPU_Range;
13305 Val : constant Uint := Expr_Value (Arg);
13308 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13310 Val > Expr_Value (Type_High_Bound (CPU_Id))
13313 ("main subprogram CPU is out of range", Arg1);
13319 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13323 elsif Nkind (P) = N_Task_Definition then
13324 Arg := Get_Pragma_Arg (Arg1);
13325 Ent := Defining_Identifier (Parent (P));
13327 -- The expression must be analyzed in the special manner
13328 -- described in "Handling of Default and Per-Object
13329 -- Expressions" in sem.ads.
13331 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13333 -- Anything else is incorrect
13339 -- Check duplicate pragma before we chain the pragma in the Rep
13340 -- Item chain of Ent.
13342 Check_Duplicate_Pragma (Ent);
13343 Record_Rep_Item (Ent, N);
13350 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13352 when Pragma_Debug => Debug : declare
13359 -- The condition for executing the call is that the expander
13360 -- is active and that we are not ignoring this debug pragma.
13365 (Expander_Active and then not Is_Ignored (N)),
13368 if not Is_Ignored (N) then
13369 Set_SCO_Pragma_Enabled (Loc);
13372 if Arg_Count = 2 then
13374 Make_And_Then (Loc,
13375 Left_Opnd => Relocate_Node (Cond),
13376 Right_Opnd => Get_Pragma_Arg (Arg1));
13377 Call := Get_Pragma_Arg (Arg2);
13379 Call := Get_Pragma_Arg (Arg1);
13383 N_Indexed_Component,
13387 N_Selected_Component)
13389 -- If this pragma Debug comes from source, its argument was
13390 -- parsed as a name form (which is syntactically identical).
13391 -- In a generic context a parameterless call will be left as
13392 -- an expanded name (if global) or selected_component if local.
13393 -- Change it to a procedure call statement now.
13395 Change_Name_To_Procedure_Call_Statement (Call);
13397 elsif Nkind (Call) = N_Procedure_Call_Statement then
13399 -- Already in the form of a procedure call statement: nothing
13400 -- to do (could happen in case of an internally generated
13406 -- All other cases: diagnose error
13409 ("argument of pragma ""Debug"" is not procedure call",
13414 -- Rewrite into a conditional with an appropriate condition. We
13415 -- wrap the procedure call in a block so that overhead from e.g.
13416 -- use of the secondary stack does not generate execution overhead
13417 -- for suppressed conditions.
13419 -- Normally the analysis that follows will freeze the subprogram
13420 -- being called. However, if the call is to a null procedure,
13421 -- we want to freeze it before creating the block, because the
13422 -- analysis that follows may be done with expansion disabled, in
13423 -- which case the body will not be generated, leading to spurious
13426 if Nkind (Call) = N_Procedure_Call_Statement
13427 and then Is_Entity_Name (Name (Call))
13429 Analyze (Name (Call));
13430 Freeze_Before (N, Entity (Name (Call)));
13434 Make_Implicit_If_Statement (N,
13436 Then_Statements => New_List (
13437 Make_Block_Statement (Loc,
13438 Handled_Statement_Sequence =>
13439 Make_Handled_Sequence_Of_Statements (Loc,
13440 Statements => New_List (Relocate_Node (Call)))))));
13443 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13444 -- after analysis of the normally rewritten node, to capture all
13445 -- references to entities, which avoids issuing wrong warnings
13446 -- about unused entities.
13448 if GNATprove_Mode then
13449 Rewrite (N, Make_Null_Statement (Loc));
13457 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13459 when Pragma_Debug_Policy =>
13461 Check_Arg_Count (1);
13462 Check_No_Identifiers;
13463 Check_Arg_Is_Identifier (Arg1);
13465 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13466 -- rewrite it that way, and let the rest of the checking come
13467 -- from analyzing the rewritten pragma.
13471 Chars => Name_Check_Policy,
13472 Pragma_Argument_Associations => New_List (
13473 Make_Pragma_Argument_Association (Loc,
13474 Expression => Make_Identifier (Loc, Name_Debug)),
13476 Make_Pragma_Argument_Association (Loc,
13477 Expression => Get_Pragma_Arg (Arg1)))));
13480 -------------------------------
13481 -- Default_Initial_Condition --
13482 -------------------------------
13484 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13486 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13493 Check_No_Identifiers;
13494 Check_At_Most_N_Arguments (1);
13497 while Present (Stmt) loop
13499 -- Skip prior pragmas, but check for duplicates
13501 if Nkind (Stmt) = N_Pragma then
13502 if Pragma_Name (Stmt) = Pname then
13503 Error_Msg_Name_1 := Pname;
13504 Error_Msg_Sloc := Sloc (Stmt);
13505 Error_Msg_N ("pragma % duplicates pragma declared#", N);
13508 -- Skip internally generated code
13510 elsif not Comes_From_Source (Stmt) then
13513 -- The associated private type [extension] has been found, stop
13516 elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13517 N_Private_Type_Declaration)
13519 Typ := Defining_Entity (Stmt);
13522 -- The pragma does not apply to a legal construct, issue an
13523 -- error and stop the analysis.
13530 Stmt := Prev (Stmt);
13533 -- A pragma that applies to a Ghost entity becomes Ghost for the
13534 -- purposes of legality checks and removal of ignored Ghost code.
13536 Mark_Pragma_As_Ghost (N, Typ);
13537 Set_Has_Default_Init_Cond (Typ);
13538 Set_Has_Inherited_Default_Init_Cond (Typ, False);
13540 -- Chain the pragma on the rep item chain for further processing
13542 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13543 end Default_Init_Cond;
13545 ----------------------------------
13546 -- Default_Scalar_Storage_Order --
13547 ----------------------------------
13549 -- pragma Default_Scalar_Storage_Order
13550 -- (High_Order_First | Low_Order_First);
13552 when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13553 Default : Character;
13557 Check_Arg_Count (1);
13559 -- Default_Scalar_Storage_Order can appear as a configuration
13560 -- pragma, or in a declarative part of a package spec.
13562 if not Is_Configuration_Pragma then
13563 Check_Is_In_Decl_Part_Or_Package_Spec;
13566 Check_No_Identifiers;
13567 Check_Arg_Is_One_Of
13568 (Arg1, Name_High_Order_First, Name_Low_Order_First);
13569 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13570 Default := Fold_Upper (Name_Buffer (1));
13572 if not Support_Nondefault_SSO_On_Target
13573 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13575 if Warn_On_Unrecognized_Pragma then
13577 ("non-default Scalar_Storage_Order not supported "
13578 & "on target?g?", N);
13580 ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13583 -- Here set the specified default
13586 Opt.Default_SSO := Default;
13590 --------------------------
13591 -- Default_Storage_Pool --
13592 --------------------------
13594 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13596 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13601 Check_Arg_Count (1);
13603 -- Default_Storage_Pool can appear as a configuration pragma, or
13604 -- in a declarative part of a package spec.
13606 if not Is_Configuration_Pragma then
13607 Check_Is_In_Decl_Part_Or_Package_Spec;
13610 if From_Aspect_Specification (N) then
13612 E : constant Entity_Id := Entity (Corresponding_Aspect (N));
13614 if not In_Open_Scopes (E) then
13616 ("aspect must apply to package or subprogram", N);
13621 if Present (Arg1) then
13622 Pool := Get_Pragma_Arg (Arg1);
13624 -- Case of Default_Storage_Pool (null);
13626 if Nkind (Pool) = N_Null then
13629 -- This is an odd case, this is not really an expression,
13630 -- so we don't have a type for it. So just set the type to
13633 Set_Etype (Pool, Empty);
13635 -- Case of Default_Storage_Pool (storage_pool_NAME);
13638 -- If it's a configuration pragma, then the only allowed
13639 -- argument is "null".
13641 if Is_Configuration_Pragma then
13642 Error_Pragma_Arg ("NULL expected", Arg1);
13645 -- The expected type for a non-"null" argument is
13646 -- Root_Storage_Pool'Class, and the pool must be a variable.
13648 Analyze_And_Resolve
13649 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13651 if Is_Variable (Pool) then
13653 -- A pragma that applies to a Ghost entity becomes Ghost
13654 -- for the purposes of legality checks and removal of
13655 -- ignored Ghost code.
13657 Mark_Pragma_As_Ghost (N, Entity (Pool));
13661 ("default storage pool must be a variable", Arg1);
13665 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13666 -- access type will use this information to set the appropriate
13667 -- attributes of the access type.
13669 Default_Pool := Pool;
13671 end Default_Storage_Pool;
13677 -- pragma Depends (DEPENDENCY_RELATION);
13679 -- DEPENDENCY_RELATION ::=
13681 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
13683 -- DEPENDENCY_CLAUSE ::=
13684 -- OUTPUT_LIST =>[+] INPUT_LIST
13685 -- | NULL_DEPENDENCY_CLAUSE
13687 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13689 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13691 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13693 -- OUTPUT ::= NAME | FUNCTION_RESULT
13696 -- where FUNCTION_RESULT is a function Result attribute_reference
13698 -- Characteristics:
13700 -- * Analysis - The annotation undergoes initial checks to verify
13701 -- the legal placement and context. Secondary checks fully analyze
13702 -- the dependency clauses in:
13704 -- Analyze_Depends_In_Decl_Part
13706 -- * Expansion - None.
13708 -- * Template - The annotation utilizes the generic template of the
13709 -- related subprogram [body] when it is:
13711 -- aspect on subprogram declaration
13712 -- aspect on stand alone subprogram body
13713 -- pragma on stand alone subprogram body
13715 -- The annotation must prepare its own template when it is:
13717 -- pragma on subprogram declaration
13719 -- * Globals - Capture of global references must occur after full
13722 -- * Instance - The annotation is instantiated automatically when
13723 -- the related generic subprogram [body] is instantiated except for
13724 -- the "pragma on subprogram declaration" case. In that scenario
13725 -- the annotation must instantiate itself.
13727 when Pragma_Depends => Depends : declare
13729 Spec_Id : Entity_Id;
13730 Subp_Decl : Node_Id;
13733 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
13737 -- Chain the pragma on the contract for further processing by
13738 -- Analyze_Depends_In_Decl_Part.
13740 Add_Contract_Item (N, Spec_Id);
13742 -- Fully analyze the pragma when it appears inside an entry
13743 -- or subprogram body because it cannot benefit from forward
13746 if Nkind_In (Subp_Decl, N_Entry_Body,
13748 N_Subprogram_Body_Stub)
13750 -- The legality checks of pragmas Depends and Global are
13751 -- affected by the SPARK mode in effect and the volatility
13752 -- of the context. In addition these two pragmas are subject
13753 -- to an inherent order:
13758 -- Analyze all these pragmas in the order outlined above
13760 Analyze_If_Present (Pragma_SPARK_Mode);
13761 Analyze_If_Present (Pragma_Volatile_Function);
13762 Analyze_If_Present (Pragma_Global);
13763 Analyze_Depends_In_Decl_Part (N);
13768 ---------------------
13769 -- Detect_Blocking --
13770 ---------------------
13772 -- pragma Detect_Blocking;
13774 when Pragma_Detect_Blocking =>
13776 Check_Arg_Count (0);
13777 Check_Valid_Configuration_Pragma;
13778 Detect_Blocking := True;
13780 ------------------------------------
13781 -- Disable_Atomic_Synchronization --
13782 ------------------------------------
13784 -- pragma Disable_Atomic_Synchronization [(Entity)];
13786 when Pragma_Disable_Atomic_Synchronization =>
13788 Process_Disable_Enable_Atomic_Sync (Name_Suppress);
13790 -------------------
13791 -- Discard_Names --
13792 -------------------
13794 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13796 when Pragma_Discard_Names => Discard_Names : declare
13801 Check_Ada_83_Warning;
13803 -- Deal with configuration pragma case
13805 if Arg_Count = 0 and then Is_Configuration_Pragma then
13806 Global_Discard_Names := True;
13809 -- Otherwise, check correct appropriate context
13812 Check_Is_In_Decl_Part_Or_Package_Spec;
13814 if Arg_Count = 0 then
13816 -- If there is no parameter, then from now on this pragma
13817 -- applies to any enumeration, exception or tagged type
13818 -- defined in the current declarative part, and recursively
13819 -- to any nested scope.
13821 Set_Discard_Names (Current_Scope);
13825 Check_Arg_Count (1);
13826 Check_Optional_Identifier (Arg1, Name_On);
13827 Check_Arg_Is_Local_Name (Arg1);
13829 E_Id := Get_Pragma_Arg (Arg1);
13831 if Etype (E_Id) = Any_Type then
13834 E := Entity (E_Id);
13837 -- A pragma that applies to a Ghost entity becomes Ghost for
13838 -- the purposes of legality checks and removal of ignored
13841 Mark_Pragma_As_Ghost (N, E);
13843 if (Is_First_Subtype (E)
13845 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
13846 or else Ekind (E) = E_Exception
13848 Set_Discard_Names (E);
13849 Record_Rep_Item (E, N);
13853 ("inappropriate entity for pragma%", Arg1);
13859 ------------------------
13860 -- Dispatching_Domain --
13861 ------------------------
13863 -- pragma Dispatching_Domain (EXPRESSION);
13865 when Pragma_Dispatching_Domain => Dispatching_Domain : declare
13866 P : constant Node_Id := Parent (N);
13872 Check_No_Identifiers;
13873 Check_Arg_Count (1);
13875 -- This pragma is born obsolete, but not the aspect
13877 if not From_Aspect_Specification (N) then
13879 (No_Obsolescent_Features, Pragma_Identifier (N));
13882 if Nkind (P) = N_Task_Definition then
13883 Arg := Get_Pragma_Arg (Arg1);
13884 Ent := Defining_Identifier (Parent (P));
13886 -- A pragma that applies to a Ghost entity becomes Ghost for
13887 -- the purposes of legality checks and removal of ignored Ghost
13890 Mark_Pragma_As_Ghost (N, Ent);
13892 -- The expression must be analyzed in the special manner
13893 -- described in "Handling of Default and Per-Object
13894 -- Expressions" in sem.ads.
13896 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
13898 -- Check duplicate pragma before we chain the pragma in the Rep
13899 -- Item chain of Ent.
13901 Check_Duplicate_Pragma (Ent);
13902 Record_Rep_Item (Ent, N);
13904 -- Anything else is incorrect
13909 end Dispatching_Domain;
13915 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13917 when Pragma_Elaborate => Elaborate : declare
13922 -- Pragma must be in context items list of a compilation unit
13924 if not Is_In_Context_Clause then
13928 -- Must be at least one argument
13930 if Arg_Count = 0 then
13931 Error_Pragma ("pragma% requires at least one argument");
13934 -- In Ada 83 mode, there can be no items following it in the
13935 -- context list except other pragmas and implicit with clauses
13936 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13937 -- placement rule does not apply.
13939 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
13941 while Present (Citem) loop
13942 if Nkind (Citem) = N_Pragma
13943 or else (Nkind (Citem) = N_With_Clause
13944 and then Implicit_With (Citem))
13949 ("(Ada 83) pragma% must be at end of context clause");
13956 -- Finally, the arguments must all be units mentioned in a with
13957 -- clause in the same context clause. Note we already checked (in
13958 -- Par.Prag) that the arguments are all identifiers or selected
13962 Outer : while Present (Arg) loop
13963 Citem := First (List_Containing (N));
13964 Inner : while Citem /= N loop
13965 if Nkind (Citem) = N_With_Clause
13966 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
13968 Set_Elaborate_Present (Citem, True);
13969 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
13971 -- With the pragma present, elaboration calls on
13972 -- subprograms from the named unit need no further
13973 -- checks, as long as the pragma appears in the current
13974 -- compilation unit. If the pragma appears in some unit
13975 -- in the context, there might still be a need for an
13976 -- Elaborate_All_Desirable from the current compilation
13977 -- to the named unit, so we keep the check enabled.
13979 if In_Extended_Main_Source_Unit (N) then
13981 -- This does not apply in SPARK mode, where we allow
13982 -- pragma Elaborate, but we don't trust it to be right
13983 -- so we will still insist on the Elaborate_All.
13985 if SPARK_Mode /= On then
13986 Set_Suppress_Elaboration_Warnings
13987 (Entity (Name (Citem)));
13999 ("argument of pragma% is not withed unit", Arg);
14005 -- Give a warning if operating in static mode with one of the
14006 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14009 and not Dynamic_Elaboration_Checks
14011 -- pragma Elaborate not allowed in SPARK mode anyway. We
14012 -- already complained about it, no point in generating any
14013 -- further complaint.
14015 and SPARK_Mode /= On
14018 ("?l?use of pragma Elaborate may not be safe", N);
14020 ("?l?use pragma Elaborate_All instead if possible", N);
14024 -------------------
14025 -- Elaborate_All --
14026 -------------------
14028 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14030 when Pragma_Elaborate_All => Elaborate_All : declare
14035 Check_Ada_83_Warning;
14037 -- Pragma must be in context items list of a compilation unit
14039 if not Is_In_Context_Clause then
14043 -- Must be at least one argument
14045 if Arg_Count = 0 then
14046 Error_Pragma ("pragma% requires at least one argument");
14049 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14050 -- have to appear at the end of the context clause, but may
14051 -- appear mixed in with other items, even in Ada 83 mode.
14053 -- Final check: the arguments must all be units mentioned in
14054 -- a with clause in the same context clause. Note that we
14055 -- already checked (in Par.Prag) that all the arguments are
14056 -- either identifiers or selected components.
14059 Outr : while Present (Arg) loop
14060 Citem := First (List_Containing (N));
14061 Innr : while Citem /= N loop
14062 if Nkind (Citem) = N_With_Clause
14063 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14065 Set_Elaborate_All_Present (Citem, True);
14066 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14068 -- Suppress warnings and elaboration checks on the named
14069 -- unit if the pragma is in the current compilation, as
14070 -- for pragma Elaborate.
14072 if In_Extended_Main_Source_Unit (N) then
14073 Set_Suppress_Elaboration_Warnings
14074 (Entity (Name (Citem)));
14083 Set_Error_Posted (N);
14085 ("argument of pragma% is not withed unit", Arg);
14092 --------------------
14093 -- Elaborate_Body --
14094 --------------------
14096 -- pragma Elaborate_Body [( library_unit_NAME )];
14098 when Pragma_Elaborate_Body => Elaborate_Body : declare
14099 Cunit_Node : Node_Id;
14100 Cunit_Ent : Entity_Id;
14103 Check_Ada_83_Warning;
14104 Check_Valid_Library_Unit_Pragma;
14106 if Nkind (N) = N_Null_Statement then
14110 Cunit_Node := Cunit (Current_Sem_Unit);
14111 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
14113 -- A pragma that applies to a Ghost entity becomes Ghost for the
14114 -- purposes of legality checks and removal of ignored Ghost code.
14116 Mark_Pragma_As_Ghost (N, Cunit_Ent);
14118 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14121 Error_Pragma ("pragma% must refer to a spec, not a body");
14123 Set_Body_Required (Cunit_Node, True);
14124 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14126 -- If we are in dynamic elaboration mode, then we suppress
14127 -- elaboration warnings for the unit, since it is definitely
14128 -- fine NOT to do dynamic checks at the first level (and such
14129 -- checks will be suppressed because no elaboration boolean
14130 -- is created for Elaborate_Body packages).
14132 -- But in the static model of elaboration, Elaborate_Body is
14133 -- definitely NOT good enough to ensure elaboration safety on
14134 -- its own, since the body may WITH other units that are not
14135 -- safe from an elaboration point of view, so a client must
14136 -- still do an Elaborate_All on such units.
14138 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14139 -- Elaborate_Body always suppressed elab warnings.
14141 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14142 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14145 end Elaborate_Body;
14147 ------------------------
14148 -- Elaboration_Checks --
14149 ------------------------
14151 -- pragma Elaboration_Checks (Static | Dynamic);
14153 when Pragma_Elaboration_Checks =>
14155 Check_Arg_Count (1);
14156 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14158 -- Set flag accordingly (ignore attempt at dynamic elaboration
14159 -- checks in SPARK mode).
14161 Dynamic_Elaboration_Checks :=
14162 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic)
14163 and then SPARK_Mode /= On;
14169 -- pragma Eliminate (
14170 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14171 -- [,[Entity =>] IDENTIFIER |
14172 -- SELECTED_COMPONENT |
14174 -- [, OVERLOADING_RESOLUTION]);
14176 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14179 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14180 -- FUNCTION_PROFILE
14182 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14184 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14185 -- Result_Type => result_SUBTYPE_NAME]
14187 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14188 -- SUBTYPE_NAME ::= STRING_LITERAL
14190 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14191 -- SOURCE_TRACE ::= STRING_LITERAL
14193 when Pragma_Eliminate => Eliminate : declare
14194 Args : Args_List (1 .. 5);
14195 Names : constant Name_List (1 .. 5) := (
14198 Name_Parameter_Types,
14200 Name_Source_Location);
14202 Unit_Name : Node_Id renames Args (1);
14203 Entity : Node_Id renames Args (2);
14204 Parameter_Types : Node_Id renames Args (3);
14205 Result_Type : Node_Id renames Args (4);
14206 Source_Location : Node_Id renames Args (5);
14210 Check_Valid_Configuration_Pragma;
14211 Gather_Associations (Names, Args);
14213 if No (Unit_Name) then
14214 Error_Pragma ("missing Unit_Name argument for pragma%");
14218 and then (Present (Parameter_Types)
14220 Present (Result_Type)
14222 Present (Source_Location))
14224 Error_Pragma ("missing Entity argument for pragma%");
14227 if (Present (Parameter_Types)
14229 Present (Result_Type))
14231 Present (Source_Location)
14234 ("parameter profile and source location cannot be used "
14235 & "together in pragma%");
14238 Process_Eliminate_Pragma
14247 -----------------------------------
14248 -- Enable_Atomic_Synchronization --
14249 -----------------------------------
14251 -- pragma Enable_Atomic_Synchronization [(Entity)];
14253 when Pragma_Enable_Atomic_Synchronization =>
14255 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14262 -- [ Convention =>] convention_IDENTIFIER,
14263 -- [ Entity =>] LOCAL_NAME
14264 -- [, [External_Name =>] static_string_EXPRESSION ]
14265 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14267 when Pragma_Export => Export : declare
14269 Def_Id : Entity_Id;
14271 pragma Warnings (Off, C);
14274 Check_Ada_83_Warning;
14278 Name_External_Name,
14281 Check_At_Least_N_Arguments (2);
14282 Check_At_Most_N_Arguments (4);
14284 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14285 -- pragma Export (Entity, "external name");
14287 if Relaxed_RM_Semantics
14288 and then Arg_Count = 2
14289 and then Nkind (Expression (Arg2)) = N_String_Literal
14292 Def_Id := Get_Pragma_Arg (Arg1);
14295 if not Is_Entity_Name (Def_Id) then
14296 Error_Pragma_Arg ("entity name required", Arg1);
14299 Def_Id := Entity (Def_Id);
14300 Set_Exported (Def_Id, Arg1);
14303 Process_Convention (C, Def_Id);
14305 -- A pragma that applies to a Ghost entity becomes Ghost for
14306 -- the purposes of legality checks and removal of ignored Ghost
14309 Mark_Pragma_As_Ghost (N, Def_Id);
14311 if Ekind (Def_Id) /= E_Constant then
14312 Note_Possible_Modification
14313 (Get_Pragma_Arg (Arg2), Sure => False);
14316 Process_Interface_Name (Def_Id, Arg3, Arg4);
14317 Set_Exported (Def_Id, Arg2);
14320 -- If the entity is a deferred constant, propagate the information
14321 -- to the full view, because gigi elaborates the full view only.
14323 if Ekind (Def_Id) = E_Constant
14324 and then Present (Full_View (Def_Id))
14327 Id2 : constant Entity_Id := Full_View (Def_Id);
14329 Set_Is_Exported (Id2, Is_Exported (Def_Id));
14330 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
14331 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14336 ---------------------
14337 -- Export_Function --
14338 ---------------------
14340 -- pragma Export_Function (
14341 -- [Internal =>] LOCAL_NAME
14342 -- [, [External =>] EXTERNAL_SYMBOL]
14343 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14344 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14345 -- [, [Mechanism =>] MECHANISM]
14346 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14348 -- EXTERNAL_SYMBOL ::=
14350 -- | static_string_EXPRESSION
14352 -- PARAMETER_TYPES ::=
14354 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14356 -- TYPE_DESIGNATOR ::=
14358 -- | subtype_Name ' Access
14362 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14364 -- MECHANISM_ASSOCIATION ::=
14365 -- [formal_parameter_NAME =>] MECHANISM_NAME
14367 -- MECHANISM_NAME ::=
14371 when Pragma_Export_Function => Export_Function : declare
14372 Args : Args_List (1 .. 6);
14373 Names : constant Name_List (1 .. 6) := (
14376 Name_Parameter_Types,
14379 Name_Result_Mechanism);
14381 Internal : Node_Id renames Args (1);
14382 External : Node_Id renames Args (2);
14383 Parameter_Types : Node_Id renames Args (3);
14384 Result_Type : Node_Id renames Args (4);
14385 Mechanism : Node_Id renames Args (5);
14386 Result_Mechanism : Node_Id renames Args (6);
14390 Gather_Associations (Names, Args);
14391 Process_Extended_Import_Export_Subprogram_Pragma (
14392 Arg_Internal => Internal,
14393 Arg_External => External,
14394 Arg_Parameter_Types => Parameter_Types,
14395 Arg_Result_Type => Result_Type,
14396 Arg_Mechanism => Mechanism,
14397 Arg_Result_Mechanism => Result_Mechanism);
14398 end Export_Function;
14400 -------------------
14401 -- Export_Object --
14402 -------------------
14404 -- pragma Export_Object (
14405 -- [Internal =>] LOCAL_NAME
14406 -- [, [External =>] EXTERNAL_SYMBOL]
14407 -- [, [Size =>] EXTERNAL_SYMBOL]);
14409 -- EXTERNAL_SYMBOL ::=
14411 -- | static_string_EXPRESSION
14413 -- PARAMETER_TYPES ::=
14415 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14417 -- TYPE_DESIGNATOR ::=
14419 -- | subtype_Name ' Access
14423 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14425 -- MECHANISM_ASSOCIATION ::=
14426 -- [formal_parameter_NAME =>] MECHANISM_NAME
14428 -- MECHANISM_NAME ::=
14432 when Pragma_Export_Object => Export_Object : declare
14433 Args : Args_List (1 .. 3);
14434 Names : constant Name_List (1 .. 3) := (
14439 Internal : Node_Id renames Args (1);
14440 External : Node_Id renames Args (2);
14441 Size : Node_Id renames Args (3);
14445 Gather_Associations (Names, Args);
14446 Process_Extended_Import_Export_Object_Pragma (
14447 Arg_Internal => Internal,
14448 Arg_External => External,
14452 ----------------------
14453 -- Export_Procedure --
14454 ----------------------
14456 -- pragma Export_Procedure (
14457 -- [Internal =>] LOCAL_NAME
14458 -- [, [External =>] EXTERNAL_SYMBOL]
14459 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14460 -- [, [Mechanism =>] MECHANISM]);
14462 -- EXTERNAL_SYMBOL ::=
14464 -- | static_string_EXPRESSION
14466 -- PARAMETER_TYPES ::=
14468 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14470 -- TYPE_DESIGNATOR ::=
14472 -- | subtype_Name ' Access
14476 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14478 -- MECHANISM_ASSOCIATION ::=
14479 -- [formal_parameter_NAME =>] MECHANISM_NAME
14481 -- MECHANISM_NAME ::=
14485 when Pragma_Export_Procedure => Export_Procedure : declare
14486 Args : Args_List (1 .. 4);
14487 Names : constant Name_List (1 .. 4) := (
14490 Name_Parameter_Types,
14493 Internal : Node_Id renames Args (1);
14494 External : Node_Id renames Args (2);
14495 Parameter_Types : Node_Id renames Args (3);
14496 Mechanism : Node_Id renames Args (4);
14500 Gather_Associations (Names, Args);
14501 Process_Extended_Import_Export_Subprogram_Pragma (
14502 Arg_Internal => Internal,
14503 Arg_External => External,
14504 Arg_Parameter_Types => Parameter_Types,
14505 Arg_Mechanism => Mechanism);
14506 end Export_Procedure;
14512 -- pragma Export_Value (
14513 -- [Value =>] static_integer_EXPRESSION,
14514 -- [Link_Name =>] static_string_EXPRESSION);
14516 when Pragma_Export_Value =>
14518 Check_Arg_Order ((Name_Value, Name_Link_Name));
14519 Check_Arg_Count (2);
14521 Check_Optional_Identifier (Arg1, Name_Value);
14522 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14524 Check_Optional_Identifier (Arg2, Name_Link_Name);
14525 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14527 -----------------------------
14528 -- Export_Valued_Procedure --
14529 -----------------------------
14531 -- pragma Export_Valued_Procedure (
14532 -- [Internal =>] LOCAL_NAME
14533 -- [, [External =>] EXTERNAL_SYMBOL,]
14534 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14535 -- [, [Mechanism =>] MECHANISM]);
14537 -- EXTERNAL_SYMBOL ::=
14539 -- | static_string_EXPRESSION
14541 -- PARAMETER_TYPES ::=
14543 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14545 -- TYPE_DESIGNATOR ::=
14547 -- | subtype_Name ' Access
14551 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14553 -- MECHANISM_ASSOCIATION ::=
14554 -- [formal_parameter_NAME =>] MECHANISM_NAME
14556 -- MECHANISM_NAME ::=
14560 when Pragma_Export_Valued_Procedure =>
14561 Export_Valued_Procedure : declare
14562 Args : Args_List (1 .. 4);
14563 Names : constant Name_List (1 .. 4) := (
14566 Name_Parameter_Types,
14569 Internal : Node_Id renames Args (1);
14570 External : Node_Id renames Args (2);
14571 Parameter_Types : Node_Id renames Args (3);
14572 Mechanism : Node_Id renames Args (4);
14576 Gather_Associations (Names, Args);
14577 Process_Extended_Import_Export_Subprogram_Pragma (
14578 Arg_Internal => Internal,
14579 Arg_External => External,
14580 Arg_Parameter_Types => Parameter_Types,
14581 Arg_Mechanism => Mechanism);
14582 end Export_Valued_Procedure;
14584 -------------------
14585 -- Extend_System --
14586 -------------------
14588 -- pragma Extend_System ([Name =>] Identifier);
14590 when Pragma_Extend_System => Extend_System : declare
14593 Check_Valid_Configuration_Pragma;
14594 Check_Arg_Count (1);
14595 Check_Optional_Identifier (Arg1, Name_Name);
14596 Check_Arg_Is_Identifier (Arg1);
14598 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14601 and then Name_Buffer (1 .. 4) = "aux_"
14603 if Present (System_Extend_Pragma_Arg) then
14604 if Chars (Get_Pragma_Arg (Arg1)) =
14605 Chars (Expression (System_Extend_Pragma_Arg))
14609 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14610 Error_Pragma ("pragma% conflicts with that #");
14614 System_Extend_Pragma_Arg := Arg1;
14616 if not GNAT_Mode then
14617 System_Extend_Unit := Arg1;
14621 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14625 ------------------------
14626 -- Extensions_Allowed --
14627 ------------------------
14629 -- pragma Extensions_Allowed (ON | OFF);
14631 when Pragma_Extensions_Allowed =>
14633 Check_Arg_Count (1);
14634 Check_No_Identifiers;
14635 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14637 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14638 Extensions_Allowed := True;
14639 Ada_Version := Ada_Version_Type'Last;
14642 Extensions_Allowed := False;
14643 Ada_Version := Ada_Version_Explicit;
14644 Ada_Version_Pragma := Empty;
14647 ------------------------
14648 -- Extensions_Visible --
14649 ------------------------
14651 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14653 -- Characteristics:
14655 -- * Analysis - The annotation is fully analyzed immediately upon
14656 -- elaboration as its expression must be static.
14658 -- * Expansion - None.
14660 -- * Template - The annotation utilizes the generic template of the
14661 -- related subprogram [body] when it is:
14663 -- aspect on subprogram declaration
14664 -- aspect on stand alone subprogram body
14665 -- pragma on stand alone subprogram body
14667 -- The annotation must prepare its own template when it is:
14669 -- pragma on subprogram declaration
14671 -- * Globals - Capture of global references must occur after full
14674 -- * Instance - The annotation is instantiated automatically when
14675 -- the related generic subprogram [body] is instantiated except for
14676 -- the "pragma on subprogram declaration" case. In that scenario
14677 -- the annotation must instantiate itself.
14679 when Pragma_Extensions_Visible => Extensions_Visible : declare
14680 Formal : Entity_Id;
14681 Has_OK_Formal : Boolean := False;
14682 Spec_Id : Entity_Id;
14683 Subp_Decl : Node_Id;
14687 Check_No_Identifiers;
14688 Check_At_Most_N_Arguments (1);
14691 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
14693 -- Abstract subprogram declaration
14695 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
14698 -- Generic subprogram declaration
14700 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
14703 -- Body acts as spec
14705 elsif Nkind (Subp_Decl) = N_Subprogram_Body
14706 and then No (Corresponding_Spec (Subp_Decl))
14710 -- Body stub acts as spec
14712 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
14713 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
14717 -- Subprogram declaration
14719 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
14722 -- Otherwise the pragma is associated with an illegal construct
14725 Error_Pragma ("pragma % must apply to a subprogram");
14729 -- Chain the pragma on the contract for completeness
14731 Add_Contract_Item (N, Defining_Entity (Subp_Decl));
14733 -- The legality checks of pragma Extension_Visible are affected
14734 -- by the SPARK mode in effect. Analyze all pragmas in specific
14737 Analyze_If_Present (Pragma_SPARK_Mode);
14739 -- Mark the pragma as Ghost if the related subprogram is also
14740 -- Ghost. This also ensures that any expansion performed further
14741 -- below will produce Ghost nodes.
14743 Spec_Id := Unique_Defining_Entity (Subp_Decl);
14744 Mark_Pragma_As_Ghost (N, Spec_Id);
14746 -- Examine the formals of the related subprogram
14748 Formal := First_Formal (Spec_Id);
14749 while Present (Formal) loop
14751 -- At least one of the formals is of a specific tagged type,
14752 -- the pragma is legal.
14754 if Is_Specific_Tagged_Type (Etype (Formal)) then
14755 Has_OK_Formal := True;
14758 -- A generic subprogram with at least one formal of a private
14759 -- type ensures the legality of the pragma because the actual
14760 -- may be specifically tagged. Note that this is verified by
14761 -- the check above at instantiation time.
14763 elsif Is_Private_Type (Etype (Formal))
14764 and then Is_Generic_Type (Etype (Formal))
14766 Has_OK_Formal := True;
14770 Next_Formal (Formal);
14773 if not Has_OK_Formal then
14774 Error_Msg_Name_1 := Pname;
14775 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
14777 ("\subprogram & lacks parameter of specific tagged or "
14778 & "generic private type", N, Spec_Id);
14783 -- Analyze the Boolean expression (if any)
14785 if Present (Arg1) then
14786 Check_Static_Boolean_Expression
14787 (Expression (Get_Argument (N, Spec_Id)));
14789 end Extensions_Visible;
14795 -- pragma External (
14796 -- [ Convention =>] convention_IDENTIFIER,
14797 -- [ Entity =>] LOCAL_NAME
14798 -- [, [External_Name =>] static_string_EXPRESSION ]
14799 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14801 when Pragma_External => External : declare
14804 pragma Warnings (Off, C);
14811 Name_External_Name,
14813 Check_At_Least_N_Arguments (2);
14814 Check_At_Most_N_Arguments (4);
14815 Process_Convention (C, E);
14817 -- A pragma that applies to a Ghost entity becomes Ghost for the
14818 -- purposes of legality checks and removal of ignored Ghost code.
14820 Mark_Pragma_As_Ghost (N, E);
14822 Note_Possible_Modification
14823 (Get_Pragma_Arg (Arg2), Sure => False);
14824 Process_Interface_Name (E, Arg3, Arg4);
14825 Set_Exported (E, Arg2);
14828 --------------------------
14829 -- External_Name_Casing --
14830 --------------------------
14832 -- pragma External_Name_Casing (
14833 -- UPPERCASE | LOWERCASE
14834 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14836 when Pragma_External_Name_Casing => External_Name_Casing : declare
14839 Check_No_Identifiers;
14841 if Arg_Count = 2 then
14842 Check_Arg_Is_One_Of
14843 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
14845 case Chars (Get_Pragma_Arg (Arg2)) is
14847 Opt.External_Name_Exp_Casing := As_Is;
14849 when Name_Uppercase =>
14850 Opt.External_Name_Exp_Casing := Uppercase;
14852 when Name_Lowercase =>
14853 Opt.External_Name_Exp_Casing := Lowercase;
14860 Check_Arg_Count (1);
14863 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
14865 case Chars (Get_Pragma_Arg (Arg1)) is
14866 when Name_Uppercase =>
14867 Opt.External_Name_Imp_Casing := Uppercase;
14869 when Name_Lowercase =>
14870 Opt.External_Name_Imp_Casing := Lowercase;
14875 end External_Name_Casing;
14881 -- pragma Fast_Math;
14883 when Pragma_Fast_Math =>
14885 Check_No_Identifiers;
14886 Check_Valid_Configuration_Pragma;
14889 --------------------------
14890 -- Favor_Top_Level --
14891 --------------------------
14893 -- pragma Favor_Top_Level (type_NAME);
14895 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
14900 Check_No_Identifiers;
14901 Check_Arg_Count (1);
14902 Check_Arg_Is_Local_Name (Arg1);
14903 Typ := Entity (Get_Pragma_Arg (Arg1));
14905 -- A pragma that applies to a Ghost entity becomes Ghost for the
14906 -- purposes of legality checks and removal of ignored Ghost code.
14908 Mark_Pragma_As_Ghost (N, Typ);
14910 -- If it's an access-to-subprogram type (in particular, not a
14911 -- subtype), set the flag on that type.
14913 if Is_Access_Subprogram_Type (Typ) then
14914 Set_Can_Use_Internal_Rep (Typ, False);
14916 -- Otherwise it's an error (name denotes the wrong sort of entity)
14920 ("access-to-subprogram type expected",
14921 Get_Pragma_Arg (Arg1));
14923 end Favor_Top_Level;
14925 ---------------------------
14926 -- Finalize_Storage_Only --
14927 ---------------------------
14929 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14931 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
14932 Assoc : constant Node_Id := Arg1;
14933 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
14938 Check_No_Identifiers;
14939 Check_Arg_Count (1);
14940 Check_Arg_Is_Local_Name (Arg1);
14942 Find_Type (Type_Id);
14943 Typ := Entity (Type_Id);
14946 or else Rep_Item_Too_Early (Typ, N)
14950 Typ := Underlying_Type (Typ);
14953 if not Is_Controlled (Typ) then
14954 Error_Pragma ("pragma% must specify controlled type");
14957 Check_First_Subtype (Arg1);
14959 if Finalize_Storage_Only (Typ) then
14960 Error_Pragma ("duplicate pragma%, only one allowed");
14962 elsif not Rep_Item_Too_Late (Typ, N) then
14963 Set_Finalize_Storage_Only (Base_Type (Typ), True);
14965 end Finalize_Storage;
14971 -- pragma Ghost [ (boolean_EXPRESSION) ];
14973 when Pragma_Ghost => Ghost : declare
14977 Orig_Stmt : Node_Id;
14978 Prev_Id : Entity_Id;
14983 Check_No_Identifiers;
14984 Check_At_Most_N_Arguments (1);
14988 while Present (Stmt) loop
14990 -- Skip prior pragmas, but check for duplicates
14992 if Nkind (Stmt) = N_Pragma then
14993 if Pragma_Name (Stmt) = Pname then
14994 Error_Msg_Name_1 := Pname;
14995 Error_Msg_Sloc := Sloc (Stmt);
14996 Error_Msg_N ("pragma % duplicates pragma declared#", N);
14999 -- Task unit declared without a definition cannot be subject to
15000 -- pragma Ghost (SPARK RM 6.9(19)).
15002 elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15003 N_Task_Type_Declaration)
15005 Error_Pragma ("pragma % cannot apply to a task type");
15008 -- Skip internally generated code
15010 elsif not Comes_From_Source (Stmt) then
15011 Orig_Stmt := Original_Node (Stmt);
15013 -- When pragma Ghost applies to an untagged derivation, the
15014 -- derivation is transformed into a [sub]type declaration.
15016 if Nkind_In (Stmt, N_Full_Type_Declaration,
15017 N_Subtype_Declaration)
15018 and then Comes_From_Source (Orig_Stmt)
15019 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15020 and then Nkind (Type_Definition (Orig_Stmt)) =
15021 N_Derived_Type_Definition
15023 Id := Defining_Entity (Stmt);
15026 -- When pragma Ghost applies to an object declaration which
15027 -- is initialized by means of a function call that returns
15028 -- on the secondary stack, the object declaration becomes a
15031 elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15032 and then Comes_From_Source (Orig_Stmt)
15033 and then Nkind (Orig_Stmt) = N_Object_Declaration
15035 Id := Defining_Entity (Stmt);
15038 -- When pragma Ghost applies to an expression function, the
15039 -- expression function is transformed into a subprogram.
15041 elsif Nkind (Stmt) = N_Subprogram_Declaration
15042 and then Comes_From_Source (Orig_Stmt)
15043 and then Nkind (Orig_Stmt) = N_Expression_Function
15045 Id := Defining_Entity (Stmt);
15049 -- The pragma applies to a legal construct, stop the traversal
15051 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15052 N_Full_Type_Declaration,
15053 N_Generic_Subprogram_Declaration,
15054 N_Object_Declaration,
15055 N_Private_Extension_Declaration,
15056 N_Private_Type_Declaration,
15057 N_Subprogram_Declaration,
15058 N_Subtype_Declaration)
15060 Id := Defining_Entity (Stmt);
15063 -- The pragma does not apply to a legal construct, issue an
15064 -- error and stop the analysis.
15068 ("pragma % must apply to an object, package, subprogram "
15073 Stmt := Prev (Stmt);
15076 Context := Parent (N);
15078 -- Handle compilation units
15080 if Nkind (Context) = N_Compilation_Unit_Aux then
15081 Context := Unit (Parent (Context));
15084 -- Protected and task types cannot be subject to pragma Ghost
15085 -- (SPARK RM 6.9(19)).
15087 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15089 Error_Pragma ("pragma % cannot apply to a protected type");
15092 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15093 Error_Pragma ("pragma % cannot apply to a task type");
15099 -- When pragma Ghost is associated with a [generic] package, it
15100 -- appears in the visible declarations.
15102 if Nkind (Context) = N_Package_Specification
15103 and then Present (Visible_Declarations (Context))
15104 and then List_Containing (N) = Visible_Declarations (Context)
15106 Id := Defining_Entity (Context);
15108 -- Pragma Ghost applies to a stand alone subprogram body
15110 elsif Nkind (Context) = N_Subprogram_Body
15111 and then No (Corresponding_Spec (Context))
15113 Id := Defining_Entity (Context);
15115 -- Pragma Ghost applies to a subprogram declaration that acts
15116 -- as a compilation unit.
15118 elsif Nkind (Context) = N_Subprogram_Declaration then
15119 Id := Defining_Entity (Context);
15125 ("pragma % must apply to an object, package, subprogram or "
15130 -- Handle completions of types and constants that are subject to
15133 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15134 Prev_Id := Incomplete_Or_Partial_View (Id);
15136 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15137 Error_Msg_Name_1 := Pname;
15139 -- The full declaration of a deferred constant cannot be
15140 -- subject to pragma Ghost unless the deferred declaration
15141 -- is also Ghost (SPARK RM 6.9(9)).
15143 if Ekind (Prev_Id) = E_Constant then
15144 Error_Msg_Name_1 := Pname;
15145 Error_Msg_NE (Fix_Error
15146 ("pragma % must apply to declaration of deferred "
15147 & "constant &"), N, Id);
15150 -- Pragma Ghost may appear on the full view of an incomplete
15151 -- type because the incomplete declaration lacks aspects and
15152 -- cannot be subject to pragma Ghost.
15154 elsif Ekind (Prev_Id) = E_Incomplete_Type then
15157 -- The full declaration of a type cannot be subject to
15158 -- pragma Ghost unless the partial view is also Ghost
15159 -- (SPARK RM 6.9(9)).
15162 Error_Msg_NE (Fix_Error
15163 ("pragma % must apply to partial view of type &"),
15169 -- A synchronized object cannot be subject to pragma Ghost
15170 -- (SPARK RM 6.9(19)).
15172 elsif Ekind (Id) = E_Variable then
15173 if Is_Protected_Type (Etype (Id)) then
15174 Error_Pragma ("pragma % cannot apply to a protected object");
15177 elsif Is_Task_Type (Etype (Id)) then
15178 Error_Pragma ("pragma % cannot apply to a task object");
15183 -- Analyze the Boolean expression (if any)
15185 if Present (Arg1) then
15186 Expr := Get_Pragma_Arg (Arg1);
15188 Analyze_And_Resolve (Expr, Standard_Boolean);
15190 if Is_OK_Static_Expression (Expr) then
15192 -- "Ghostness" cannot be turned off once enabled within a
15193 -- region (SPARK RM 6.9(6)).
15195 if Is_False (Expr_Value (Expr))
15196 and then Ghost_Mode > None
15199 ("pragma % with value False cannot appear in enabled "
15204 -- Otherwie the expression is not static
15208 ("expression of pragma % must be static", Expr);
15213 Set_Is_Ghost_Entity (Id);
15220 -- pragma Global (GLOBAL_SPECIFICATION);
15222 -- GLOBAL_SPECIFICATION ::=
15225 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15227 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15229 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15230 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15231 -- GLOBAL_ITEM ::= NAME
15233 -- Characteristics:
15235 -- * Analysis - The annotation undergoes initial checks to verify
15236 -- the legal placement and context. Secondary checks fully analyze
15237 -- the dependency clauses in:
15239 -- Analyze_Global_In_Decl_Part
15241 -- * Expansion - None.
15243 -- * Template - The annotation utilizes the generic template of the
15244 -- related subprogram [body] when it is:
15246 -- aspect on subprogram declaration
15247 -- aspect on stand alone subprogram body
15248 -- pragma on stand alone subprogram body
15250 -- The annotation must prepare its own template when it is:
15252 -- pragma on subprogram declaration
15254 -- * Globals - Capture of global references must occur after full
15257 -- * Instance - The annotation is instantiated automatically when
15258 -- the related generic subprogram [body] is instantiated except for
15259 -- the "pragma on subprogram declaration" case. In that scenario
15260 -- the annotation must instantiate itself.
15262 when Pragma_Global => Global : declare
15264 Spec_Id : Entity_Id;
15265 Subp_Decl : Node_Id;
15268 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15272 -- Chain the pragma on the contract for further processing by
15273 -- Analyze_Global_In_Decl_Part.
15275 Add_Contract_Item (N, Spec_Id);
15277 -- Fully analyze the pragma when it appears inside an entry
15278 -- or subprogram body because it cannot benefit from forward
15281 if Nkind_In (Subp_Decl, N_Entry_Body,
15283 N_Subprogram_Body_Stub)
15285 -- The legality checks of pragmas Depends and Global are
15286 -- affected by the SPARK mode in effect and the volatility
15287 -- of the context. In addition these two pragmas are subject
15288 -- to an inherent order:
15293 -- Analyze all these pragmas in the order outlined above
15295 Analyze_If_Present (Pragma_SPARK_Mode);
15296 Analyze_If_Present (Pragma_Volatile_Function);
15297 Analyze_Global_In_Decl_Part (N);
15298 Analyze_If_Present (Pragma_Depends);
15307 -- pragma Ident (static_string_EXPRESSION)
15309 -- Note: pragma Comment shares this processing. Pragma Ident is
15310 -- identical in effect to pragma Commment.
15312 when Pragma_Ident | Pragma_Comment => Ident : declare
15317 Check_Arg_Count (1);
15318 Check_No_Identifiers;
15319 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15322 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15329 GP := Parent (Parent (N));
15331 if Nkind_In (GP, N_Package_Declaration,
15332 N_Generic_Package_Declaration)
15337 -- If we have a compilation unit, then record the ident value,
15338 -- checking for improper duplication.
15340 if Nkind (GP) = N_Compilation_Unit then
15341 CS := Ident_String (Current_Sem_Unit);
15343 if Present (CS) then
15345 -- If we have multiple instances, concatenate them, but
15346 -- not in ASIS, where we want the original tree.
15348 if not ASIS_Mode then
15349 Start_String (Strval (CS));
15350 Store_String_Char (' ');
15351 Store_String_Chars (Strval (Str));
15352 Set_Strval (CS, End_String);
15356 Set_Ident_String (Current_Sem_Unit, Str);
15359 -- For subunits, we just ignore the Ident, since in GNAT these
15360 -- are not separate object files, and hence not separate units
15361 -- in the unit table.
15363 elsif Nkind (GP) = N_Subunit then
15369 -------------------
15370 -- Ignore_Pragma --
15371 -------------------
15373 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15375 -- Entirely handled in the parser, nothing to do here
15377 when Pragma_Ignore_Pragma =>
15380 ----------------------------
15381 -- Implementation_Defined --
15382 ----------------------------
15384 -- pragma Implementation_Defined (LOCAL_NAME);
15386 -- Marks previously declared entity as implementation defined. For
15387 -- an overloaded entity, applies to the most recent homonym.
15389 -- pragma Implementation_Defined;
15391 -- The form with no arguments appears anywhere within a scope, most
15392 -- typically a package spec, and indicates that all entities that are
15393 -- defined within the package spec are Implementation_Defined.
15395 when Pragma_Implementation_Defined => Implementation_Defined : declare
15400 Check_No_Identifiers;
15402 -- Form with no arguments
15404 if Arg_Count = 0 then
15405 Set_Is_Implementation_Defined (Current_Scope);
15407 -- Form with one argument
15410 Check_Arg_Count (1);
15411 Check_Arg_Is_Local_Name (Arg1);
15412 Ent := Entity (Get_Pragma_Arg (Arg1));
15413 Set_Is_Implementation_Defined (Ent);
15415 end Implementation_Defined;
15421 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15423 -- IMPLEMENTATION_KIND ::=
15424 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15426 -- "By_Any" and "Optional" are treated as synonyms in order to
15427 -- support Ada 2012 aspect Synchronization.
15429 when Pragma_Implemented => Implemented : declare
15430 Proc_Id : Entity_Id;
15435 Check_Arg_Count (2);
15436 Check_No_Identifiers;
15437 Check_Arg_Is_Identifier (Arg1);
15438 Check_Arg_Is_Local_Name (Arg1);
15439 Check_Arg_Is_One_Of (Arg2,
15442 Name_By_Protected_Procedure,
15445 -- Extract the name of the local procedure
15447 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15449 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15450 -- primitive procedure of a synchronized tagged type.
15452 if Ekind (Proc_Id) = E_Procedure
15453 and then Is_Primitive (Proc_Id)
15454 and then Present (First_Formal (Proc_Id))
15456 Typ := Etype (First_Formal (Proc_Id));
15458 if Is_Tagged_Type (Typ)
15461 -- Check for a protected, a synchronized or a task interface
15463 ((Is_Interface (Typ)
15464 and then Is_Synchronized_Interface (Typ))
15466 -- Check for a protected type or a task type that implements
15470 (Is_Concurrent_Record_Type (Typ)
15471 and then Present (Interfaces (Typ)))
15473 -- In analysis-only mode, examine original protected type
15476 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15477 and then Present (Interface_List (Parent (Typ))))
15479 -- Check for a private record extension with keyword
15483 (Ekind_In (Typ, E_Record_Type_With_Private,
15484 E_Record_Subtype_With_Private)
15485 and then Synchronized_Present (Parent (Typ))))
15490 ("controlling formal must be of synchronized tagged type",
15495 -- Procedures declared inside a protected type must be accepted
15497 elsif Ekind (Proc_Id) = E_Procedure
15498 and then Is_Protected_Type (Scope (Proc_Id))
15502 -- The first argument is not a primitive procedure
15506 ("pragma % must be applied to a primitive procedure", Arg1);
15510 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15511 -- By_Protected_Procedure to the primitive procedure of a task
15514 if Chars (Arg2) = Name_By_Protected_Procedure
15515 and then Is_Interface (Typ)
15516 and then Is_Task_Interface (Typ)
15519 ("implementation kind By_Protected_Procedure cannot be "
15520 & "applied to a task interface primitive", Arg2);
15524 Record_Rep_Item (Proc_Id, N);
15527 ----------------------
15528 -- Implicit_Packing --
15529 ----------------------
15531 -- pragma Implicit_Packing;
15533 when Pragma_Implicit_Packing =>
15535 Check_Arg_Count (0);
15536 Implicit_Packing := True;
15543 -- [Convention =>] convention_IDENTIFIER,
15544 -- [Entity =>] LOCAL_NAME
15545 -- [, [External_Name =>] static_string_EXPRESSION ]
15546 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15548 when Pragma_Import =>
15549 Check_Ada_83_Warning;
15553 Name_External_Name,
15556 Check_At_Least_N_Arguments (2);
15557 Check_At_Most_N_Arguments (4);
15558 Process_Import_Or_Interface;
15560 ---------------------
15561 -- Import_Function --
15562 ---------------------
15564 -- pragma Import_Function (
15565 -- [Internal =>] LOCAL_NAME,
15566 -- [, [External =>] EXTERNAL_SYMBOL]
15567 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15568 -- [, [Result_Type =>] SUBTYPE_MARK]
15569 -- [, [Mechanism =>] MECHANISM]
15570 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15572 -- EXTERNAL_SYMBOL ::=
15574 -- | static_string_EXPRESSION
15576 -- PARAMETER_TYPES ::=
15578 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15580 -- TYPE_DESIGNATOR ::=
15582 -- | subtype_Name ' Access
15586 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15588 -- MECHANISM_ASSOCIATION ::=
15589 -- [formal_parameter_NAME =>] MECHANISM_NAME
15591 -- MECHANISM_NAME ::=
15595 when Pragma_Import_Function => Import_Function : declare
15596 Args : Args_List (1 .. 6);
15597 Names : constant Name_List (1 .. 6) := (
15600 Name_Parameter_Types,
15603 Name_Result_Mechanism);
15605 Internal : Node_Id renames Args (1);
15606 External : Node_Id renames Args (2);
15607 Parameter_Types : Node_Id renames Args (3);
15608 Result_Type : Node_Id renames Args (4);
15609 Mechanism : Node_Id renames Args (5);
15610 Result_Mechanism : Node_Id renames Args (6);
15614 Gather_Associations (Names, Args);
15615 Process_Extended_Import_Export_Subprogram_Pragma (
15616 Arg_Internal => Internal,
15617 Arg_External => External,
15618 Arg_Parameter_Types => Parameter_Types,
15619 Arg_Result_Type => Result_Type,
15620 Arg_Mechanism => Mechanism,
15621 Arg_Result_Mechanism => Result_Mechanism);
15622 end Import_Function;
15624 -------------------
15625 -- Import_Object --
15626 -------------------
15628 -- pragma Import_Object (
15629 -- [Internal =>] LOCAL_NAME
15630 -- [, [External =>] EXTERNAL_SYMBOL]
15631 -- [, [Size =>] EXTERNAL_SYMBOL]);
15633 -- EXTERNAL_SYMBOL ::=
15635 -- | static_string_EXPRESSION
15637 when Pragma_Import_Object => Import_Object : declare
15638 Args : Args_List (1 .. 3);
15639 Names : constant Name_List (1 .. 3) := (
15644 Internal : Node_Id renames Args (1);
15645 External : Node_Id renames Args (2);
15646 Size : Node_Id renames Args (3);
15650 Gather_Associations (Names, Args);
15651 Process_Extended_Import_Export_Object_Pragma (
15652 Arg_Internal => Internal,
15653 Arg_External => External,
15657 ----------------------
15658 -- Import_Procedure --
15659 ----------------------
15661 -- pragma Import_Procedure (
15662 -- [Internal =>] LOCAL_NAME
15663 -- [, [External =>] EXTERNAL_SYMBOL]
15664 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15665 -- [, [Mechanism =>] MECHANISM]);
15667 -- EXTERNAL_SYMBOL ::=
15669 -- | static_string_EXPRESSION
15671 -- PARAMETER_TYPES ::=
15673 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15675 -- TYPE_DESIGNATOR ::=
15677 -- | subtype_Name ' Access
15681 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15683 -- MECHANISM_ASSOCIATION ::=
15684 -- [formal_parameter_NAME =>] MECHANISM_NAME
15686 -- MECHANISM_NAME ::=
15690 when Pragma_Import_Procedure => Import_Procedure : declare
15691 Args : Args_List (1 .. 4);
15692 Names : constant Name_List (1 .. 4) := (
15695 Name_Parameter_Types,
15698 Internal : Node_Id renames Args (1);
15699 External : Node_Id renames Args (2);
15700 Parameter_Types : Node_Id renames Args (3);
15701 Mechanism : Node_Id renames Args (4);
15705 Gather_Associations (Names, Args);
15706 Process_Extended_Import_Export_Subprogram_Pragma (
15707 Arg_Internal => Internal,
15708 Arg_External => External,
15709 Arg_Parameter_Types => Parameter_Types,
15710 Arg_Mechanism => Mechanism);
15711 end Import_Procedure;
15713 -----------------------------
15714 -- Import_Valued_Procedure --
15715 -----------------------------
15717 -- pragma Import_Valued_Procedure (
15718 -- [Internal =>] LOCAL_NAME
15719 -- [, [External =>] EXTERNAL_SYMBOL]
15720 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15721 -- [, [Mechanism =>] MECHANISM]);
15723 -- EXTERNAL_SYMBOL ::=
15725 -- | static_string_EXPRESSION
15727 -- PARAMETER_TYPES ::=
15729 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15731 -- TYPE_DESIGNATOR ::=
15733 -- | subtype_Name ' Access
15737 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15739 -- MECHANISM_ASSOCIATION ::=
15740 -- [formal_parameter_NAME =>] MECHANISM_NAME
15742 -- MECHANISM_NAME ::=
15746 when Pragma_Import_Valued_Procedure =>
15747 Import_Valued_Procedure : declare
15748 Args : Args_List (1 .. 4);
15749 Names : constant Name_List (1 .. 4) := (
15752 Name_Parameter_Types,
15755 Internal : Node_Id renames Args (1);
15756 External : Node_Id renames Args (2);
15757 Parameter_Types : Node_Id renames Args (3);
15758 Mechanism : Node_Id renames Args (4);
15762 Gather_Associations (Names, Args);
15763 Process_Extended_Import_Export_Subprogram_Pragma (
15764 Arg_Internal => Internal,
15765 Arg_External => External,
15766 Arg_Parameter_Types => Parameter_Types,
15767 Arg_Mechanism => Mechanism);
15768 end Import_Valued_Procedure;
15774 -- pragma Independent (LOCAL_NAME);
15776 when Pragma_Independent =>
15777 Process_Atomic_Independent_Shared_Volatile;
15779 ----------------------------
15780 -- Independent_Components --
15781 ----------------------------
15783 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15785 when Pragma_Independent_Components => Independent_Components : declare
15793 Check_Ada_83_Warning;
15795 Check_No_Identifiers;
15796 Check_Arg_Count (1);
15797 Check_Arg_Is_Local_Name (Arg1);
15798 E_Id := Get_Pragma_Arg (Arg1);
15800 if Etype (E_Id) = Any_Type then
15804 E := Entity (E_Id);
15806 -- A pragma that applies to a Ghost entity becomes Ghost for the
15807 -- purposes of legality checks and removal of ignored Ghost code.
15809 Mark_Pragma_As_Ghost (N, E);
15811 -- Check duplicate before we chain ourselves
15813 Check_Duplicate_Pragma (E);
15815 -- Check appropriate entity
15817 if Rep_Item_Too_Early (E, N)
15819 Rep_Item_Too_Late (E, N)
15824 D := Declaration_Node (E);
15827 -- The flag is set on the base type, or on the object
15829 if K = N_Full_Type_Declaration
15830 and then (Is_Array_Type (E) or else Is_Record_Type (E))
15832 Set_Has_Independent_Components (Base_Type (E));
15833 Record_Independence_Check (N, Base_Type (E));
15835 -- For record type, set all components independent
15837 if Is_Record_Type (E) then
15838 C := First_Component (E);
15839 while Present (C) loop
15840 Set_Is_Independent (C);
15841 Next_Component (C);
15845 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15846 and then Nkind (D) = N_Object_Declaration
15847 and then Nkind (Object_Definition (D)) =
15848 N_Constrained_Array_Definition
15850 Set_Has_Independent_Components (E);
15851 Record_Independence_Check (N, E);
15854 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
15856 end Independent_Components;
15858 -----------------------
15859 -- Initial_Condition --
15860 -----------------------
15862 -- pragma Initial_Condition (boolean_EXPRESSION);
15864 -- Characteristics:
15866 -- * Analysis - The annotation undergoes initial checks to verify
15867 -- the legal placement and context. Secondary checks preanalyze the
15870 -- Analyze_Initial_Condition_In_Decl_Part
15872 -- * Expansion - The annotation is expanded during the expansion of
15873 -- the package body whose declaration is subject to the annotation
15876 -- Expand_Pragma_Initial_Condition
15878 -- * Template - The annotation utilizes the generic template of the
15879 -- related package declaration.
15881 -- * Globals - Capture of global references must occur after full
15884 -- * Instance - The annotation is instantiated automatically when
15885 -- the related generic package is instantiated.
15887 when Pragma_Initial_Condition => Initial_Condition : declare
15888 Pack_Decl : Node_Id;
15889 Pack_Id : Entity_Id;
15893 Check_No_Identifiers;
15894 Check_Arg_Count (1);
15896 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
15898 -- Ensure the proper placement of the pragma. Initial_Condition
15899 -- must be associated with a package declaration.
15901 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
15902 N_Package_Declaration)
15906 -- Otherwise the pragma is associated with an illegal context
15913 Pack_Id := Defining_Entity (Pack_Decl);
15915 -- Chain the pragma on the contract for further processing by
15916 -- Analyze_Initial_Condition_In_Decl_Part.
15918 Add_Contract_Item (N, Pack_Id);
15920 -- The legality checks of pragmas Abstract_State, Initializes, and
15921 -- Initial_Condition are affected by the SPARK mode in effect. In
15922 -- addition, these three pragmas are subject to an inherent order:
15924 -- 1) Abstract_State
15926 -- 3) Initial_Condition
15928 -- Analyze all these pragmas in the order outlined above
15930 Analyze_If_Present (Pragma_SPARK_Mode);
15931 Analyze_If_Present (Pragma_Abstract_State);
15932 Analyze_If_Present (Pragma_Initializes);
15934 -- A pragma that applies to a Ghost entity becomes Ghost for the
15935 -- purposes of legality checks and removal of ignored Ghost code.
15937 Mark_Pragma_As_Ghost (N, Pack_Id);
15938 end Initial_Condition;
15940 ------------------------
15941 -- Initialize_Scalars --
15942 ------------------------
15944 -- pragma Initialize_Scalars;
15946 when Pragma_Initialize_Scalars =>
15948 Check_Arg_Count (0);
15949 Check_Valid_Configuration_Pragma;
15950 Check_Restriction (No_Initialize_Scalars, N);
15952 -- Initialize_Scalars creates false positives in CodePeer, and
15953 -- incorrect negative results in GNATprove mode, so ignore this
15954 -- pragma in these modes.
15956 if not Restriction_Active (No_Initialize_Scalars)
15957 and then not (CodePeer_Mode or GNATprove_Mode)
15959 Init_Or_Norm_Scalars := True;
15960 Initialize_Scalars := True;
15967 -- pragma Initializes (INITIALIZATION_LIST);
15969 -- INITIALIZATION_LIST ::=
15971 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15973 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15978 -- | (INPUT {, INPUT})
15982 -- Characteristics:
15984 -- * Analysis - The annotation undergoes initial checks to verify
15985 -- the legal placement and context. Secondary checks preanalyze the
15988 -- Analyze_Initializes_In_Decl_Part
15990 -- * Expansion - None.
15992 -- * Template - The annotation utilizes the generic template of the
15993 -- related package declaration.
15995 -- * Globals - Capture of global references must occur after full
15998 -- * Instance - The annotation is instantiated automatically when
15999 -- the related generic package is instantiated.
16001 when Pragma_Initializes => Initializes : declare
16002 Pack_Decl : Node_Id;
16003 Pack_Id : Entity_Id;
16007 Check_No_Identifiers;
16008 Check_Arg_Count (1);
16010 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16012 -- Ensure the proper placement of the pragma. Initializes must be
16013 -- associated with a package declaration.
16015 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16016 N_Package_Declaration)
16020 -- Otherwise the pragma is associated with an illegal construc
16027 Pack_Id := Defining_Entity (Pack_Decl);
16029 -- Chain the pragma on the contract for further processing by
16030 -- Analyze_Initializes_In_Decl_Part.
16032 Add_Contract_Item (N, Pack_Id);
16034 -- The legality checks of pragmas Abstract_State, Initializes, and
16035 -- Initial_Condition are affected by the SPARK mode in effect. In
16036 -- addition, these three pragmas are subject to an inherent order:
16038 -- 1) Abstract_State
16040 -- 3) Initial_Condition
16042 -- Analyze all these pragmas in the order outlined above
16044 Analyze_If_Present (Pragma_SPARK_Mode);
16045 Analyze_If_Present (Pragma_Abstract_State);
16047 -- A pragma that applies to a Ghost entity becomes Ghost for the
16048 -- purposes of legality checks and removal of ignored Ghost code.
16050 Mark_Pragma_As_Ghost (N, Pack_Id);
16051 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16053 Analyze_If_Present (Pragma_Initial_Condition);
16060 -- pragma Inline ( NAME {, NAME} );
16062 when Pragma_Inline =>
16064 -- Pragma always active unless in GNATprove mode. It is disabled
16065 -- in GNATprove mode because frontend inlining is applied
16066 -- independently of pragmas Inline and Inline_Always for
16067 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16070 if not GNATprove_Mode then
16072 -- Inline status is Enabled if inlining option is active
16074 if Inline_Active then
16075 Process_Inline (Enabled);
16077 Process_Inline (Disabled);
16081 -------------------
16082 -- Inline_Always --
16083 -------------------
16085 -- pragma Inline_Always ( NAME {, NAME} );
16087 when Pragma_Inline_Always =>
16090 -- Pragma always active unless in CodePeer mode or GNATprove
16091 -- mode. It is disabled in CodePeer mode because inlining is
16092 -- not helpful, and enabling it caused walk order issues. It
16093 -- is disabled in GNATprove mode because frontend inlining is
16094 -- applied independently of pragmas Inline and Inline_Always for
16095 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16098 if not CodePeer_Mode and not GNATprove_Mode then
16099 Process_Inline (Enabled);
16102 --------------------
16103 -- Inline_Generic --
16104 --------------------
16106 -- pragma Inline_Generic (NAME {, NAME});
16108 when Pragma_Inline_Generic =>
16110 Process_Generic_List;
16112 ----------------------
16113 -- Inspection_Point --
16114 ----------------------
16116 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16118 when Pragma_Inspection_Point => Inspection_Point : declare
16125 if Arg_Count > 0 then
16128 Exp := Get_Pragma_Arg (Arg);
16131 if not Is_Entity_Name (Exp)
16132 or else not Is_Object (Entity (Exp))
16134 Error_Pragma_Arg ("object name required", Arg);
16138 exit when No (Arg);
16141 end Inspection_Point;
16147 -- pragma Interface (
16148 -- [ Convention =>] convention_IDENTIFIER,
16149 -- [ Entity =>] LOCAL_NAME
16150 -- [, [External_Name =>] static_string_EXPRESSION ]
16151 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16153 when Pragma_Interface =>
16158 Name_External_Name,
16160 Check_At_Least_N_Arguments (2);
16161 Check_At_Most_N_Arguments (4);
16162 Process_Import_Or_Interface;
16164 -- In Ada 2005, the permission to use Interface (a reserved word)
16165 -- as a pragma name is considered an obsolescent feature, and this
16166 -- pragma was already obsolescent in Ada 95.
16168 if Ada_Version >= Ada_95 then
16170 (No_Obsolescent_Features, Pragma_Identifier (N));
16172 if Warn_On_Obsolescent_Feature then
16174 ("pragma Interface is an obsolescent feature?j?", N);
16176 ("|use pragma Import instead?j?", N);
16180 --------------------
16181 -- Interface_Name --
16182 --------------------
16184 -- pragma Interface_Name (
16185 -- [ Entity =>] LOCAL_NAME
16186 -- [,[External_Name =>] static_string_EXPRESSION ]
16187 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16189 when Pragma_Interface_Name => Interface_Name : declare
16191 Def_Id : Entity_Id;
16192 Hom_Id : Entity_Id;
16198 ((Name_Entity, Name_External_Name, Name_Link_Name));
16199 Check_At_Least_N_Arguments (2);
16200 Check_At_Most_N_Arguments (3);
16201 Id := Get_Pragma_Arg (Arg1);
16204 -- This is obsolete from Ada 95 on, but it is an implementation
16205 -- defined pragma, so we do not consider that it violates the
16206 -- restriction (No_Obsolescent_Features).
16208 if Ada_Version >= Ada_95 then
16209 if Warn_On_Obsolescent_Feature then
16211 ("pragma Interface_Name is an obsolescent feature?j?", N);
16213 ("|use pragma Import instead?j?", N);
16217 if not Is_Entity_Name (Id) then
16219 ("first argument for pragma% must be entity name", Arg1);
16220 elsif Etype (Id) = Any_Type then
16223 Def_Id := Entity (Id);
16226 -- Special DEC-compatible processing for the object case, forces
16227 -- object to be imported.
16229 if Ekind (Def_Id) = E_Variable then
16230 Kill_Size_Check_Code (Def_Id);
16231 Note_Possible_Modification (Id, Sure => False);
16233 -- Initialization is not allowed for imported variable
16235 if Present (Expression (Parent (Def_Id)))
16236 and then Comes_From_Source (Expression (Parent (Def_Id)))
16238 Error_Msg_Sloc := Sloc (Def_Id);
16240 ("no initialization allowed for declaration of& #",
16244 -- For compatibility, support VADS usage of providing both
16245 -- pragmas Interface and Interface_Name to obtain the effect
16246 -- of a single Import pragma.
16248 if Is_Imported (Def_Id)
16249 and then Present (First_Rep_Item (Def_Id))
16250 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16252 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
16256 Set_Imported (Def_Id);
16259 Set_Is_Public (Def_Id);
16260 Process_Interface_Name (Def_Id, Arg2, Arg3);
16263 -- Otherwise must be subprogram
16265 elsif not Is_Subprogram (Def_Id) then
16267 ("argument of pragma% is not subprogram", Arg1);
16270 Check_At_Most_N_Arguments (3);
16274 -- Loop through homonyms
16277 Def_Id := Get_Base_Subprogram (Hom_Id);
16279 if Is_Imported (Def_Id) then
16280 Process_Interface_Name (Def_Id, Arg2, Arg3);
16284 exit when From_Aspect_Specification (N);
16285 Hom_Id := Homonym (Hom_Id);
16287 exit when No (Hom_Id)
16288 or else Scope (Hom_Id) /= Current_Scope;
16293 ("argument of pragma% is not imported subprogram",
16297 end Interface_Name;
16299 -----------------------
16300 -- Interrupt_Handler --
16301 -----------------------
16303 -- pragma Interrupt_Handler (handler_NAME);
16305 when Pragma_Interrupt_Handler =>
16306 Check_Ada_83_Warning;
16307 Check_Arg_Count (1);
16308 Check_No_Identifiers;
16310 if No_Run_Time_Mode then
16311 Error_Msg_CRT ("Interrupt_Handler pragma", N);
16313 Check_Interrupt_Or_Attach_Handler;
16314 Process_Interrupt_Or_Attach_Handler;
16317 ------------------------
16318 -- Interrupt_Priority --
16319 ------------------------
16321 -- pragma Interrupt_Priority [(EXPRESSION)];
16323 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16324 P : constant Node_Id := Parent (N);
16329 Check_Ada_83_Warning;
16331 if Arg_Count /= 0 then
16332 Arg := Get_Pragma_Arg (Arg1);
16333 Check_Arg_Count (1);
16334 Check_No_Identifiers;
16336 -- The expression must be analyzed in the special manner
16337 -- described in "Handling of Default and Per-Object
16338 -- Expressions" in sem.ads.
16340 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16343 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16348 Ent := Defining_Identifier (Parent (P));
16350 -- Check duplicate pragma before we chain the pragma in the Rep
16351 -- Item chain of Ent.
16353 Check_Duplicate_Pragma (Ent);
16354 Record_Rep_Item (Ent, N);
16356 -- Check the No_Task_At_Interrupt_Priority restriction
16358 if Nkind (P) = N_Task_Definition then
16359 Check_Restriction (No_Task_At_Interrupt_Priority, N);
16362 end Interrupt_Priority;
16364 ---------------------
16365 -- Interrupt_State --
16366 ---------------------
16368 -- pragma Interrupt_State (
16369 -- [Name =>] INTERRUPT_ID,
16370 -- [State =>] INTERRUPT_STATE);
16372 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16373 -- INTERRUPT_STATE => System | Runtime | User
16375 -- Note: if the interrupt id is given as an identifier, then it must
16376 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16377 -- given as a static integer expression which must be in the range of
16378 -- Ada.Interrupts.Interrupt_ID.
16380 when Pragma_Interrupt_State => Interrupt_State : declare
16381 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16382 -- This is the entity Ada.Interrupts.Interrupt_ID;
16384 State_Type : Character;
16385 -- Set to 's'/'r'/'u' for System/Runtime/User
16388 -- Index to entry in Interrupt_States table
16391 -- Value of interrupt
16393 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16394 -- The first argument to the pragma
16396 Int_Ent : Entity_Id;
16397 -- Interrupt entity in Ada.Interrupts.Names
16401 Check_Arg_Order ((Name_Name, Name_State));
16402 Check_Arg_Count (2);
16404 Check_Optional_Identifier (Arg1, Name_Name);
16405 Check_Optional_Identifier (Arg2, Name_State);
16406 Check_Arg_Is_Identifier (Arg2);
16408 -- First argument is identifier
16410 if Nkind (Arg1X) = N_Identifier then
16412 -- Search list of names in Ada.Interrupts.Names
16414 Int_Ent := First_Entity (RTE (RE_Names));
16416 if No (Int_Ent) then
16417 Error_Pragma_Arg ("invalid interrupt name", Arg1);
16419 elsif Chars (Int_Ent) = Chars (Arg1X) then
16420 Int_Val := Expr_Value (Constant_Value (Int_Ent));
16424 Next_Entity (Int_Ent);
16427 -- First argument is not an identifier, so it must be a static
16428 -- expression of type Ada.Interrupts.Interrupt_ID.
16431 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16432 Int_Val := Expr_Value (Arg1X);
16434 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16436 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16439 ("value not in range of type "
16440 & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16446 case Chars (Get_Pragma_Arg (Arg2)) is
16447 when Name_Runtime => State_Type := 'r';
16448 when Name_System => State_Type := 's';
16449 when Name_User => State_Type := 'u';
16452 Error_Pragma_Arg ("invalid interrupt state", Arg2);
16455 -- Check if entry is already stored
16457 IST_Num := Interrupt_States.First;
16459 -- If entry not found, add it
16461 if IST_Num > Interrupt_States.Last then
16462 Interrupt_States.Append
16463 ((Interrupt_Number => UI_To_Int (Int_Val),
16464 Interrupt_State => State_Type,
16465 Pragma_Loc => Loc));
16468 -- Case of entry for the same entry
16470 elsif Int_Val = Interrupt_States.Table (IST_Num).
16473 -- If state matches, done, no need to make redundant entry
16476 State_Type = Interrupt_States.Table (IST_Num).
16479 -- Otherwise if state does not match, error
16482 Interrupt_States.Table (IST_Num).Pragma_Loc;
16484 ("state conflicts with that given #", Arg2);
16488 IST_Num := IST_Num + 1;
16490 end Interrupt_State;
16496 -- pragma Invariant
16497 -- ([Entity =>] type_LOCAL_NAME,
16498 -- [Check =>] EXPRESSION
16499 -- [,[Message =>] String_Expression]);
16501 when Pragma_Invariant => Invariant : declare
16506 CRec_Typ : Entity_Id;
16507 -- The corresponding record type of Full_Typ
16509 Full_Base : Entity_Id;
16510 -- The base type of Full_Typ
16512 Full_Typ : Entity_Id;
16513 -- The full view of Typ
16515 Priv_Typ : Entity_Id;
16516 -- The partial view of Typ
16520 Check_At_Least_N_Arguments (2);
16521 Check_At_Most_N_Arguments (3);
16522 Check_Optional_Identifier (Arg1, Name_Entity);
16523 Check_Optional_Identifier (Arg2, Name_Check);
16525 if Arg_Count = 3 then
16526 Check_Optional_Identifier (Arg3, Name_Message);
16527 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16530 Check_Arg_Is_Local_Name (Arg1);
16532 Typ_Arg := Get_Pragma_Arg (Arg1);
16533 Find_Type (Typ_Arg);
16534 Typ := Entity (Typ_Arg);
16536 -- Nothing to do of the related type is erroneous in some way
16538 if Typ = Any_Type then
16541 -- AI12-0041: Invariants are allowed in interface types
16543 elsif Is_Interface (Typ) then
16546 -- An invariant must apply to a private type, or appear in the
16547 -- private part of a package spec and apply to a completion.
16548 -- a class-wide invariant can only appear on a private declaration
16549 -- or private extension, not a completion.
16551 -- A [class-wide] invariant may be associated a [limited] private
16552 -- type or a private extension.
16554 elsif Ekind_In (Typ, E_Limited_Private_Type,
16556 E_Record_Type_With_Private)
16560 -- A non-class-wide invariant may be associated with the full view
16561 -- of a [limited] private type or a private extension.
16563 elsif Has_Private_Declaration (Typ)
16564 and then not Class_Present (N)
16568 -- A class-wide invariant may appear on the partial view only
16570 elsif Class_Present (N) then
16572 ("pragma % only allowed for private type", Arg1);
16575 -- A regular invariant may appear on both views
16579 ("pragma % only allowed for private type or corresponding "
16580 & "full view", Arg1);
16584 -- An invariant associated with an abstract type (this includes
16585 -- interfaces) must be class-wide.
16587 if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16589 ("pragma % not allowed for abstract type", Arg1);
16593 -- A pragma that applies to a Ghost entity becomes Ghost for the
16594 -- purposes of legality checks and removal of ignored Ghost code.
16596 Mark_Pragma_As_Ghost (N, Typ);
16598 -- The pragma defines a type-specific invariant, the type is said
16599 -- to have invariants of its "own".
16601 Set_Has_Own_Invariants (Typ);
16603 -- If the invariant is class-wide, then it can be inherited by
16604 -- derived or interface implementing types. The type is said to
16605 -- have "inheritable" invariants.
16607 if Class_Present (N) then
16608 Set_Has_Inheritable_Invariants (Typ);
16611 Get_Views (Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
16613 -- Propagate invariant-related attributes to all views of the type
16614 -- and any additional types that may have been created.
16616 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Typ);
16617 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Typ);
16618 Propagate_Invariant_Attributes (Full_Base, From_Typ => Typ);
16619 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Typ);
16621 -- Chain the pragma on to the rep item chain, for processing when
16622 -- the type is frozen.
16624 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16626 -- Create the declaration of the invariant procedure which will
16627 -- verify the invariant at run-time. Note that interfaces do not
16628 -- carry such a declaration.
16630 Build_Invariant_Procedure_Declaration (Typ);
16637 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16639 when Pragma_Keep_Names => Keep_Names : declare
16644 Check_Arg_Count (1);
16645 Check_Optional_Identifier (Arg1, Name_On);
16646 Check_Arg_Is_Local_Name (Arg1);
16648 Arg := Get_Pragma_Arg (Arg1);
16651 if Etype (Arg) = Any_Type then
16655 if not Is_Entity_Name (Arg)
16656 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16659 ("pragma% requires a local enumeration type", Arg1);
16662 Set_Discard_Names (Entity (Arg), False);
16669 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16671 when Pragma_License =>
16674 -- Do not analyze pragma any further in CodePeer mode, to avoid
16675 -- extraneous errors in this implementation-dependent pragma,
16676 -- which has a different profile on other compilers.
16678 if CodePeer_Mode then
16682 Check_Arg_Count (1);
16683 Check_No_Identifiers;
16684 Check_Valid_Configuration_Pragma;
16685 Check_Arg_Is_Identifier (Arg1);
16688 Sind : constant Source_File_Index :=
16689 Source_Index (Current_Sem_Unit);
16692 case Chars (Get_Pragma_Arg (Arg1)) is
16694 Set_License (Sind, GPL);
16696 when Name_Modified_GPL =>
16697 Set_License (Sind, Modified_GPL);
16699 when Name_Restricted =>
16700 Set_License (Sind, Restricted);
16702 when Name_Unrestricted =>
16703 Set_License (Sind, Unrestricted);
16706 Error_Pragma_Arg ("invalid license name", Arg1);
16714 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16716 when Pragma_Link_With => Link_With : declare
16722 if Operating_Mode = Generate_Code
16723 and then In_Extended_Main_Source_Unit (N)
16725 Check_At_Least_N_Arguments (1);
16726 Check_No_Identifiers;
16727 Check_Is_In_Decl_Part_Or_Package_Spec;
16728 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16732 while Present (Arg) loop
16733 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16735 -- Store argument, converting sequences of spaces to a
16736 -- single null character (this is one of the differences
16737 -- in processing between Link_With and Linker_Options).
16739 Arg_Store : declare
16740 C : constant Char_Code := Get_Char_Code (' ');
16741 S : constant String_Id :=
16742 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
16743 L : constant Nat := String_Length (S);
16746 procedure Skip_Spaces;
16747 -- Advance F past any spaces
16753 procedure Skip_Spaces is
16755 while F <= L and then Get_String_Char (S, F) = C loop
16760 -- Start of processing for Arg_Store
16763 Skip_Spaces; -- skip leading spaces
16765 -- Loop through characters, changing any embedded
16766 -- sequence of spaces to a single null character (this
16767 -- is how Link_With/Linker_Options differ)
16770 if Get_String_Char (S, F) = C then
16773 Store_String_Char (ASCII.NUL);
16776 Store_String_Char (Get_String_Char (S, F));
16784 if Present (Arg) then
16785 Store_String_Char (ASCII.NUL);
16789 Store_Linker_Option_String (End_String);
16797 -- pragma Linker_Alias (
16798 -- [Entity =>] LOCAL_NAME
16799 -- [Target =>] static_string_EXPRESSION);
16801 when Pragma_Linker_Alias =>
16803 Check_Arg_Order ((Name_Entity, Name_Target));
16804 Check_Arg_Count (2);
16805 Check_Optional_Identifier (Arg1, Name_Entity);
16806 Check_Optional_Identifier (Arg2, Name_Target);
16807 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16808 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16810 -- The only processing required is to link this item on to the
16811 -- list of rep items for the given entity. This is accomplished
16812 -- by the call to Rep_Item_Too_Late (when no error is detected
16813 -- and False is returned).
16815 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
16818 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
16821 ------------------------
16822 -- Linker_Constructor --
16823 ------------------------
16825 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16827 -- Code is shared with Linker_Destructor
16829 -----------------------
16830 -- Linker_Destructor --
16831 -----------------------
16833 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16835 when Pragma_Linker_Constructor |
16836 Pragma_Linker_Destructor =>
16837 Linker_Constructor : declare
16843 Check_Arg_Count (1);
16844 Check_No_Identifiers;
16845 Check_Arg_Is_Local_Name (Arg1);
16846 Arg1_X := Get_Pragma_Arg (Arg1);
16848 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
16850 if not Is_Library_Level_Entity (Proc) then
16852 ("argument for pragma% must be library level entity", Arg1);
16855 -- The only processing required is to link this item on to the
16856 -- list of rep items for the given entity. This is accomplished
16857 -- by the call to Rep_Item_Too_Late (when no error is detected
16858 -- and False is returned).
16860 if Rep_Item_Too_Late (Proc, N) then
16863 Set_Has_Gigi_Rep_Item (Proc);
16865 end Linker_Constructor;
16867 --------------------
16868 -- Linker_Options --
16869 --------------------
16871 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16873 when Pragma_Linker_Options => Linker_Options : declare
16877 Check_Ada_83_Warning;
16878 Check_No_Identifiers;
16879 Check_Arg_Count (1);
16880 Check_Is_In_Decl_Part_Or_Package_Spec;
16881 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
16882 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
16885 while Present (Arg) loop
16886 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
16887 Store_String_Char (ASCII.NUL);
16889 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
16893 if Operating_Mode = Generate_Code
16894 and then In_Extended_Main_Source_Unit (N)
16896 Store_Linker_Option_String (End_String);
16898 end Linker_Options;
16900 --------------------
16901 -- Linker_Section --
16902 --------------------
16904 -- pragma Linker_Section (
16905 -- [Entity =>] LOCAL_NAME
16906 -- [Section =>] static_string_EXPRESSION);
16908 when Pragma_Linker_Section => Linker_Section : declare
16913 Ghost_Error_Posted : Boolean := False;
16914 -- Flag set when an error concerning the illegal mix of Ghost and
16915 -- non-Ghost subprograms is emitted.
16917 Ghost_Id : Entity_Id := Empty;
16918 -- The entity of the first Ghost subprogram encountered while
16919 -- processing the arguments of the pragma.
16923 Check_Arg_Order ((Name_Entity, Name_Section));
16924 Check_Arg_Count (2);
16925 Check_Optional_Identifier (Arg1, Name_Entity);
16926 Check_Optional_Identifier (Arg2, Name_Section);
16927 Check_Arg_Is_Library_Level_Local_Name (Arg1);
16928 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
16930 -- Check kind of entity
16932 Arg := Get_Pragma_Arg (Arg1);
16933 Ent := Entity (Arg);
16935 case Ekind (Ent) is
16937 -- Objects (constants and variables) and types. For these cases
16938 -- all we need to do is to set the Linker_Section_pragma field,
16939 -- checking that we do not have a duplicate.
16941 when E_Constant | E_Variable | Type_Kind =>
16942 LPE := Linker_Section_Pragma (Ent);
16944 if Present (LPE) then
16945 Error_Msg_Sloc := Sloc (LPE);
16947 ("Linker_Section already specified for &#", Arg1, Ent);
16950 Set_Linker_Section_Pragma (Ent, N);
16952 -- A pragma that applies to a Ghost entity becomes Ghost for
16953 -- the purposes of legality checks and removal of ignored
16956 Mark_Pragma_As_Ghost (N, Ent);
16960 when Subprogram_Kind =>
16962 -- Aspect case, entity already set
16964 if From_Aspect_Specification (N) then
16965 Set_Linker_Section_Pragma
16966 (Entity (Corresponding_Aspect (N)), N);
16968 -- Pragma case, we must climb the homonym chain, but skip
16969 -- any for which the linker section is already set.
16973 if No (Linker_Section_Pragma (Ent)) then
16974 Set_Linker_Section_Pragma (Ent, N);
16976 -- A pragma that applies to a Ghost entity becomes
16977 -- Ghost for the purposes of legality checks and
16978 -- removal of ignored Ghost code.
16980 Mark_Pragma_As_Ghost (N, Ent);
16982 -- Capture the entity of the first Ghost subprogram
16983 -- being processed for error detection purposes.
16985 if Is_Ghost_Entity (Ent) then
16986 if No (Ghost_Id) then
16990 -- Otherwise the subprogram is non-Ghost. It is
16991 -- illegal to mix references to Ghost and non-Ghost
16992 -- entities (SPARK RM 6.9).
16994 elsif Present (Ghost_Id)
16995 and then not Ghost_Error_Posted
16997 Ghost_Error_Posted := True;
16999 Error_Msg_Name_1 := Pname;
17001 ("pragma % cannot mention ghost and "
17002 & "non-ghost subprograms", N);
17004 Error_Msg_Sloc := Sloc (Ghost_Id);
17006 ("\& # declared as ghost", N, Ghost_Id);
17008 Error_Msg_Sloc := Sloc (Ent);
17010 ("\& # declared as non-ghost", N, Ent);
17014 Ent := Homonym (Ent);
17016 or else Scope (Ent) /= Current_Scope;
17020 -- All other cases are illegal
17024 ("pragma% applies only to objects, subprograms, and types",
17027 end Linker_Section;
17033 -- pragma List (On | Off)
17035 -- There is nothing to do here, since we did all the processing for
17036 -- this pragma in Par.Prag (so that it works properly even in syntax
17039 when Pragma_List =>
17046 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17048 when Pragma_Lock_Free => Lock_Free : declare
17049 P : constant Node_Id := Parent (N);
17055 Check_No_Identifiers;
17056 Check_At_Most_N_Arguments (1);
17058 -- Protected definition case
17060 if Nkind (P) = N_Protected_Definition then
17061 Ent := Defining_Identifier (Parent (P));
17065 if Arg_Count = 1 then
17066 Arg := Get_Pragma_Arg (Arg1);
17067 Val := Is_True (Static_Boolean (Arg));
17069 -- No arguments (expression is considered to be True)
17075 -- Check duplicate pragma before we chain the pragma in the Rep
17076 -- Item chain of Ent.
17078 Check_Duplicate_Pragma (Ent);
17079 Record_Rep_Item (Ent, N);
17080 Set_Uses_Lock_Free (Ent, Val);
17082 -- Anything else is incorrect placement
17089 --------------------
17090 -- Locking_Policy --
17091 --------------------
17093 -- pragma Locking_Policy (policy_IDENTIFIER);
17095 when Pragma_Locking_Policy => declare
17096 subtype LP_Range is Name_Id
17097 range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17102 Check_Ada_83_Warning;
17103 Check_Arg_Count (1);
17104 Check_No_Identifiers;
17105 Check_Arg_Is_Locking_Policy (Arg1);
17106 Check_Valid_Configuration_Pragma;
17107 LP_Val := Chars (Get_Pragma_Arg (Arg1));
17110 when Name_Ceiling_Locking =>
17112 when Name_Inheritance_Locking =>
17114 when Name_Concurrent_Readers_Locking =>
17118 if Locking_Policy /= ' '
17119 and then Locking_Policy /= LP
17121 Error_Msg_Sloc := Locking_Policy_Sloc;
17122 Error_Pragma ("locking policy incompatible with policy#");
17124 -- Set new policy, but always preserve System_Location since we
17125 -- like the error message with the run time name.
17128 Locking_Policy := LP;
17130 if Locking_Policy_Sloc /= System_Location then
17131 Locking_Policy_Sloc := Loc;
17136 -------------------
17137 -- Loop_Optimize --
17138 -------------------
17140 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17142 -- OPTIMIZATION_HINT ::=
17143 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17145 when Pragma_Loop_Optimize => Loop_Optimize : declare
17150 Check_At_Least_N_Arguments (1);
17151 Check_No_Identifiers;
17153 Hint := First (Pragma_Argument_Associations (N));
17154 while Present (Hint) loop
17155 Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17163 Check_Loop_Pragma_Placement;
17170 -- pragma Loop_Variant
17171 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17173 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17175 -- CHANGE_DIRECTION ::= Increases | Decreases
17177 when Pragma_Loop_Variant => Loop_Variant : declare
17182 Check_At_Least_N_Arguments (1);
17183 Check_Loop_Pragma_Placement;
17185 -- Process all increasing / decreasing expressions
17187 Variant := First (Pragma_Argument_Associations (N));
17188 while Present (Variant) loop
17189 if not Nam_In (Chars (Variant), Name_Decreases,
17192 Error_Pragma_Arg ("wrong change modifier", Variant);
17195 Preanalyze_Assert_Expression
17196 (Expression (Variant), Any_Discrete);
17202 -----------------------
17203 -- Machine_Attribute --
17204 -----------------------
17206 -- pragma Machine_Attribute (
17207 -- [Entity =>] LOCAL_NAME,
17208 -- [Attribute_Name =>] static_string_EXPRESSION
17209 -- [, [Info =>] static_EXPRESSION] );
17211 when Pragma_Machine_Attribute => Machine_Attribute : declare
17212 Def_Id : Entity_Id;
17216 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17218 if Arg_Count = 3 then
17219 Check_Optional_Identifier (Arg3, Name_Info);
17220 Check_Arg_Is_OK_Static_Expression (Arg3);
17222 Check_Arg_Count (2);
17225 Check_Optional_Identifier (Arg1, Name_Entity);
17226 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17227 Check_Arg_Is_Local_Name (Arg1);
17228 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17229 Def_Id := Entity (Get_Pragma_Arg (Arg1));
17231 if Is_Access_Type (Def_Id) then
17232 Def_Id := Designated_Type (Def_Id);
17235 if Rep_Item_Too_Early (Def_Id, N) then
17239 Def_Id := Underlying_Type (Def_Id);
17241 -- The only processing required is to link this item on to the
17242 -- list of rep items for the given entity. This is accomplished
17243 -- by the call to Rep_Item_Too_Late (when no error is detected
17244 -- and False is returned).
17246 if Rep_Item_Too_Late (Def_Id, N) then
17249 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17251 end Machine_Attribute;
17258 -- (MAIN_OPTION [, MAIN_OPTION]);
17261 -- [STACK_SIZE =>] static_integer_EXPRESSION
17262 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17263 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17265 when Pragma_Main => Main : declare
17266 Args : Args_List (1 .. 3);
17267 Names : constant Name_List (1 .. 3) := (
17269 Name_Task_Stack_Size_Default,
17270 Name_Time_Slicing_Enabled);
17276 Gather_Associations (Names, Args);
17278 for J in 1 .. 2 loop
17279 if Present (Args (J)) then
17280 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17284 if Present (Args (3)) then
17285 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17289 while Present (Nod) loop
17290 if Nkind (Nod) = N_Pragma
17291 and then Pragma_Name (Nod) = Name_Main
17293 Error_Msg_Name_1 := Pname;
17294 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17305 -- pragma Main_Storage
17306 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17308 -- MAIN_STORAGE_OPTION ::=
17309 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17310 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17312 when Pragma_Main_Storage => Main_Storage : declare
17313 Args : Args_List (1 .. 2);
17314 Names : constant Name_List (1 .. 2) := (
17315 Name_Working_Storage,
17322 Gather_Associations (Names, Args);
17324 for J in 1 .. 2 loop
17325 if Present (Args (J)) then
17326 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17330 Check_In_Main_Program;
17333 while Present (Nod) loop
17334 if Nkind (Nod) = N_Pragma
17335 and then Pragma_Name (Nod) = Name_Main_Storage
17337 Error_Msg_Name_1 := Pname;
17338 Error_Msg_N ("duplicate pragma% not permitted", Nod);
17349 -- pragma Memory_Size (NUMERIC_LITERAL)
17351 when Pragma_Memory_Size =>
17354 -- Memory size is simply ignored
17356 Check_No_Identifiers;
17357 Check_Arg_Count (1);
17358 Check_Arg_Is_Integer_Literal (Arg1);
17366 -- The only correct use of this pragma is on its own in a file, in
17367 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17368 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17369 -- check for a file containing nothing but a No_Body pragma). If we
17370 -- attempt to process it during normal semantics processing, it means
17371 -- it was misplaced.
17373 when Pragma_No_Body =>
17377 -----------------------------
17378 -- No_Elaboration_Code_All --
17379 -----------------------------
17381 -- pragma No_Elaboration_Code_All;
17383 when Pragma_No_Elaboration_Code_All =>
17385 Check_Valid_Library_Unit_Pragma;
17387 if Nkind (N) = N_Null_Statement then
17391 -- Must appear for a spec or generic spec
17393 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17394 N_Generic_Package_Declaration,
17395 N_Generic_Subprogram_Declaration,
17396 N_Package_Declaration,
17397 N_Subprogram_Declaration)
17401 ("pragma% can only occur for package "
17402 & "or subprogram spec"));
17405 -- Set flag in unit table
17407 Set_No_Elab_Code_All (Current_Sem_Unit);
17409 -- Set restriction No_Elaboration_Code if this is the main unit
17411 if Current_Sem_Unit = Main_Unit then
17412 Set_Restriction (No_Elaboration_Code, N);
17415 -- If we are in the main unit or in an extended main source unit,
17416 -- then we also add it to the configuration restrictions so that
17417 -- it will apply to all units in the extended main source.
17419 if Current_Sem_Unit = Main_Unit
17420 or else In_Extended_Main_Source_Unit (N)
17422 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17425 -- If in main extended unit, activate transitive with test
17427 if In_Extended_Main_Source_Unit (N) then
17428 Opt.No_Elab_Code_All_Pragma := N;
17435 -- pragma No_Inline ( NAME {, NAME} );
17437 when Pragma_No_Inline =>
17439 Process_Inline (Suppressed);
17445 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17447 when Pragma_No_Return => No_Return : declare
17453 Ghost_Error_Posted : Boolean := False;
17454 -- Flag set when an error concerning the illegal mix of Ghost and
17455 -- non-Ghost subprograms is emitted.
17457 Ghost_Id : Entity_Id := Empty;
17458 -- The entity of the first Ghost procedure encountered while
17459 -- processing the arguments of the pragma.
17463 Check_At_Least_N_Arguments (1);
17465 -- Loop through arguments of pragma
17468 while Present (Arg) loop
17469 Check_Arg_Is_Local_Name (Arg);
17470 Id := Get_Pragma_Arg (Arg);
17473 if not Is_Entity_Name (Id) then
17474 Error_Pragma_Arg ("entity name required", Arg);
17477 if Etype (Id) = Any_Type then
17481 -- Loop to find matching procedures
17487 and then Scope (E) = Current_Scope
17489 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17492 -- A pragma that applies to a Ghost entity becomes Ghost
17493 -- for the purposes of legality checks and removal of
17494 -- ignored Ghost code.
17496 Mark_Pragma_As_Ghost (N, E);
17498 -- Capture the entity of the first Ghost procedure being
17499 -- processed for error detection purposes.
17501 if Is_Ghost_Entity (E) then
17502 if No (Ghost_Id) then
17506 -- Otherwise the subprogram is non-Ghost. It is illegal
17507 -- to mix references to Ghost and non-Ghost entities
17510 elsif Present (Ghost_Id)
17511 and then not Ghost_Error_Posted
17513 Ghost_Error_Posted := True;
17515 Error_Msg_Name_1 := Pname;
17517 ("pragma % cannot mention ghost and non-ghost "
17518 & "procedures", N);
17520 Error_Msg_Sloc := Sloc (Ghost_Id);
17521 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17523 Error_Msg_Sloc := Sloc (E);
17524 Error_Msg_NE ("\& # declared as non-ghost", N, E);
17527 -- Set flag on any alias as well
17529 if Is_Overloadable (E) and then Present (Alias (E)) then
17530 Set_No_Return (Alias (E));
17536 exit when From_Aspect_Specification (N);
17540 -- If entity in not in current scope it may be the enclosing
17541 -- suprogram body to which the aspect applies.
17544 if Entity (Id) = Current_Scope
17545 and then From_Aspect_Specification (N)
17547 Set_No_Return (Entity (Id));
17549 Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17561 -- pragma No_Run_Time;
17563 -- Note: this pragma is retained for backwards compatibility. See
17564 -- body of Rtsfind for full details on its handling.
17566 when Pragma_No_Run_Time =>
17568 Check_Valid_Configuration_Pragma;
17569 Check_Arg_Count (0);
17571 No_Run_Time_Mode := True;
17572 Configurable_Run_Time_Mode := True;
17574 -- Set Duration to 32 bits if word size is 32
17576 if Ttypes.System_Word_Size = 32 then
17577 Duration_32_Bits_On_Target := True;
17580 -- Set appropriate restrictions
17582 Set_Restriction (No_Finalization, N);
17583 Set_Restriction (No_Exception_Handlers, N);
17584 Set_Restriction (Max_Tasks, N, 0);
17585 Set_Restriction (No_Tasking, N);
17587 -----------------------
17588 -- No_Tagged_Streams --
17589 -----------------------
17591 -- pragma No_Tagged_Streams;
17592 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17594 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17600 Check_At_Most_N_Arguments (1);
17602 -- One argument case
17604 if Arg_Count = 1 then
17605 Check_Optional_Identifier (Arg1, Name_Entity);
17606 Check_Arg_Is_Local_Name (Arg1);
17607 E_Id := Get_Pragma_Arg (Arg1);
17609 if Etype (E_Id) = Any_Type then
17613 E := Entity (E_Id);
17615 Check_Duplicate_Pragma (E);
17617 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17619 ("argument for pragma% must be root tagged type", Arg1);
17622 if Rep_Item_Too_Early (E, N)
17624 Rep_Item_Too_Late (E, N)
17628 Set_No_Tagged_Streams_Pragma (E, N);
17631 -- Zero argument case
17634 Check_Is_In_Decl_Part_Or_Package_Spec;
17635 No_Tagged_Streams := N;
17637 end No_Tagged_Strms;
17639 ------------------------
17640 -- No_Strict_Aliasing --
17641 ------------------------
17643 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17645 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17650 Check_At_Most_N_Arguments (1);
17652 if Arg_Count = 0 then
17653 Check_Valid_Configuration_Pragma;
17654 Opt.No_Strict_Aliasing := True;
17657 Check_Optional_Identifier (Arg2, Name_Entity);
17658 Check_Arg_Is_Local_Name (Arg1);
17659 E_Id := Entity (Get_Pragma_Arg (Arg1));
17661 if E_Id = Any_Type then
17663 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
17664 Error_Pragma_Arg ("pragma% requires access type", Arg1);
17667 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
17669 end No_Strict_Aliasing;
17671 -----------------------
17672 -- Normalize_Scalars --
17673 -----------------------
17675 -- pragma Normalize_Scalars;
17677 when Pragma_Normalize_Scalars =>
17678 Check_Ada_83_Warning;
17679 Check_Arg_Count (0);
17680 Check_Valid_Configuration_Pragma;
17682 -- Normalize_Scalars creates false positives in CodePeer, and
17683 -- incorrect negative results in GNATprove mode, so ignore this
17684 -- pragma in these modes.
17686 if not (CodePeer_Mode or GNATprove_Mode) then
17687 Normalize_Scalars := True;
17688 Init_Or_Norm_Scalars := True;
17695 -- pragma Obsolescent;
17697 -- pragma Obsolescent (
17698 -- [Message =>] static_string_EXPRESSION
17699 -- [,[Version =>] Ada_05]]);
17701 -- pragma Obsolescent (
17702 -- [Entity =>] NAME
17703 -- [,[Message =>] static_string_EXPRESSION
17704 -- [,[Version =>] Ada_05]] );
17706 when Pragma_Obsolescent => Obsolescent : declare
17710 procedure Set_Obsolescent (E : Entity_Id);
17711 -- Given an entity Ent, mark it as obsolescent if appropriate
17713 ---------------------
17714 -- Set_Obsolescent --
17715 ---------------------
17717 procedure Set_Obsolescent (E : Entity_Id) is
17726 -- A pragma that applies to a Ghost entity becomes Ghost for
17727 -- the purposes of legality checks and removal of ignored Ghost
17730 Mark_Pragma_As_Ghost (N, E);
17732 -- Entity name was given
17734 if Present (Ename) then
17736 -- If entity name matches, we are fine. Save entity in
17737 -- pragma argument, for ASIS use.
17739 if Chars (Ename) = Chars (Ent) then
17740 Set_Entity (Ename, Ent);
17741 Generate_Reference (Ent, Ename);
17743 -- If entity name does not match, only possibility is an
17744 -- enumeration literal from an enumeration type declaration.
17746 elsif Ekind (Ent) /= E_Enumeration_Type then
17748 ("pragma % entity name does not match declaration");
17751 Ent := First_Literal (E);
17755 ("pragma % entity name does not match any "
17756 & "enumeration literal");
17758 elsif Chars (Ent) = Chars (Ename) then
17759 Set_Entity (Ename, Ent);
17760 Generate_Reference (Ent, Ename);
17764 Ent := Next_Literal (Ent);
17770 -- Ent points to entity to be marked
17772 if Arg_Count >= 1 then
17774 -- Deal with static string argument
17776 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17777 S := Strval (Get_Pragma_Arg (Arg1));
17779 for J in 1 .. String_Length (S) loop
17780 if not In_Character_Range (Get_String_Char (S, J)) then
17782 ("pragma% argument does not allow wide characters",
17787 Obsolescent_Warnings.Append
17788 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
17790 -- Check for Ada_05 parameter
17792 if Arg_Count /= 1 then
17793 Check_Arg_Count (2);
17796 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
17799 Check_Arg_Is_Identifier (Argx);
17801 if Chars (Argx) /= Name_Ada_05 then
17802 Error_Msg_Name_2 := Name_Ada_05;
17804 ("only allowed argument for pragma% is %", Argx);
17807 if Ada_Version_Explicit < Ada_2005
17808 or else not Warn_On_Ada_2005_Compatibility
17816 -- Set flag if pragma active
17819 Set_Is_Obsolescent (Ent);
17823 end Set_Obsolescent;
17825 -- Start of processing for pragma Obsolescent
17830 Check_At_Most_N_Arguments (3);
17832 -- See if first argument specifies an entity name
17836 (Chars (Arg1) = Name_Entity
17838 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
17840 N_Operator_Symbol))
17842 Ename := Get_Pragma_Arg (Arg1);
17844 -- Eliminate first argument, so we can share processing
17848 Arg_Count := Arg_Count - 1;
17850 -- No Entity name argument given
17856 if Arg_Count >= 1 then
17857 Check_Optional_Identifier (Arg1, Name_Message);
17859 if Arg_Count = 2 then
17860 Check_Optional_Identifier (Arg2, Name_Version);
17864 -- Get immediately preceding declaration
17867 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
17871 -- Cases where we do not follow anything other than another pragma
17875 -- First case: library level compilation unit declaration with
17876 -- the pragma immediately following the declaration.
17878 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
17880 (Defining_Entity (Unit (Parent (Parent (N)))));
17883 -- Case 2: library unit placement for package
17887 Ent : constant Entity_Id := Find_Lib_Unit_Name;
17889 if Is_Package_Or_Generic_Package (Ent) then
17890 Set_Obsolescent (Ent);
17896 -- Cases where we must follow a declaration, including an
17897 -- abstract subprogram declaration, which is not in the
17898 -- other node subtypes.
17901 if Nkind (Decl) not in N_Declaration
17902 and then Nkind (Decl) not in N_Later_Decl_Item
17903 and then Nkind (Decl) not in N_Generic_Declaration
17904 and then Nkind (Decl) not in N_Renaming_Declaration
17905 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
17908 ("pragma% misplaced, "
17909 & "must immediately follow a declaration");
17912 Set_Obsolescent (Defining_Entity (Decl));
17922 -- pragma Optimize (Time | Space | Off);
17924 -- The actual check for optimize is done in Gigi. Note that this
17925 -- pragma does not actually change the optimization setting, it
17926 -- simply checks that it is consistent with the pragma.
17928 when Pragma_Optimize =>
17929 Check_No_Identifiers;
17930 Check_Arg_Count (1);
17931 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
17933 ------------------------
17934 -- Optimize_Alignment --
17935 ------------------------
17937 -- pragma Optimize_Alignment (Time | Space | Off);
17939 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
17941 Check_No_Identifiers;
17942 Check_Arg_Count (1);
17943 Check_Valid_Configuration_Pragma;
17946 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
17950 Opt.Optimize_Alignment := 'T';
17952 Opt.Optimize_Alignment := 'S';
17954 Opt.Optimize_Alignment := 'O';
17956 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
17960 -- Set indication that mode is set locally. If we are in fact in a
17961 -- configuration pragma file, this setting is harmless since the
17962 -- switch will get reset anyway at the start of each unit.
17964 Optimize_Alignment_Local := True;
17965 end Optimize_Alignment;
17971 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17973 when Pragma_Ordered => Ordered : declare
17974 Assoc : constant Node_Id := Arg1;
17980 Check_No_Identifiers;
17981 Check_Arg_Count (1);
17982 Check_Arg_Is_Local_Name (Arg1);
17984 Type_Id := Get_Pragma_Arg (Assoc);
17985 Find_Type (Type_Id);
17986 Typ := Entity (Type_Id);
17988 if Typ = Any_Type then
17991 Typ := Underlying_Type (Typ);
17994 if not Is_Enumeration_Type (Typ) then
17995 Error_Pragma ("pragma% must specify enumeration type");
17998 Check_First_Subtype (Arg1);
17999 Set_Has_Pragma_Ordered (Base_Type (Typ));
18002 -------------------
18003 -- Overflow_Mode --
18004 -------------------
18006 -- pragma Overflow_Mode
18007 -- ([General => ] MODE [, [Assertions => ] MODE]);
18009 -- MODE := STRICT | MINIMIZED | ELIMINATED
18011 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18012 -- since System.Bignums makes this assumption. This is true of nearly
18013 -- all (all?) targets.
18015 when Pragma_Overflow_Mode => Overflow_Mode : declare
18016 function Get_Overflow_Mode
18018 Arg : Node_Id) return Overflow_Mode_Type;
18019 -- Function to process one pragma argument, Arg. If an identifier
18020 -- is present, it must be Name. Mode type is returned if a valid
18021 -- argument exists, otherwise an error is signalled.
18023 -----------------------
18024 -- Get_Overflow_Mode --
18025 -----------------------
18027 function Get_Overflow_Mode
18029 Arg : Node_Id) return Overflow_Mode_Type
18031 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18034 Check_Optional_Identifier (Arg, Name);
18035 Check_Arg_Is_Identifier (Argx);
18037 if Chars (Argx) = Name_Strict then
18040 elsif Chars (Argx) = Name_Minimized then
18043 elsif Chars (Argx) = Name_Eliminated then
18044 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18046 ("Eliminated not implemented on this target", Argx);
18052 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18054 end Get_Overflow_Mode;
18056 -- Start of processing for Overflow_Mode
18060 Check_At_Least_N_Arguments (1);
18061 Check_At_Most_N_Arguments (2);
18063 -- Process first argument
18065 Scope_Suppress.Overflow_Mode_General :=
18066 Get_Overflow_Mode (Name_General, Arg1);
18068 -- Case of only one argument
18070 if Arg_Count = 1 then
18071 Scope_Suppress.Overflow_Mode_Assertions :=
18072 Scope_Suppress.Overflow_Mode_General;
18074 -- Case of two arguments present
18077 Scope_Suppress.Overflow_Mode_Assertions :=
18078 Get_Overflow_Mode (Name_Assertions, Arg2);
18082 --------------------------
18083 -- Overriding Renamings --
18084 --------------------------
18086 -- pragma Overriding_Renamings;
18088 when Pragma_Overriding_Renamings =>
18090 Check_Arg_Count (0);
18091 Check_Valid_Configuration_Pragma;
18092 Overriding_Renamings := True;
18098 -- pragma Pack (first_subtype_LOCAL_NAME);
18100 when Pragma_Pack => Pack : declare
18101 Assoc : constant Node_Id := Arg1;
18103 Ignore : Boolean := False;
18108 Check_No_Identifiers;
18109 Check_Arg_Count (1);
18110 Check_Arg_Is_Local_Name (Arg1);
18111 Type_Id := Get_Pragma_Arg (Assoc);
18113 if not Is_Entity_Name (Type_Id)
18114 or else not Is_Type (Entity (Type_Id))
18117 ("argument for pragma% must be type or subtype", Arg1);
18120 Find_Type (Type_Id);
18121 Typ := Entity (Type_Id);
18124 or else Rep_Item_Too_Early (Typ, N)
18128 Typ := Underlying_Type (Typ);
18131 -- A pragma that applies to a Ghost entity becomes Ghost for the
18132 -- purposes of legality checks and removal of ignored Ghost code.
18134 Mark_Pragma_As_Ghost (N, Typ);
18136 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18137 Error_Pragma ("pragma% must specify array or record type");
18140 Check_First_Subtype (Arg1);
18141 Check_Duplicate_Pragma (Typ);
18145 if Is_Array_Type (Typ) then
18146 Ctyp := Component_Type (Typ);
18148 -- Ignore pack that does nothing
18150 if Known_Static_Esize (Ctyp)
18151 and then Known_Static_RM_Size (Ctyp)
18152 and then Esize (Ctyp) = RM_Size (Ctyp)
18153 and then Addressable (Esize (Ctyp))
18158 -- Process OK pragma Pack. Note that if there is a separate
18159 -- component clause present, the Pack will be cancelled. This
18160 -- processing is in Freeze.
18162 if not Rep_Item_Too_Late (Typ, N) then
18164 -- In CodePeer mode, we do not need complex front-end
18165 -- expansions related to pragma Pack, so disable handling
18168 if CodePeer_Mode then
18171 -- Normal case where we do the pack action
18175 Set_Is_Packed (Base_Type (Typ));
18176 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18179 Set_Has_Pragma_Pack (Base_Type (Typ));
18183 -- For record types, the pack is always effective
18185 else pragma Assert (Is_Record_Type (Typ));
18186 if not Rep_Item_Too_Late (Typ, N) then
18187 Set_Is_Packed (Base_Type (Typ));
18188 Set_Has_Pragma_Pack (Base_Type (Typ));
18189 Set_Has_Non_Standard_Rep (Base_Type (Typ));
18200 -- There is nothing to do here, since we did all the processing for
18201 -- this pragma in Par.Prag (so that it works properly even in syntax
18204 when Pragma_Page =>
18211 -- pragma Part_Of (ABSTRACT_STATE);
18213 -- ABSTRACT_STATE ::= NAME
18215 when Pragma_Part_Of => Part_Of : declare
18216 procedure Propagate_Part_Of
18217 (Pack_Id : Entity_Id;
18218 State_Id : Entity_Id;
18219 Instance : Node_Id);
18220 -- Propagate the Part_Of indicator to all abstract states and
18221 -- objects declared in the visible state space of a package
18222 -- denoted by Pack_Id. State_Id is the encapsulating state.
18223 -- Instance is the package instantiation node.
18225 -----------------------
18226 -- Propagate_Part_Of --
18227 -----------------------
18229 procedure Propagate_Part_Of
18230 (Pack_Id : Entity_Id;
18231 State_Id : Entity_Id;
18232 Instance : Node_Id)
18234 Has_Item : Boolean := False;
18235 -- Flag set when the visible state space contains at least one
18236 -- abstract state or variable.
18238 procedure Propagate_Part_Of (Pack_Id : Entity_Id);
18239 -- Propagate the Part_Of indicator to all abstract states and
18240 -- objects declared in the visible state space of a package
18241 -- denoted by Pack_Id.
18243 -----------------------
18244 -- Propagate_Part_Of --
18245 -----------------------
18247 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
18248 Constits : Elist_Id;
18249 Item_Id : Entity_Id;
18252 -- Traverse the entity chain of the package and set relevant
18253 -- attributes of abstract states and objects declared in the
18254 -- visible state space of the package.
18256 Item_Id := First_Entity (Pack_Id);
18257 while Present (Item_Id)
18258 and then not In_Private_Part (Item_Id)
18260 -- Do not consider internally generated items
18262 if not Comes_From_Source (Item_Id) then
18265 -- The Part_Of indicator turns an abstract state or an
18266 -- object into a constituent of the encapsulating state.
18268 elsif Ekind_In (Item_Id, E_Abstract_State,
18273 Constits := Part_Of_Constituents (State_Id);
18275 if No (Constits) then
18276 Constits := New_Elmt_List;
18277 Set_Part_Of_Constituents (State_Id, Constits);
18280 Append_Elmt (Item_Id, Constits);
18281 Set_Encapsulating_State (Item_Id, State_Id);
18283 -- Recursively handle nested packages and instantiations
18285 elsif Ekind (Item_Id) = E_Package then
18286 Propagate_Part_Of (Item_Id);
18289 Next_Entity (Item_Id);
18291 end Propagate_Part_Of;
18293 -- Start of processing for Propagate_Part_Of
18296 Propagate_Part_Of (Pack_Id);
18298 -- Detect a package instantiation that is subject to a Part_Of
18299 -- indicator, but has no visible state.
18301 if not Has_Item then
18303 ("package instantiation & has Part_Of indicator but "
18304 & "lacks visible state", Instance, Pack_Id);
18306 end Propagate_Part_Of;
18310 Constits : Elist_Id;
18312 Encap_Id : Entity_Id;
18313 Item_Id : Entity_Id;
18317 -- Start of processing for Part_Of
18321 Check_No_Identifiers;
18322 Check_Arg_Count (1);
18324 Stmt := Find_Related_Context (N, Do_Checks => True);
18326 -- Object declaration
18328 if Nkind (Stmt) = N_Object_Declaration then
18331 -- Package instantiation
18333 elsif Nkind (Stmt) = N_Package_Instantiation then
18336 -- Single concurrent type declaration
18338 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
18341 -- Otherwise the pragma is associated with an illegal construct
18348 -- Extract the entity of the related object declaration or package
18349 -- instantiation. In the case of the instantiation, use the entity
18350 -- of the instance spec.
18352 if Nkind (Stmt) = N_Package_Instantiation then
18353 Stmt := Instance_Spec (Stmt);
18356 Item_Id := Defining_Entity (Stmt);
18357 Encap := Get_Pragma_Arg (Arg1);
18359 -- A pragma that applies to a Ghost entity becomes Ghost for the
18360 -- purposes of legality checks and removal of ignored Ghost code.
18362 Mark_Pragma_As_Ghost (N, Item_Id);
18364 -- Chain the pragma on the contract for further processing by
18365 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18367 Add_Contract_Item (N, Item_Id);
18369 -- A variable may act as consituent of a single concurrent type
18370 -- which in turn could be declared after the variable. Due to this
18371 -- discrepancy, the full analysis of indicator Part_Of is delayed
18372 -- until the end of the enclosing declarative region (see routine
18373 -- Analyze_Part_Of_In_Decl_Part).
18375 if Ekind (Item_Id) = E_Variable then
18378 -- Otherwise indicator Part_Of applies to a constant or a package
18382 -- Detect any discrepancies between the placement of the
18383 -- constant or package instantiation with respect to state
18384 -- space and the encapsulating state.
18388 Item_Id => Item_Id,
18390 Encap_Id => Encap_Id,
18394 pragma Assert (Present (Encap_Id));
18396 if Ekind (Item_Id) = E_Constant then
18397 Constits := Part_Of_Constituents (Encap_Id);
18399 if No (Constits) then
18400 Constits := New_Elmt_List;
18401 Set_Part_Of_Constituents (Encap_Id, Constits);
18404 Append_Elmt (Item_Id, Constits);
18405 Set_Encapsulating_State (Item_Id, Encap_Id);
18407 -- Propagate the Part_Of indicator to the visible state
18408 -- space of the package instantiation.
18412 (Pack_Id => Item_Id,
18413 State_Id => Encap_Id,
18420 ----------------------------------
18421 -- Partition_Elaboration_Policy --
18422 ----------------------------------
18424 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18426 when Pragma_Partition_Elaboration_Policy => declare
18427 subtype PEP_Range is Name_Id
18428 range First_Partition_Elaboration_Policy_Name
18429 .. Last_Partition_Elaboration_Policy_Name;
18430 PEP_Val : PEP_Range;
18435 Check_Arg_Count (1);
18436 Check_No_Identifiers;
18437 Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18438 Check_Valid_Configuration_Pragma;
18439 PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18442 when Name_Concurrent =>
18444 when Name_Sequential =>
18448 if Partition_Elaboration_Policy /= ' '
18449 and then Partition_Elaboration_Policy /= PEP
18451 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18453 ("partition elaboration policy incompatible with policy#");
18455 -- Set new policy, but always preserve System_Location since we
18456 -- like the error message with the run time name.
18459 Partition_Elaboration_Policy := PEP;
18461 if Partition_Elaboration_Policy_Sloc /= System_Location then
18462 Partition_Elaboration_Policy_Sloc := Loc;
18471 -- pragma Passive [(PASSIVE_FORM)];
18473 -- PASSIVE_FORM ::= Semaphore | No
18475 when Pragma_Passive =>
18478 if Nkind (Parent (N)) /= N_Task_Definition then
18479 Error_Pragma ("pragma% must be within task definition");
18482 if Arg_Count /= 0 then
18483 Check_Arg_Count (1);
18484 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18487 ----------------------------------
18488 -- Preelaborable_Initialization --
18489 ----------------------------------
18491 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18493 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18498 Check_Arg_Count (1);
18499 Check_No_Identifiers;
18500 Check_Arg_Is_Identifier (Arg1);
18501 Check_Arg_Is_Local_Name (Arg1);
18502 Check_First_Subtype (Arg1);
18503 Ent := Entity (Get_Pragma_Arg (Arg1));
18505 -- A pragma that applies to a Ghost entity becomes Ghost for the
18506 -- purposes of legality checks and removal of ignored Ghost code.
18508 Mark_Pragma_As_Ghost (N, Ent);
18510 -- The pragma may come from an aspect on a private declaration,
18511 -- even if the freeze point at which this is analyzed in the
18512 -- private part after the full view.
18514 if Has_Private_Declaration (Ent)
18515 and then From_Aspect_Specification (N)
18519 -- Check appropriate type argument
18521 elsif Is_Private_Type (Ent)
18522 or else Is_Protected_Type (Ent)
18523 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18525 -- AI05-0028: The pragma applies to all composite types. Note
18526 -- that we apply this binding interpretation to earlier versions
18527 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18528 -- choice since there are other compilers that do the same.
18530 or else Is_Composite_Type (Ent)
18536 ("pragma % can only be applied to private, formal derived, "
18537 & "protected, or composite type", Arg1);
18540 -- Give an error if the pragma is applied to a protected type that
18541 -- does not qualify (due to having entries, or due to components
18542 -- that do not qualify).
18544 if Is_Protected_Type (Ent)
18545 and then not Has_Preelaborable_Initialization (Ent)
18548 ("protected type & does not have preelaborable "
18549 & "initialization", Ent);
18551 -- Otherwise mark the type as definitely having preelaborable
18555 Set_Known_To_Have_Preelab_Init (Ent);
18558 if Has_Pragma_Preelab_Init (Ent)
18559 and then Warn_On_Redundant_Constructs
18561 Error_Pragma ("?r?duplicate pragma%!");
18563 Set_Has_Pragma_Preelab_Init (Ent);
18567 --------------------
18568 -- Persistent_BSS --
18569 --------------------
18571 -- pragma Persistent_BSS [(object_NAME)];
18573 when Pragma_Persistent_BSS => Persistent_BSS : declare
18580 Check_At_Most_N_Arguments (1);
18582 -- Case of application to specific object (one argument)
18584 if Arg_Count = 1 then
18585 Check_Arg_Is_Library_Level_Local_Name (Arg1);
18587 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18589 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18592 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18595 Ent := Entity (Get_Pragma_Arg (Arg1));
18596 Decl := Parent (Ent);
18598 -- A pragma that applies to a Ghost entity becomes Ghost for
18599 -- the purposes of legality checks and removal of ignored Ghost
18602 Mark_Pragma_As_Ghost (N, Ent);
18604 -- Check for duplication before inserting in list of
18605 -- representation items.
18607 Check_Duplicate_Pragma (Ent);
18609 if Rep_Item_Too_Late (Ent, N) then
18613 if Present (Expression (Decl)) then
18615 ("object for pragma% cannot have initialization", Arg1);
18618 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18620 ("object type for pragma% is not potentially persistent",
18625 Make_Linker_Section_Pragma
18626 (Ent, Sloc (N), ".persistent.bss");
18627 Insert_After (N, Prag);
18630 -- Case of use as configuration pragma with no arguments
18633 Check_Valid_Configuration_Pragma;
18634 Persistent_BSS_Mode := True;
18636 end Persistent_BSS;
18642 -- pragma Polling (ON | OFF);
18644 when Pragma_Polling =>
18646 Check_Arg_Count (1);
18647 Check_No_Identifiers;
18648 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18649 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18651 -----------------------------------
18652 -- Post/Post_Class/Postcondition --
18653 -----------------------------------
18655 -- pragma Post (Boolean_EXPRESSION);
18656 -- pragma Post_Class (Boolean_EXPRESSION);
18657 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18658 -- [,[Message =>] String_EXPRESSION]);
18660 -- Characteristics:
18662 -- * Analysis - The annotation undergoes initial checks to verify
18663 -- the legal placement and context. Secondary checks preanalyze the
18666 -- Analyze_Pre_Post_Condition_In_Decl_Part
18668 -- * Expansion - The annotation is expanded during the expansion of
18669 -- the related subprogram [body] contract as performed in:
18671 -- Expand_Subprogram_Contract
18673 -- * Template - The annotation utilizes the generic template of the
18674 -- related subprogram [body] when it is:
18676 -- aspect on subprogram declaration
18677 -- aspect on stand alone subprogram body
18678 -- pragma on stand alone subprogram body
18680 -- The annotation must prepare its own template when it is:
18682 -- pragma on subprogram declaration
18684 -- * Globals - Capture of global references must occur after full
18687 -- * Instance - The annotation is instantiated automatically when
18688 -- the related generic subprogram [body] is instantiated except for
18689 -- the "pragma on subprogram declaration" case. In that scenario
18690 -- the annotation must instantiate itself.
18693 Pragma_Post_Class |
18694 Pragma_Postcondition =>
18695 Analyze_Pre_Post_Condition;
18697 --------------------------------
18698 -- Pre/Pre_Class/Precondition --
18699 --------------------------------
18701 -- pragma Pre (Boolean_EXPRESSION);
18702 -- pragma Pre_Class (Boolean_EXPRESSION);
18703 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18704 -- [,[Message =>] String_EXPRESSION]);
18706 -- Characteristics:
18708 -- * Analysis - The annotation undergoes initial checks to verify
18709 -- the legal placement and context. Secondary checks preanalyze the
18712 -- Analyze_Pre_Post_Condition_In_Decl_Part
18714 -- * Expansion - The annotation is expanded during the expansion of
18715 -- the related subprogram [body] contract as performed in:
18717 -- Expand_Subprogram_Contract
18719 -- * Template - The annotation utilizes the generic template of the
18720 -- related subprogram [body] when it is:
18722 -- aspect on subprogram declaration
18723 -- aspect on stand alone subprogram body
18724 -- pragma on stand alone subprogram body
18726 -- The annotation must prepare its own template when it is:
18728 -- pragma on subprogram declaration
18730 -- * Globals - Capture of global references must occur after full
18733 -- * Instance - The annotation is instantiated automatically when
18734 -- the related generic subprogram [body] is instantiated except for
18735 -- the "pragma on subprogram declaration" case. In that scenario
18736 -- the annotation must instantiate itself.
18740 Pragma_Precondition =>
18741 Analyze_Pre_Post_Condition;
18747 -- pragma Predicate
18748 -- ([Entity =>] type_LOCAL_NAME,
18749 -- [Check =>] boolean_EXPRESSION);
18751 when Pragma_Predicate => Predicate : declare
18758 Check_Arg_Count (2);
18759 Check_Optional_Identifier (Arg1, Name_Entity);
18760 Check_Optional_Identifier (Arg2, Name_Check);
18762 Check_Arg_Is_Local_Name (Arg1);
18764 Type_Id := Get_Pragma_Arg (Arg1);
18765 Find_Type (Type_Id);
18766 Typ := Entity (Type_Id);
18768 if Typ = Any_Type then
18772 -- A pragma that applies to a Ghost entity becomes Ghost for the
18773 -- purposes of legality checks and removal of ignored Ghost code.
18775 Mark_Pragma_As_Ghost (N, Typ);
18777 -- The remaining processing is simply to link the pragma on to
18778 -- the rep item chain, for processing when the type is frozen.
18779 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18780 -- mark the type as having predicates.
18781 -- If the current policy is Ignore mark the subtype accordingly.
18782 -- In the case of predicates we consider them enabled unless an
18783 -- Ignore is specified, to preserve existing warnings.
18785 Set_Has_Predicates (Typ);
18786 Set_Predicates_Ignored (Typ,
18787 Present (Check_Policy_List)
18789 Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore);
18790 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18793 -----------------------
18794 -- Predicate_Failure --
18795 -----------------------
18797 -- pragma Predicate_Failure
18798 -- ([Entity =>] type_LOCAL_NAME,
18799 -- [Message =>] string_EXPRESSION);
18801 when Pragma_Predicate_Failure => Predicate_Failure : declare
18808 Check_Arg_Count (2);
18809 Check_Optional_Identifier (Arg1, Name_Entity);
18810 Check_Optional_Identifier (Arg2, Name_Message);
18812 Check_Arg_Is_Local_Name (Arg1);
18814 Type_Id := Get_Pragma_Arg (Arg1);
18815 Find_Type (Type_Id);
18816 Typ := Entity (Type_Id);
18818 if Typ = Any_Type then
18822 -- A pragma that applies to a Ghost entity becomes Ghost for the
18823 -- purposes of legality checks and removal of ignored Ghost code.
18825 Mark_Pragma_As_Ghost (N, Typ);
18827 -- The remaining processing is simply to link the pragma on to
18828 -- the rep item chain, for processing when the type is frozen.
18829 -- This is accomplished by a call to Rep_Item_Too_Late.
18831 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
18832 end Predicate_Failure;
18838 -- pragma Preelaborate [(library_unit_NAME)];
18840 -- Set the flag Is_Preelaborated of program unit name entity
18842 when Pragma_Preelaborate => Preelaborate : declare
18843 Pa : constant Node_Id := Parent (N);
18844 Pk : constant Node_Kind := Nkind (Pa);
18848 Check_Ada_83_Warning;
18849 Check_Valid_Library_Unit_Pragma;
18851 if Nkind (N) = N_Null_Statement then
18855 Ent := Find_Lib_Unit_Name;
18857 -- A pragma that applies to a Ghost entity becomes Ghost for the
18858 -- purposes of legality checks and removal of ignored Ghost code.
18860 Mark_Pragma_As_Ghost (N, Ent);
18861 Check_Duplicate_Pragma (Ent);
18863 -- This filters out pragmas inside generic parents that show up
18864 -- inside instantiations. Pragmas that come from aspects in the
18865 -- unit are not ignored.
18867 if Present (Ent) then
18868 if Pk = N_Package_Specification
18869 and then Present (Generic_Parent (Pa))
18870 and then not From_Aspect_Specification (N)
18875 if not Debug_Flag_U then
18876 Set_Is_Preelaborated (Ent);
18877 Set_Suppress_Elaboration_Warnings (Ent);
18883 -------------------------------
18884 -- Prefix_Exception_Messages --
18885 -------------------------------
18887 -- pragma Prefix_Exception_Messages;
18889 when Pragma_Prefix_Exception_Messages =>
18891 Check_Valid_Configuration_Pragma;
18892 Check_Arg_Count (0);
18893 Prefix_Exception_Messages := True;
18899 -- pragma Priority (EXPRESSION);
18901 when Pragma_Priority => Priority : declare
18902 P : constant Node_Id := Parent (N);
18907 Check_No_Identifiers;
18908 Check_Arg_Count (1);
18912 if Nkind (P) = N_Subprogram_Body then
18913 Check_In_Main_Program;
18915 Ent := Defining_Unit_Name (Specification (P));
18917 if Nkind (Ent) = N_Defining_Program_Unit_Name then
18918 Ent := Defining_Identifier (Ent);
18921 Arg := Get_Pragma_Arg (Arg1);
18922 Analyze_And_Resolve (Arg, Standard_Integer);
18926 if not Is_OK_Static_Expression (Arg) then
18927 Flag_Non_Static_Expr
18928 ("main subprogram priority is not static!", Arg);
18931 -- If constraint error, then we already signalled an error
18933 elsif Raises_Constraint_Error (Arg) then
18936 -- Otherwise check in range except if Relaxed_RM_Semantics
18937 -- where we ignore the value if out of range.
18940 if not Relaxed_RM_Semantics
18941 and then not Is_In_Range (Arg, RTE (RE_Priority))
18944 ("main subprogram priority is out of range", Arg1);
18947 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
18951 -- Load an arbitrary entity from System.Tasking.Stages or
18952 -- System.Tasking.Restricted.Stages (depending on the
18953 -- supported profile) to make sure that one of these packages
18954 -- is implicitly with'ed, since we need to have the tasking
18955 -- run time active for the pragma Priority to have any effect.
18956 -- Previously we with'ed the package System.Tasking, but this
18957 -- package does not trigger the required initialization of the
18958 -- run-time library.
18961 Discard : Entity_Id;
18962 pragma Warnings (Off, Discard);
18964 if Restricted_Profile then
18965 Discard := RTE (RE_Activate_Restricted_Tasks);
18967 Discard := RTE (RE_Activate_Tasks);
18971 -- Task or Protected, must be of type Integer
18973 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
18974 Arg := Get_Pragma_Arg (Arg1);
18975 Ent := Defining_Identifier (Parent (P));
18977 -- The expression must be analyzed in the special manner
18978 -- described in "Handling of Default and Per-Object
18979 -- Expressions" in sem.ads.
18981 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
18983 if not Is_OK_Static_Expression (Arg) then
18984 Check_Restriction (Static_Priorities, Arg);
18987 -- Anything else is incorrect
18993 -- Check duplicate pragma before we chain the pragma in the Rep
18994 -- Item chain of Ent.
18996 Check_Duplicate_Pragma (Ent);
18997 Record_Rep_Item (Ent, N);
19000 -----------------------------------
19001 -- Priority_Specific_Dispatching --
19002 -----------------------------------
19004 -- pragma Priority_Specific_Dispatching (
19005 -- policy_IDENTIFIER,
19006 -- first_priority_EXPRESSION,
19007 -- last_priority_EXPRESSION);
19009 when Pragma_Priority_Specific_Dispatching =>
19010 Priority_Specific_Dispatching : declare
19011 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19012 -- This is the entity System.Any_Priority;
19015 Lower_Bound : Node_Id;
19016 Upper_Bound : Node_Id;
19022 Check_Arg_Count (3);
19023 Check_No_Identifiers;
19024 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19025 Check_Valid_Configuration_Pragma;
19026 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19027 DP := Fold_Upper (Name_Buffer (1));
19029 Lower_Bound := Get_Pragma_Arg (Arg2);
19030 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19031 Lower_Val := Expr_Value (Lower_Bound);
19033 Upper_Bound := Get_Pragma_Arg (Arg3);
19034 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19035 Upper_Val := Expr_Value (Upper_Bound);
19037 -- It is not allowed to use Task_Dispatching_Policy and
19038 -- Priority_Specific_Dispatching in the same partition.
19040 if Task_Dispatching_Policy /= ' ' then
19041 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19043 ("pragma% incompatible with Task_Dispatching_Policy#");
19045 -- Check lower bound in range
19047 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19049 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19052 ("first_priority is out of range", Arg2);
19054 -- Check upper bound in range
19056 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19058 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19061 ("last_priority is out of range", Arg3);
19063 -- Check that the priority range is valid
19065 elsif Lower_Val > Upper_Val then
19067 ("last_priority_expression must be greater than or equal to "
19068 & "first_priority_expression");
19070 -- Store the new policy, but always preserve System_Location since
19071 -- we like the error message with the run-time name.
19074 -- Check overlapping in the priority ranges specified in other
19075 -- Priority_Specific_Dispatching pragmas within the same
19076 -- partition. We can only check those we know about.
19079 Specific_Dispatching.First .. Specific_Dispatching.Last
19081 if Specific_Dispatching.Table (J).First_Priority in
19082 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19083 or else Specific_Dispatching.Table (J).Last_Priority in
19084 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19087 Specific_Dispatching.Table (J).Pragma_Loc;
19089 ("priority range overlaps with "
19090 & "Priority_Specific_Dispatching#");
19094 -- The use of Priority_Specific_Dispatching is incompatible
19095 -- with Task_Dispatching_Policy.
19097 if Task_Dispatching_Policy /= ' ' then
19098 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19100 ("Priority_Specific_Dispatching incompatible "
19101 & "with Task_Dispatching_Policy#");
19104 -- The use of Priority_Specific_Dispatching forces ceiling
19107 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19108 Error_Msg_Sloc := Locking_Policy_Sloc;
19110 ("Priority_Specific_Dispatching incompatible "
19111 & "with Locking_Policy#");
19113 -- Set the Ceiling_Locking policy, but preserve System_Location
19114 -- since we like the error message with the run time name.
19117 Locking_Policy := 'C';
19119 if Locking_Policy_Sloc /= System_Location then
19120 Locking_Policy_Sloc := Loc;
19124 -- Add entry in the table
19126 Specific_Dispatching.Append
19127 ((Dispatching_Policy => DP,
19128 First_Priority => UI_To_Int (Lower_Val),
19129 Last_Priority => UI_To_Int (Upper_Val),
19130 Pragma_Loc => Loc));
19132 end Priority_Specific_Dispatching;
19138 -- pragma Profile (profile_IDENTIFIER);
19140 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19142 when Pragma_Profile =>
19144 Check_Arg_Count (1);
19145 Check_Valid_Configuration_Pragma;
19146 Check_No_Identifiers;
19149 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19152 if Chars (Argx) = Name_Ravenscar then
19153 Set_Ravenscar_Profile (Ravenscar, N);
19155 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19156 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19158 elsif Chars (Argx) = Name_Restricted then
19159 Set_Profile_Restrictions
19161 N, Warn => Treat_Restrictions_As_Warnings);
19163 elsif Chars (Argx) = Name_Rational then
19164 Set_Rational_Profile;
19166 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19167 Set_Profile_Restrictions
19168 (No_Implementation_Extensions,
19169 N, Warn => Treat_Restrictions_As_Warnings);
19172 Error_Pragma_Arg ("& is not a valid profile", Argx);
19176 ----------------------
19177 -- Profile_Warnings --
19178 ----------------------
19180 -- pragma Profile_Warnings (profile_IDENTIFIER);
19182 -- profile_IDENTIFIER => Restricted | Ravenscar
19184 when Pragma_Profile_Warnings =>
19186 Check_Arg_Count (1);
19187 Check_Valid_Configuration_Pragma;
19188 Check_No_Identifiers;
19191 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19194 if Chars (Argx) = Name_Ravenscar then
19195 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
19197 elsif Chars (Argx) = Name_Restricted then
19198 Set_Profile_Restrictions (Restricted, N, Warn => True);
19200 elsif Chars (Argx) = Name_No_Implementation_Extensions then
19201 Set_Profile_Restrictions
19202 (No_Implementation_Extensions, N, Warn => True);
19205 Error_Pragma_Arg ("& is not a valid profile", Argx);
19209 --------------------------
19210 -- Propagate_Exceptions --
19211 --------------------------
19213 -- pragma Propagate_Exceptions;
19215 -- Note: this pragma is obsolete and has no effect
19217 when Pragma_Propagate_Exceptions =>
19219 Check_Arg_Count (0);
19221 if Warn_On_Obsolescent_Feature then
19223 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19224 "and has no effect?j?", N);
19227 -----------------------------
19228 -- Provide_Shift_Operators --
19229 -----------------------------
19231 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19233 when Pragma_Provide_Shift_Operators =>
19234 Provide_Shift_Operators : declare
19237 procedure Declare_Shift_Operator (Nam : Name_Id);
19238 -- Insert declaration and pragma Instrinsic for named shift op
19240 ----------------------------
19241 -- Declare_Shift_Operator --
19242 ----------------------------
19244 procedure Declare_Shift_Operator (Nam : Name_Id) is
19250 Make_Subprogram_Declaration (Loc,
19251 Make_Function_Specification (Loc,
19252 Defining_Unit_Name =>
19253 Make_Defining_Identifier (Loc, Chars => Nam),
19255 Result_Definition =>
19256 Make_Identifier (Loc, Chars => Chars (Ent)),
19258 Parameter_Specifications => New_List (
19259 Make_Parameter_Specification (Loc,
19260 Defining_Identifier =>
19261 Make_Defining_Identifier (Loc, Name_Value),
19263 Make_Identifier (Loc, Chars => Chars (Ent))),
19265 Make_Parameter_Specification (Loc,
19266 Defining_Identifier =>
19267 Make_Defining_Identifier (Loc, Name_Amount),
19269 New_Occurrence_Of (Standard_Natural, Loc)))));
19273 Pragma_Identifier => Make_Identifier (Loc, Name_Import),
19274 Pragma_Argument_Associations => New_List (
19275 Make_Pragma_Argument_Association (Loc,
19276 Expression => Make_Identifier (Loc, Name_Intrinsic)),
19277 Make_Pragma_Argument_Association (Loc,
19278 Expression => Make_Identifier (Loc, Nam))));
19280 Insert_After (N, Import);
19281 Insert_After (N, Func);
19282 end Declare_Shift_Operator;
19284 -- Start of processing for Provide_Shift_Operators
19288 Check_Arg_Count (1);
19289 Check_Arg_Is_Local_Name (Arg1);
19291 Arg1 := Get_Pragma_Arg (Arg1);
19293 -- We must have an entity name
19295 if not Is_Entity_Name (Arg1) then
19297 ("pragma % must apply to integer first subtype", Arg1);
19300 -- If no Entity, means there was a prior error so ignore
19302 if Present (Entity (Arg1)) then
19303 Ent := Entity (Arg1);
19305 -- Apply error checks
19307 if not Is_First_Subtype (Ent) then
19309 ("cannot apply pragma %",
19310 "\& is not a first subtype",
19313 elsif not Is_Integer_Type (Ent) then
19315 ("cannot apply pragma %",
19316 "\& is not an integer type",
19319 elsif Has_Shift_Operator (Ent) then
19321 ("cannot apply pragma %",
19322 "\& already has declared shift operators",
19325 elsif Is_Frozen (Ent) then
19327 ("pragma % appears too late",
19328 "\& is already frozen",
19332 -- Now declare the operators. We do this during analysis rather
19333 -- than expansion, since we want the operators available if we
19334 -- are operating in -gnatc or ASIS mode.
19336 Declare_Shift_Operator (Name_Rotate_Left);
19337 Declare_Shift_Operator (Name_Rotate_Right);
19338 Declare_Shift_Operator (Name_Shift_Left);
19339 Declare_Shift_Operator (Name_Shift_Right);
19340 Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
19342 end Provide_Shift_Operators;
19348 -- pragma Psect_Object (
19349 -- [Internal =>] LOCAL_NAME,
19350 -- [, [External =>] EXTERNAL_SYMBOL]
19351 -- [, [Size =>] EXTERNAL_SYMBOL]);
19353 when Pragma_Psect_Object | Pragma_Common_Object =>
19354 Psect_Object : declare
19355 Args : Args_List (1 .. 3);
19356 Names : constant Name_List (1 .. 3) := (
19361 Internal : Node_Id renames Args (1);
19362 External : Node_Id renames Args (2);
19363 Size : Node_Id renames Args (3);
19365 Def_Id : Entity_Id;
19367 procedure Check_Arg (Arg : Node_Id);
19368 -- Checks that argument is either a string literal or an
19369 -- identifier, and posts error message if not.
19375 procedure Check_Arg (Arg : Node_Id) is
19377 if not Nkind_In (Original_Node (Arg),
19382 ("inappropriate argument for pragma %", Arg);
19386 -- Start of processing for Common_Object/Psect_Object
19390 Gather_Associations (Names, Args);
19391 Process_Extended_Import_Export_Internal_Arg (Internal);
19393 Def_Id := Entity (Internal);
19395 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19397 ("pragma% must designate an object", Internal);
19400 Check_Arg (Internal);
19402 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19404 ("cannot use pragma% for imported/exported object",
19408 if Is_Concurrent_Type (Etype (Internal)) then
19410 ("cannot specify pragma % for task/protected object",
19414 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19416 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19418 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19421 if Ekind (Def_Id) = E_Constant then
19423 ("cannot specify pragma % for a constant", Internal);
19426 if Is_Record_Type (Etype (Internal)) then
19432 Ent := First_Entity (Etype (Internal));
19433 while Present (Ent) loop
19434 Decl := Declaration_Node (Ent);
19436 if Ekind (Ent) = E_Component
19437 and then Nkind (Decl) = N_Component_Declaration
19438 and then Present (Expression (Decl))
19439 and then Warn_On_Export_Import
19442 ("?x?object for pragma % has defaults", Internal);
19452 if Present (Size) then
19456 if Present (External) then
19457 Check_Arg_Is_External_Name (External);
19460 -- If all error tests pass, link pragma on to the rep item chain
19462 Record_Rep_Item (Def_Id, N);
19469 -- pragma Pure [(library_unit_NAME)];
19471 when Pragma_Pure => Pure : declare
19475 Check_Ada_83_Warning;
19477 -- If the pragma comes from a subprogram instantiation, nothing to
19478 -- check, this can happen at any level of nesting.
19480 if Is_Wrapper_Package (Current_Scope) then
19483 Check_Valid_Library_Unit_Pragma;
19486 if Nkind (N) = N_Null_Statement then
19490 Ent := Find_Lib_Unit_Name;
19492 -- A pragma that applies to a Ghost entity becomes Ghost for the
19493 -- purposes of legality checks and removal of ignored Ghost code.
19495 Mark_Pragma_As_Ghost (N, Ent);
19497 if not Debug_Flag_U then
19499 Set_Has_Pragma_Pure (Ent);
19500 Set_Suppress_Elaboration_Warnings (Ent);
19504 -------------------
19505 -- Pure_Function --
19506 -------------------
19508 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19510 when Pragma_Pure_Function => Pure_Function : declare
19511 Def_Id : Entity_Id;
19514 Effective : Boolean := False;
19518 Check_Arg_Count (1);
19519 Check_Optional_Identifier (Arg1, Name_Entity);
19520 Check_Arg_Is_Local_Name (Arg1);
19521 E_Id := Get_Pragma_Arg (Arg1);
19523 if Error_Posted (E_Id) then
19527 -- Loop through homonyms (overloadings) of referenced entity
19529 E := Entity (E_Id);
19531 -- A pragma that applies to a Ghost entity becomes Ghost for the
19532 -- purposes of legality checks and removal of ignored Ghost code.
19534 Mark_Pragma_As_Ghost (N, E);
19536 if Present (E) then
19538 Def_Id := Get_Base_Subprogram (E);
19540 if not Ekind_In (Def_Id, E_Function,
19541 E_Generic_Function,
19545 ("pragma% requires a function name", Arg1);
19548 Set_Is_Pure (Def_Id);
19550 if not Has_Pragma_Pure_Function (Def_Id) then
19551 Set_Has_Pragma_Pure_Function (Def_Id);
19555 exit when From_Aspect_Specification (N);
19557 exit when No (E) or else Scope (E) /= Current_Scope;
19561 and then Warn_On_Redundant_Constructs
19564 ("pragma Pure_Function on& is redundant?r?",
19570 --------------------
19571 -- Queuing_Policy --
19572 --------------------
19574 -- pragma Queuing_Policy (policy_IDENTIFIER);
19576 when Pragma_Queuing_Policy => declare
19580 Check_Ada_83_Warning;
19581 Check_Arg_Count (1);
19582 Check_No_Identifiers;
19583 Check_Arg_Is_Queuing_Policy (Arg1);
19584 Check_Valid_Configuration_Pragma;
19585 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19586 QP := Fold_Upper (Name_Buffer (1));
19588 if Queuing_Policy /= ' '
19589 and then Queuing_Policy /= QP
19591 Error_Msg_Sloc := Queuing_Policy_Sloc;
19592 Error_Pragma ("queuing policy incompatible with policy#");
19594 -- Set new policy, but always preserve System_Location since we
19595 -- like the error message with the run time name.
19598 Queuing_Policy := QP;
19600 if Queuing_Policy_Sloc /= System_Location then
19601 Queuing_Policy_Sloc := Loc;
19610 -- pragma Rational, for compatibility with foreign compiler
19612 when Pragma_Rational =>
19613 Set_Rational_Profile;
19615 ---------------------
19616 -- Refined_Depends --
19617 ---------------------
19619 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19621 -- DEPENDENCY_RELATION ::=
19623 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19625 -- DEPENDENCY_CLAUSE ::=
19626 -- OUTPUT_LIST =>[+] INPUT_LIST
19627 -- | NULL_DEPENDENCY_CLAUSE
19629 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19631 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19633 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19635 -- OUTPUT ::= NAME | FUNCTION_RESULT
19638 -- where FUNCTION_RESULT is a function Result attribute_reference
19640 -- Characteristics:
19642 -- * Analysis - The annotation undergoes initial checks to verify
19643 -- the legal placement and context. Secondary checks fully analyze
19644 -- the dependency clauses/global list in:
19646 -- Analyze_Refined_Depends_In_Decl_Part
19648 -- * Expansion - None.
19650 -- * Template - The annotation utilizes the generic template of the
19651 -- related subprogram body.
19653 -- * Globals - Capture of global references must occur after full
19656 -- * Instance - The annotation is instantiated automatically when
19657 -- the related generic subprogram body is instantiated.
19659 when Pragma_Refined_Depends => Refined_Depends : declare
19660 Body_Id : Entity_Id;
19662 Spec_Id : Entity_Id;
19665 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19669 -- Chain the pragma on the contract for further processing by
19670 -- Analyze_Refined_Depends_In_Decl_Part.
19672 Add_Contract_Item (N, Body_Id);
19674 -- The legality checks of pragmas Refined_Depends and
19675 -- Refined_Global are affected by the SPARK mode in effect and
19676 -- the volatility of the context. In addition these two pragmas
19677 -- are subject to an inherent order:
19679 -- 1) Refined_Global
19680 -- 2) Refined_Depends
19682 -- Analyze all these pragmas in the order outlined above
19684 Analyze_If_Present (Pragma_SPARK_Mode);
19685 Analyze_If_Present (Pragma_Volatile_Function);
19686 Analyze_If_Present (Pragma_Refined_Global);
19687 Analyze_Refined_Depends_In_Decl_Part (N);
19689 end Refined_Depends;
19691 --------------------
19692 -- Refined_Global --
19693 --------------------
19695 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19697 -- GLOBAL_SPECIFICATION ::=
19700 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
19702 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19704 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19705 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19706 -- GLOBAL_ITEM ::= NAME
19708 -- Characteristics:
19710 -- * Analysis - The annotation undergoes initial checks to verify
19711 -- the legal placement and context. Secondary checks fully analyze
19712 -- the dependency clauses/global list in:
19714 -- Analyze_Refined_Global_In_Decl_Part
19716 -- * Expansion - None.
19718 -- * Template - The annotation utilizes the generic template of the
19719 -- related subprogram body.
19721 -- * Globals - Capture of global references must occur after full
19724 -- * Instance - The annotation is instantiated automatically when
19725 -- the related generic subprogram body is instantiated.
19727 when Pragma_Refined_Global => Refined_Global : declare
19728 Body_Id : Entity_Id;
19730 Spec_Id : Entity_Id;
19733 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19737 -- Chain the pragma on the contract for further processing by
19738 -- Analyze_Refined_Global_In_Decl_Part.
19740 Add_Contract_Item (N, Body_Id);
19742 -- The legality checks of pragmas Refined_Depends and
19743 -- Refined_Global are affected by the SPARK mode in effect and
19744 -- the volatility of the context. In addition these two pragmas
19745 -- are subject to an inherent order:
19747 -- 1) Refined_Global
19748 -- 2) Refined_Depends
19750 -- Analyze all these pragmas in the order outlined above
19752 Analyze_If_Present (Pragma_SPARK_Mode);
19753 Analyze_If_Present (Pragma_Volatile_Function);
19754 Analyze_Refined_Global_In_Decl_Part (N);
19755 Analyze_If_Present (Pragma_Refined_Depends);
19757 end Refined_Global;
19763 -- pragma Refined_Post (boolean_EXPRESSION);
19765 -- Characteristics:
19767 -- * Analysis - The annotation is fully analyzed immediately upon
19768 -- elaboration as it cannot forward reference entities.
19770 -- * Expansion - The annotation is expanded during the expansion of
19771 -- the related subprogram body contract as performed in:
19773 -- Expand_Subprogram_Contract
19775 -- * Template - The annotation utilizes the generic template of the
19776 -- related subprogram body.
19778 -- * Globals - Capture of global references must occur after full
19781 -- * Instance - The annotation is instantiated automatically when
19782 -- the related generic subprogram body is instantiated.
19784 when Pragma_Refined_Post => Refined_Post : declare
19785 Body_Id : Entity_Id;
19787 Spec_Id : Entity_Id;
19790 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
19792 -- Fully analyze the pragma when it appears inside a subprogram
19793 -- body because it cannot benefit from forward references.
19797 -- Chain the pragma on the contract for completeness
19799 Add_Contract_Item (N, Body_Id);
19801 -- The legality checks of pragma Refined_Post are affected by
19802 -- the SPARK mode in effect and the volatility of the context.
19803 -- Analyze all pragmas in a specific order.
19805 Analyze_If_Present (Pragma_SPARK_Mode);
19806 Analyze_If_Present (Pragma_Volatile_Function);
19807 Analyze_Pre_Post_Condition_In_Decl_Part (N);
19809 -- Currently it is not possible to inline pre/postconditions on
19810 -- a subprogram subject to pragma Inline_Always.
19812 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
19816 -------------------
19817 -- Refined_State --
19818 -------------------
19820 -- pragma Refined_State (REFINEMENT_LIST);
19822 -- REFINEMENT_LIST ::=
19823 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19825 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19827 -- CONSTITUENT_LIST ::=
19830 -- | (CONSTITUENT {, CONSTITUENT})
19832 -- CONSTITUENT ::= object_NAME | state_NAME
19834 -- Characteristics:
19836 -- * Analysis - The annotation undergoes initial checks to verify
19837 -- the legal placement and context. Secondary checks preanalyze the
19838 -- refinement clauses in:
19840 -- Analyze_Refined_State_In_Decl_Part
19842 -- * Expansion - None.
19844 -- * Template - The annotation utilizes the template of the related
19847 -- * Globals - Capture of global references must occur after full
19850 -- * Instance - The annotation is instantiated automatically when
19851 -- the related generic package body is instantiated.
19853 when Pragma_Refined_State => Refined_State : declare
19854 Pack_Decl : Node_Id;
19855 Spec_Id : Entity_Id;
19859 Check_No_Identifiers;
19860 Check_Arg_Count (1);
19862 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
19864 -- Ensure the proper placement of the pragma. Refined states must
19865 -- be associated with a package body.
19867 if Nkind (Pack_Decl) = N_Package_Body then
19870 -- Otherwise the pragma is associated with an illegal construct
19877 Spec_Id := Corresponding_Spec (Pack_Decl);
19879 -- Chain the pragma on the contract for further processing by
19880 -- Analyze_Refined_State_In_Decl_Part.
19882 Add_Contract_Item (N, Defining_Entity (Pack_Decl));
19884 -- The legality checks of pragma Refined_State are affected by the
19885 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19887 Analyze_If_Present (Pragma_SPARK_Mode);
19889 -- A pragma that applies to a Ghost entity becomes Ghost for the
19890 -- purposes of legality checks and removal of ignored Ghost code.
19892 Mark_Pragma_As_Ghost (N, Spec_Id);
19894 -- State refinement is allowed only when the corresponding package
19895 -- declaration has non-null pragma Abstract_State. Refinement not
19896 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19898 if SPARK_Mode /= Off
19900 (No (Abstract_States (Spec_Id))
19901 or else Has_Null_Abstract_State (Spec_Id))
19904 ("useless refinement, package & does not define abstract "
19905 & "states", N, Spec_Id);
19910 -----------------------
19911 -- Relative_Deadline --
19912 -----------------------
19914 -- pragma Relative_Deadline (time_span_EXPRESSION);
19916 when Pragma_Relative_Deadline => Relative_Deadline : declare
19917 P : constant Node_Id := Parent (N);
19922 Check_No_Identifiers;
19923 Check_Arg_Count (1);
19925 Arg := Get_Pragma_Arg (Arg1);
19927 -- The expression must be analyzed in the special manner described
19928 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19930 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
19934 if Nkind (P) = N_Subprogram_Body then
19935 Check_In_Main_Program;
19937 -- Only Task and subprogram cases allowed
19939 elsif Nkind (P) /= N_Task_Definition then
19943 -- Check duplicate pragma before we set the corresponding flag
19945 if Has_Relative_Deadline_Pragma (P) then
19946 Error_Pragma ("duplicate pragma% not allowed");
19949 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19950 -- Relative_Deadline pragma node cannot be inserted in the Rep
19951 -- Item chain of Ent since it is rewritten by the expander as a
19952 -- procedure call statement that will break the chain.
19954 Set_Has_Relative_Deadline_Pragma (P);
19955 end Relative_Deadline;
19957 ------------------------
19958 -- Remote_Access_Type --
19959 ------------------------
19961 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19963 when Pragma_Remote_Access_Type => Remote_Access_Type : declare
19968 Check_Arg_Count (1);
19969 Check_Optional_Identifier (Arg1, Name_Entity);
19970 Check_Arg_Is_Local_Name (Arg1);
19972 E := Entity (Get_Pragma_Arg (Arg1));
19974 -- A pragma that applies to a Ghost entity becomes Ghost for the
19975 -- purposes of legality checks and removal of ignored Ghost code.
19977 Mark_Pragma_As_Ghost (N, E);
19979 if Nkind (Parent (E)) = N_Formal_Type_Declaration
19980 and then Ekind (E) = E_General_Access_Type
19981 and then Is_Class_Wide_Type (Directly_Designated_Type (E))
19982 and then Scope (Root_Type (Directly_Designated_Type (E)))
19984 and then Is_Valid_Remote_Object_Type
19985 (Root_Type (Directly_Designated_Type (E)))
19987 Set_Is_Remote_Types (E);
19991 ("pragma% applies only to formal access to classwide types",
19994 end Remote_Access_Type;
19996 ---------------------------
19997 -- Remote_Call_Interface --
19998 ---------------------------
20000 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20002 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20003 Cunit_Node : Node_Id;
20004 Cunit_Ent : Entity_Id;
20008 Check_Ada_83_Warning;
20009 Check_Valid_Library_Unit_Pragma;
20011 if Nkind (N) = N_Null_Statement then
20015 Cunit_Node := Cunit (Current_Sem_Unit);
20016 K := Nkind (Unit (Cunit_Node));
20017 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20019 -- A pragma that applies to a Ghost entity becomes Ghost for the
20020 -- purposes of legality checks and removal of ignored Ghost code.
20022 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20024 if K = N_Package_Declaration
20025 or else K = N_Generic_Package_Declaration
20026 or else K = N_Subprogram_Declaration
20027 or else K = N_Generic_Subprogram_Declaration
20028 or else (K = N_Subprogram_Body
20029 and then Acts_As_Spec (Unit (Cunit_Node)))
20034 "pragma% must apply to package or subprogram declaration");
20037 Set_Is_Remote_Call_Interface (Cunit_Ent);
20038 end Remote_Call_Interface;
20044 -- pragma Remote_Types [(library_unit_NAME)];
20046 when Pragma_Remote_Types => Remote_Types : declare
20047 Cunit_Node : Node_Id;
20048 Cunit_Ent : Entity_Id;
20051 Check_Ada_83_Warning;
20052 Check_Valid_Library_Unit_Pragma;
20054 if Nkind (N) = N_Null_Statement then
20058 Cunit_Node := Cunit (Current_Sem_Unit);
20059 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20061 -- A pragma that applies to a Ghost entity becomes Ghost for the
20062 -- purposes of legality checks and removal of ignored Ghost code.
20064 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20066 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20067 N_Generic_Package_Declaration)
20070 ("pragma% can only apply to a package declaration");
20073 Set_Is_Remote_Types (Cunit_Ent);
20080 -- pragma Ravenscar;
20082 when Pragma_Ravenscar =>
20084 Check_Arg_Count (0);
20085 Check_Valid_Configuration_Pragma;
20086 Set_Ravenscar_Profile (Ravenscar, N);
20088 if Warn_On_Obsolescent_Feature then
20090 ("pragma Ravenscar is an obsolescent feature?j?", N);
20092 ("|use pragma Profile (Ravenscar) instead?j?", N);
20095 -------------------------
20096 -- Restricted_Run_Time --
20097 -------------------------
20099 -- pragma Restricted_Run_Time;
20101 when Pragma_Restricted_Run_Time =>
20103 Check_Arg_Count (0);
20104 Check_Valid_Configuration_Pragma;
20105 Set_Profile_Restrictions
20106 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20108 if Warn_On_Obsolescent_Feature then
20110 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20113 ("|use pragma Profile (Restricted) instead?j?", N);
20120 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20123 -- restriction_IDENTIFIER
20124 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20126 when Pragma_Restrictions =>
20127 Process_Restrictions_Or_Restriction_Warnings
20128 (Warn => Treat_Restrictions_As_Warnings);
20130 --------------------------
20131 -- Restriction_Warnings --
20132 --------------------------
20134 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20137 -- restriction_IDENTIFIER
20138 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20140 when Pragma_Restriction_Warnings =>
20142 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20148 -- pragma Reviewable;
20150 when Pragma_Reviewable =>
20151 Check_Ada_83_Warning;
20152 Check_Arg_Count (0);
20154 -- Call dummy debugging function rv. This is done to assist front
20155 -- end debugging. By placing a Reviewable pragma in the source
20156 -- program, a breakpoint on rv catches this place in the source,
20157 -- allowing convenient stepping to the point of interest.
20161 --------------------------
20162 -- Short_Circuit_And_Or --
20163 --------------------------
20165 -- pragma Short_Circuit_And_Or;
20167 when Pragma_Short_Circuit_And_Or =>
20169 Check_Arg_Count (0);
20170 Check_Valid_Configuration_Pragma;
20171 Short_Circuit_And_Or := True;
20173 -------------------
20174 -- Share_Generic --
20175 -------------------
20177 -- pragma Share_Generic (GNAME {, GNAME});
20179 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20181 when Pragma_Share_Generic =>
20183 Process_Generic_List;
20189 -- pragma Shared (LOCAL_NAME);
20191 when Pragma_Shared =>
20193 Process_Atomic_Independent_Shared_Volatile;
20195 --------------------
20196 -- Shared_Passive --
20197 --------------------
20199 -- pragma Shared_Passive [(library_unit_NAME)];
20201 -- Set the flag Is_Shared_Passive of program unit name entity
20203 when Pragma_Shared_Passive => Shared_Passive : declare
20204 Cunit_Node : Node_Id;
20205 Cunit_Ent : Entity_Id;
20208 Check_Ada_83_Warning;
20209 Check_Valid_Library_Unit_Pragma;
20211 if Nkind (N) = N_Null_Statement then
20215 Cunit_Node := Cunit (Current_Sem_Unit);
20216 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
20218 -- A pragma that applies to a Ghost entity becomes Ghost for the
20219 -- purposes of legality checks and removal of ignored Ghost code.
20221 Mark_Pragma_As_Ghost (N, Cunit_Ent);
20223 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20224 N_Generic_Package_Declaration)
20227 ("pragma% can only apply to a package declaration");
20230 Set_Is_Shared_Passive (Cunit_Ent);
20231 end Shared_Passive;
20233 -----------------------
20234 -- Short_Descriptors --
20235 -----------------------
20237 -- pragma Short_Descriptors;
20239 -- Recognize and validate, but otherwise ignore
20241 when Pragma_Short_Descriptors =>
20243 Check_Arg_Count (0);
20244 Check_Valid_Configuration_Pragma;
20246 ------------------------------
20247 -- Simple_Storage_Pool_Type --
20248 ------------------------------
20250 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20252 when Pragma_Simple_Storage_Pool_Type =>
20253 Simple_Storage_Pool_Type : declare
20259 Check_Arg_Count (1);
20260 Check_Arg_Is_Library_Level_Local_Name (Arg1);
20262 Type_Id := Get_Pragma_Arg (Arg1);
20263 Find_Type (Type_Id);
20264 Typ := Entity (Type_Id);
20266 if Typ = Any_Type then
20270 -- A pragma that applies to a Ghost entity becomes Ghost for the
20271 -- purposes of legality checks and removal of ignored Ghost code.
20273 Mark_Pragma_As_Ghost (N, Typ);
20275 -- We require the pragma to apply to a type declared in a package
20276 -- declaration, but not (immediately) within a package body.
20278 if Ekind (Current_Scope) /= E_Package
20279 or else In_Package_Body (Current_Scope)
20282 ("pragma% can only apply to type declared immediately "
20283 & "within a package declaration");
20286 -- A simple storage pool type must be an immutably limited record
20287 -- or private type. If the pragma is given for a private type,
20288 -- the full type is similarly restricted (which is checked later
20289 -- in Freeze_Entity).
20291 if Is_Record_Type (Typ)
20292 and then not Is_Limited_View (Typ)
20295 ("pragma% can only apply to explicitly limited record type");
20297 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
20299 ("pragma% can only apply to a private type that is limited");
20301 elsif not Is_Record_Type (Typ)
20302 and then not Is_Private_Type (Typ)
20305 ("pragma% can only apply to limited record or private type");
20308 Record_Rep_Item (Typ, N);
20309 end Simple_Storage_Pool_Type;
20311 ----------------------
20312 -- Source_File_Name --
20313 ----------------------
20315 -- There are five forms for this pragma:
20317 -- pragma Source_File_Name (
20318 -- [UNIT_NAME =>] unit_NAME,
20319 -- BODY_FILE_NAME => STRING_LITERAL
20320 -- [, [INDEX =>] INTEGER_LITERAL]);
20322 -- pragma Source_File_Name (
20323 -- [UNIT_NAME =>] unit_NAME,
20324 -- SPEC_FILE_NAME => STRING_LITERAL
20325 -- [, [INDEX =>] INTEGER_LITERAL]);
20327 -- pragma Source_File_Name (
20328 -- BODY_FILE_NAME => STRING_LITERAL
20329 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20330 -- [, CASING => CASING_SPEC]);
20332 -- pragma Source_File_Name (
20333 -- SPEC_FILE_NAME => STRING_LITERAL
20334 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20335 -- [, CASING => CASING_SPEC]);
20337 -- pragma Source_File_Name (
20338 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20339 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20340 -- [, CASING => CASING_SPEC]);
20342 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20344 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20345 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20346 -- only be used when no project file is used, while SFNP can only be
20347 -- used when a project file is used.
20349 -- No processing here. Processing was completed during parsing, since
20350 -- we need to have file names set as early as possible. Units are
20351 -- loaded well before semantic processing starts.
20353 -- The only processing we defer to this point is the check for
20354 -- correct placement.
20356 when Pragma_Source_File_Name =>
20358 Check_Valid_Configuration_Pragma;
20360 ------------------------------
20361 -- Source_File_Name_Project --
20362 ------------------------------
20364 -- See Source_File_Name for syntax
20366 -- No processing here. Processing was completed during parsing, since
20367 -- we need to have file names set as early as possible. Units are
20368 -- loaded well before semantic processing starts.
20370 -- The only processing we defer to this point is the check for
20371 -- correct placement.
20373 when Pragma_Source_File_Name_Project =>
20375 Check_Valid_Configuration_Pragma;
20377 -- Check that a pragma Source_File_Name_Project is used only in a
20378 -- configuration pragmas file.
20380 -- Pragmas Source_File_Name_Project should only be generated by
20381 -- the Project Manager in configuration pragmas files.
20383 -- This is really an ugly test. It seems to depend on some
20384 -- accidental and undocumented property. At the very least it
20385 -- needs to be documented, but it would be better to have a
20386 -- clean way of testing if we are in a configuration file???
20388 if Present (Parent (N)) then
20390 ("pragma% can only appear in a configuration pragmas file");
20393 ----------------------
20394 -- Source_Reference --
20395 ----------------------
20397 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20399 -- Nothing to do, all processing completed in Par.Prag, since we need
20400 -- the information for possible parser messages that are output.
20402 when Pragma_Source_Reference =>
20409 -- pragma SPARK_Mode [(On | Off)];
20411 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20412 Mode_Id : SPARK_Mode_Type;
20414 procedure Check_Pragma_Conformance
20415 (Context_Pragma : Node_Id;
20416 Entity : Entity_Id;
20417 Entity_Pragma : Node_Id);
20418 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20419 -- conformance of pragma N depending the following scenarios:
20421 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20422 -- compatible with the pragma Context_Pragma that was inherited
20423 -- from the context:
20424 -- * If the mode of Context_Pragma is ON, then the new mode can
20426 -- * If the mode of Context_Pragma is OFF, then the only allowed
20427 -- new mode is also OFF. Emit error if this is not the case.
20429 -- If Entity is not Empty, verify that pragma N is compatible with
20430 -- pragma Entity_Pragma that belongs to Entity.
20431 -- * If Entity_Pragma is Empty, always issue an error as this
20432 -- corresponds to the case where a previous section of Entity
20433 -- has no SPARK_Mode set.
20434 -- * If the mode of Entity_Pragma is ON, then the new mode can
20436 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20437 -- new mode is also OFF. Emit error if this is not the case.
20439 procedure Check_Library_Level_Entity (E : Entity_Id);
20440 -- Subsidiary to routines Process_xxx. Verify that the related
20441 -- entity E subject to pragma SPARK_Mode is library-level.
20443 procedure Process_Body (Decl : Node_Id);
20444 -- Verify the legality of pragma SPARK_Mode when it appears as the
20445 -- top of the body declarations of entry, package, protected unit,
20446 -- subprogram or task unit body denoted by Decl.
20448 procedure Process_Overloadable (Decl : Node_Id);
20449 -- Verify the legality of pragma SPARK_Mode when it applies to an
20450 -- entry or [generic] subprogram declaration denoted by Decl.
20452 procedure Process_Private_Part (Decl : Node_Id);
20453 -- Verify the legality of pragma SPARK_Mode when it appears at the
20454 -- top of the private declarations of a package spec, protected or
20455 -- task unit declaration denoted by Decl.
20457 procedure Process_Statement_Part (Decl : Node_Id);
20458 -- Verify the legality of pragma SPARK_Mode when it appears at the
20459 -- top of the statement sequence of a package body denoted by node
20462 procedure Process_Visible_Part (Decl : Node_Id);
20463 -- Verify the legality of pragma SPARK_Mode when it appears at the
20464 -- top of the visible declarations of a package spec, protected or
20465 -- task unit declaration denoted by Decl. The routine is also used
20466 -- on protected or task units declared without a definition.
20468 procedure Set_SPARK_Context;
20469 -- Subsidiary to routines Process_xxx. Set the global variables
20470 -- which represent the mode of the context from pragma N. Ensure
20471 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20473 ------------------------------
20474 -- Check_Pragma_Conformance --
20475 ------------------------------
20477 procedure Check_Pragma_Conformance
20478 (Context_Pragma : Node_Id;
20479 Entity : Entity_Id;
20480 Entity_Pragma : Node_Id)
20482 Err_Id : Entity_Id;
20486 -- The current pragma may appear without an argument. If this
20487 -- is the case, associate all error messages with the pragma
20490 if Present (Arg1) then
20496 -- The mode of the current pragma is compared against that of
20497 -- an enclosing context.
20499 if Present (Context_Pragma) then
20500 pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20502 -- Issue an error if the new mode is less restrictive than
20503 -- that of the context.
20505 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
20506 and then Get_SPARK_Mode_From_Annotation (N) = On
20509 ("cannot change SPARK_Mode from Off to On", Err_N);
20510 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20511 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20516 -- The mode of the current pragma is compared against that of
20517 -- an initial package, protected type, subprogram or task type
20520 if Present (Entity) then
20522 -- A simple protected or task type is transformed into an
20523 -- anonymous type whose name cannot be used to issue error
20524 -- messages. Recover the original entity of the type.
20526 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20529 (Original_Node (Unit_Declaration_Node (Entity)));
20534 -- Both the initial declaration and the completion carry
20535 -- SPARK_Mode pragmas.
20537 if Present (Entity_Pragma) then
20538 pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20540 -- Issue an error if the new mode is less restrictive
20541 -- than that of the initial declaration.
20543 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
20544 and then Get_SPARK_Mode_From_Annotation (N) = On
20546 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20547 Error_Msg_Sloc := Sloc (Entity_Pragma);
20549 ("\value Off was set for SPARK_Mode on&#",
20554 -- Otherwise the initial declaration lacks a SPARK_Mode
20555 -- pragma in which case the current pragma is illegal as
20556 -- it cannot "complete".
20559 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20560 Error_Msg_Sloc := Sloc (Err_Id);
20562 ("\no value was set for SPARK_Mode on&#",
20567 end Check_Pragma_Conformance;
20569 --------------------------------
20570 -- Check_Library_Level_Entity --
20571 --------------------------------
20573 procedure Check_Library_Level_Entity (E : Entity_Id) is
20574 procedure Add_Entity_To_Name_Buffer;
20575 -- Add the E_Kind of entity E to the name buffer
20577 -------------------------------
20578 -- Add_Entity_To_Name_Buffer --
20579 -------------------------------
20581 procedure Add_Entity_To_Name_Buffer is
20583 if Ekind_In (E, E_Entry, E_Entry_Family) then
20584 Add_Str_To_Name_Buffer ("entry");
20586 elsif Ekind_In (E, E_Generic_Package,
20590 Add_Str_To_Name_Buffer ("package");
20592 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20593 Add_Str_To_Name_Buffer ("protected type");
20595 elsif Ekind_In (E, E_Function,
20596 E_Generic_Function,
20597 E_Generic_Procedure,
20601 Add_Str_To_Name_Buffer ("subprogram");
20604 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20605 Add_Str_To_Name_Buffer ("task type");
20607 end Add_Entity_To_Name_Buffer;
20611 Msg_1 : constant String := "incorrect placement of pragma%";
20614 -- Start of processing for Check_Library_Level_Entity
20617 if not Is_Library_Level_Entity (E) then
20618 Error_Msg_Name_1 := Pname;
20619 Error_Msg_N (Fix_Error (Msg_1), N);
20622 Add_Str_To_Name_Buffer ("\& is not a library-level ");
20623 Add_Entity_To_Name_Buffer;
20625 Msg_2 := Name_Find;
20626 Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20630 end Check_Library_Level_Entity;
20636 procedure Process_Body (Decl : Node_Id) is
20637 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20638 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20641 -- Ignore pragma when applied to the special body created for
20642 -- inlining, recognized by its internal name _Parent.
20644 if Chars (Body_Id) = Name_uParent then
20648 Check_Library_Level_Entity (Body_Id);
20650 -- For entry bodies, verify the legality against:
20651 -- * The mode of the context
20652 -- * The mode of the spec (if any)
20654 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
20656 -- A stand alone subprogram body
20658 if Body_Id = Spec_Id then
20659 Check_Pragma_Conformance
20660 (Context_Pragma => SPARK_Pragma (Body_Id),
20662 Entity_Pragma => Empty);
20664 -- An entry or subprogram body that completes a previous
20668 Check_Pragma_Conformance
20669 (Context_Pragma => SPARK_Pragma (Body_Id),
20671 Entity_Pragma => SPARK_Pragma (Spec_Id));
20675 Set_SPARK_Pragma (Body_Id, N);
20676 Set_SPARK_Pragma_Inherited (Body_Id, False);
20678 -- For package bodies, verify the legality against:
20679 -- * The mode of the context
20680 -- * The mode of the private part
20682 -- This case is separated from protected and task bodies
20683 -- because the statement part of the package body inherits
20684 -- the mode of the body declarations.
20686 elsif Nkind (Decl) = N_Package_Body then
20687 Check_Pragma_Conformance
20688 (Context_Pragma => SPARK_Pragma (Body_Id),
20690 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20693 Set_SPARK_Pragma (Body_Id, N);
20694 Set_SPARK_Pragma_Inherited (Body_Id, False);
20695 Set_SPARK_Aux_Pragma (Body_Id, N);
20696 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
20698 -- For protected and task bodies, verify the legality against:
20699 -- * The mode of the context
20700 -- * The mode of the private part
20704 (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
20706 Check_Pragma_Conformance
20707 (Context_Pragma => SPARK_Pragma (Body_Id),
20709 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id));
20712 Set_SPARK_Pragma (Body_Id, N);
20713 Set_SPARK_Pragma_Inherited (Body_Id, False);
20717 --------------------------
20718 -- Process_Overloadable --
20719 --------------------------
20721 procedure Process_Overloadable (Decl : Node_Id) is
20722 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20723 Spec_Typ : constant Entity_Id := Etype (Spec_Id);
20726 Check_Library_Level_Entity (Spec_Id);
20728 -- Verify the legality against:
20729 -- * The mode of the context
20731 Check_Pragma_Conformance
20732 (Context_Pragma => SPARK_Pragma (Spec_Id),
20734 Entity_Pragma => Empty);
20736 Set_SPARK_Pragma (Spec_Id, N);
20737 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20739 -- When the pragma applies to the anonymous object created for
20740 -- a single task type, decorate the type as well. This scenario
20741 -- arises when the single task type lacks a task definition,
20742 -- therefore there is no issue with respect to a potential
20743 -- pragma SPARK_Mode in the private part.
20745 -- task type Anon_Task_Typ;
20746 -- Obj : Anon_Task_Typ;
20747 -- pragma SPARK_Mode ...;
20749 if Is_Single_Task_Object (Spec_Id) then
20750 Set_SPARK_Pragma (Spec_Typ, N);
20751 Set_SPARK_Pragma_Inherited (Spec_Typ, False);
20752 Set_SPARK_Aux_Pragma (Spec_Typ, N);
20753 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
20755 end Process_Overloadable;
20757 --------------------------
20758 -- Process_Private_Part --
20759 --------------------------
20761 procedure Process_Private_Part (Decl : Node_Id) is
20762 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20765 Check_Library_Level_Entity (Spec_Id);
20767 -- Verify the legality against:
20768 -- * The mode of the visible declarations
20770 Check_Pragma_Conformance
20771 (Context_Pragma => Empty,
20773 Entity_Pragma => SPARK_Pragma (Spec_Id));
20776 Set_SPARK_Aux_Pragma (Spec_Id, N);
20777 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
20778 end Process_Private_Part;
20780 ----------------------------
20781 -- Process_Statement_Part --
20782 ----------------------------
20784 procedure Process_Statement_Part (Decl : Node_Id) is
20785 Body_Id : constant Entity_Id := Defining_Entity (Decl);
20788 Check_Library_Level_Entity (Body_Id);
20790 -- Verify the legality against:
20791 -- * The mode of the body declarations
20793 Check_Pragma_Conformance
20794 (Context_Pragma => Empty,
20796 Entity_Pragma => SPARK_Pragma (Body_Id));
20799 Set_SPARK_Aux_Pragma (Body_Id, N);
20800 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
20801 end Process_Statement_Part;
20803 --------------------------
20804 -- Process_Visible_Part --
20805 --------------------------
20807 procedure Process_Visible_Part (Decl : Node_Id) is
20808 Spec_Id : constant Entity_Id := Defining_Entity (Decl);
20809 Obj_Id : Entity_Id;
20812 Check_Library_Level_Entity (Spec_Id);
20814 -- Verify the legality against:
20815 -- * The mode of the context
20817 Check_Pragma_Conformance
20818 (Context_Pragma => SPARK_Pragma (Spec_Id),
20820 Entity_Pragma => Empty);
20822 -- A task unit declared without a definition does not set the
20823 -- SPARK_Mode of the context because the task does not have any
20824 -- entries that could inherit the mode.
20826 if not Nkind_In (Decl, N_Single_Task_Declaration,
20827 N_Task_Type_Declaration)
20832 Set_SPARK_Pragma (Spec_Id, N);
20833 Set_SPARK_Pragma_Inherited (Spec_Id, False);
20834 Set_SPARK_Aux_Pragma (Spec_Id, N);
20835 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
20837 -- When the pragma applies to a single protected or task type,
20838 -- decorate the corresponding anonymous object as well.
20840 -- protected Anon_Prot_Typ is
20841 -- pragma SPARK_Mode ...;
20843 -- end Anon_Prot_Typ;
20845 -- Obj : Anon_Prot_Typ;
20847 if Is_Single_Concurrent_Type (Spec_Id) then
20848 Obj_Id := Anonymous_Object (Spec_Id);
20850 Set_SPARK_Pragma (Obj_Id, N);
20851 Set_SPARK_Pragma_Inherited (Obj_Id, False);
20853 end Process_Visible_Part;
20855 -----------------------
20856 -- Set_SPARK_Context --
20857 -----------------------
20859 procedure Set_SPARK_Context is
20861 SPARK_Mode := Mode_Id;
20862 SPARK_Mode_Pragma := N;
20864 if SPARK_Mode = On then
20865 Dynamic_Elaboration_Checks := False;
20867 end Set_SPARK_Context;
20875 -- Start of processing for Do_SPARK_Mode
20878 -- When a SPARK_Mode pragma appears inside an instantiation whose
20879 -- enclosing context has SPARK_Mode set to "off", the pragma has
20880 -- no semantic effect.
20882 if Ignore_Pragma_SPARK_Mode then
20883 Rewrite (N, Make_Null_Statement (Loc));
20889 Check_No_Identifiers;
20890 Check_At_Most_N_Arguments (1);
20892 -- Check the legality of the mode (no argument = ON)
20894 if Arg_Count = 1 then
20895 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
20896 Mode := Chars (Get_Pragma_Arg (Arg1));
20901 Mode_Id := Get_SPARK_Mode_Type (Mode);
20902 Context := Parent (N);
20904 -- The pragma appears in a configuration pragmas file
20906 if No (Context) then
20907 Check_Valid_Configuration_Pragma;
20909 if Present (SPARK_Mode_Pragma) then
20910 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20911 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20917 -- The pragma acts as a configuration pragma in a compilation unit
20919 -- pragma SPARK_Mode ...;
20920 -- package Pack is ...;
20922 elsif Nkind (Context) = N_Compilation_Unit
20923 and then List_Containing (N) = Context_Items (Context)
20925 Check_Valid_Configuration_Pragma;
20928 -- Otherwise the placement of the pragma within the tree dictates
20929 -- its associated construct. Inspect the declarative list where
20930 -- the pragma resides to find a potential construct.
20934 while Present (Stmt) loop
20936 -- Skip prior pragmas, but check for duplicates. Note that
20937 -- this also takes care of pragmas generated for aspects.
20939 if Nkind (Stmt) = N_Pragma then
20940 if Pragma_Name (Stmt) = Pname then
20941 Error_Msg_Name_1 := Pname;
20942 Error_Msg_Sloc := Sloc (Stmt);
20943 Error_Msg_N ("pragma% duplicates pragma declared#", N);
20947 -- The pragma applies to an expression function that has
20948 -- already been rewritten into a subprogram declaration.
20950 -- function Expr_Func return ... is (...);
20951 -- pragma SPARK_Mode ...;
20953 elsif Nkind (Stmt) = N_Subprogram_Declaration
20954 and then Nkind (Original_Node (Stmt)) =
20955 N_Expression_Function
20957 Process_Overloadable (Stmt);
20960 -- The pragma applies to the anonymous object created for a
20961 -- single concurrent type.
20963 -- protected type Anon_Prot_Typ ...;
20964 -- Obj : Anon_Prot_Typ;
20965 -- pragma SPARK_Mode ...;
20967 elsif Nkind (Stmt) = N_Object_Declaration
20968 and then Is_Single_Concurrent_Object
20969 (Defining_Entity (Stmt))
20971 Process_Overloadable (Stmt);
20974 -- Skip internally generated code
20976 elsif not Comes_From_Source (Stmt) then
20979 -- The pragma applies to an entry or [generic] subprogram
20983 -- pragma SPARK_Mode ...;
20986 -- procedure Proc ...;
20987 -- pragma SPARK_Mode ...;
20989 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
20990 N_Subprogram_Declaration)
20991 or else (Nkind (Stmt) = N_Entry_Declaration
20992 and then Is_Protected_Type
20993 (Scope (Defining_Entity (Stmt))))
20995 Process_Overloadable (Stmt);
20998 -- Otherwise the pragma does not apply to a legal construct
20999 -- or it does not appear at the top of a declarative or a
21000 -- statement list. Issue an error and stop the analysis.
21010 -- The pragma applies to a package or a subprogram that acts as
21011 -- a compilation unit.
21013 -- procedure Proc ...;
21014 -- pragma SPARK_Mode ...;
21016 if Nkind (Context) = N_Compilation_Unit_Aux then
21017 Context := Unit (Parent (Context));
21020 -- The pragma appears at the top of entry, package, protected
21021 -- unit, subprogram or task unit body declarations.
21023 -- entry Ent when ... is
21024 -- pragma SPARK_Mode ...;
21026 -- package body Pack is
21027 -- pragma SPARK_Mode ...;
21029 -- procedure Proc ... is
21030 -- pragma SPARK_Mode;
21032 -- protected body Prot is
21033 -- pragma SPARK_Mode ...;
21035 if Nkind_In (Context, N_Entry_Body,
21041 Process_Body (Context);
21043 -- The pragma appears at the top of the visible or private
21044 -- declaration of a package spec, protected or task unit.
21047 -- pragma SPARK_Mode ...;
21049 -- pragma SPARK_Mode ...;
21051 -- protected [type] Prot is
21052 -- pragma SPARK_Mode ...;
21054 -- pragma SPARK_Mode ...;
21056 elsif Nkind_In (Context, N_Package_Specification,
21057 N_Protected_Definition,
21060 if List_Containing (N) = Visible_Declarations (Context) then
21061 Process_Visible_Part (Parent (Context));
21063 Process_Private_Part (Parent (Context));
21066 -- The pragma appears at the top of package body statements
21068 -- package body Pack is
21070 -- pragma SPARK_Mode;
21072 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21073 and then Nkind (Parent (Context)) = N_Package_Body
21075 Process_Statement_Part (Parent (Context));
21077 -- The pragma appeared as an aspect of a [generic] subprogram
21078 -- declaration that acts as a compilation unit.
21081 -- procedure Proc ...;
21082 -- pragma SPARK_Mode ...;
21084 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21085 N_Subprogram_Declaration)
21087 Process_Overloadable (Context);
21089 -- The pragma does not apply to a legal construct, issue error
21097 --------------------------------
21098 -- Static_Elaboration_Desired --
21099 --------------------------------
21101 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21103 when Pragma_Static_Elaboration_Desired =>
21105 Check_At_Most_N_Arguments (1);
21107 if Is_Compilation_Unit (Current_Scope)
21108 and then Ekind (Current_Scope) = E_Package
21110 Set_Static_Elaboration_Desired (Current_Scope, True);
21112 Error_Pragma ("pragma% must apply to a library-level package");
21119 -- pragma Storage_Size (EXPRESSION);
21121 when Pragma_Storage_Size => Storage_Size : declare
21122 P : constant Node_Id := Parent (N);
21126 Check_No_Identifiers;
21127 Check_Arg_Count (1);
21129 -- The expression must be analyzed in the special manner described
21130 -- in "Handling of Default Expressions" in sem.ads.
21132 Arg := Get_Pragma_Arg (Arg1);
21133 Preanalyze_Spec_Expression (Arg, Any_Integer);
21135 if not Is_OK_Static_Expression (Arg) then
21136 Check_Restriction (Static_Storage_Size, Arg);
21139 if Nkind (P) /= N_Task_Definition then
21144 if Has_Storage_Size_Pragma (P) then
21145 Error_Pragma ("duplicate pragma% not allowed");
21147 Set_Has_Storage_Size_Pragma (P, True);
21150 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
21158 -- pragma Storage_Unit (NUMERIC_LITERAL);
21160 -- Only permitted argument is System'Storage_Unit value
21162 when Pragma_Storage_Unit =>
21163 Check_No_Identifiers;
21164 Check_Arg_Count (1);
21165 Check_Arg_Is_Integer_Literal (Arg1);
21167 if Intval (Get_Pragma_Arg (Arg1)) /=
21168 UI_From_Int (Ttypes.System_Storage_Unit)
21170 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
21172 ("the only allowed argument for pragma% is ^", Arg1);
21175 --------------------
21176 -- Stream_Convert --
21177 --------------------
21179 -- pragma Stream_Convert (
21180 -- [Entity =>] type_LOCAL_NAME,
21181 -- [Read =>] function_NAME,
21182 -- [Write =>] function NAME);
21184 when Pragma_Stream_Convert => Stream_Convert : declare
21186 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
21187 -- Check that the given argument is the name of a local function
21188 -- of one argument that is not overloaded earlier in the current
21189 -- local scope. A check is also made that the argument is a
21190 -- function with one parameter.
21192 --------------------------------------
21193 -- Check_OK_Stream_Convert_Function --
21194 --------------------------------------
21196 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
21200 Check_Arg_Is_Local_Name (Arg);
21201 Ent := Entity (Get_Pragma_Arg (Arg));
21203 if Has_Homonym (Ent) then
21205 ("argument for pragma% may not be overloaded", Arg);
21208 if Ekind (Ent) /= E_Function
21209 or else No (First_Formal (Ent))
21210 or else Present (Next_Formal (First_Formal (Ent)))
21213 ("argument for pragma% must be function of one argument",
21216 end Check_OK_Stream_Convert_Function;
21218 -- Start of processing for Stream_Convert
21222 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
21223 Check_Arg_Count (3);
21224 Check_Optional_Identifier (Arg1, Name_Entity);
21225 Check_Optional_Identifier (Arg2, Name_Read);
21226 Check_Optional_Identifier (Arg3, Name_Write);
21227 Check_Arg_Is_Local_Name (Arg1);
21228 Check_OK_Stream_Convert_Function (Arg2);
21229 Check_OK_Stream_Convert_Function (Arg3);
21232 Typ : constant Entity_Id :=
21233 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
21234 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
21235 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
21238 Check_First_Subtype (Arg1);
21240 -- Check for too early or too late. Note that we don't enforce
21241 -- the rule about primitive operations in this case, since, as
21242 -- is the case for explicit stream attributes themselves, these
21243 -- restrictions are not appropriate. Note that the chaining of
21244 -- the pragma by Rep_Item_Too_Late is actually the critical
21245 -- processing done for this pragma.
21247 if Rep_Item_Too_Early (Typ, N)
21249 Rep_Item_Too_Late (Typ, N, FOnly => True)
21254 -- Return if previous error
21256 if Etype (Typ) = Any_Type
21258 Etype (Read) = Any_Type
21260 Etype (Write) = Any_Type
21267 if Underlying_Type (Etype (Read)) /= Typ then
21269 ("incorrect return type for function&", Arg2);
21272 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
21274 ("incorrect parameter type for function&", Arg3);
21277 if Underlying_Type (Etype (First_Formal (Read))) /=
21278 Underlying_Type (Etype (Write))
21281 ("result type of & does not match Read parameter type",
21285 end Stream_Convert;
21291 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21293 -- This is processed by the parser since some of the style checks
21294 -- take place during source scanning and parsing. This means that
21295 -- we don't need to issue error messages here.
21297 when Pragma_Style_Checks => Style_Checks : declare
21298 A : constant Node_Id := Get_Pragma_Arg (Arg1);
21304 Check_No_Identifiers;
21306 -- Two argument form
21308 if Arg_Count = 2 then
21309 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21316 E_Id := Get_Pragma_Arg (Arg2);
21319 if not Is_Entity_Name (E_Id) then
21321 ("second argument of pragma% must be entity name",
21325 E := Entity (E_Id);
21327 if not Ignore_Style_Checks_Pragmas then
21332 Set_Suppress_Style_Checks
21333 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
21334 exit when No (Homonym (E));
21341 -- One argument form
21344 Check_Arg_Count (1);
21346 if Nkind (A) = N_String_Literal then
21350 Slen : constant Natural := Natural (String_Length (S));
21351 Options : String (1 .. Slen);
21357 C := Get_String_Char (S, Pos (J));
21358 exit when not In_Character_Range (C);
21359 Options (J) := Get_Character (C);
21361 -- If at end of string, set options. As per discussion
21362 -- above, no need to check for errors, since we issued
21363 -- them in the parser.
21366 if not Ignore_Style_Checks_Pragmas then
21367 Set_Style_Check_Options (Options);
21377 elsif Nkind (A) = N_Identifier then
21378 if Chars (A) = Name_All_Checks then
21379 if not Ignore_Style_Checks_Pragmas then
21381 Set_GNAT_Style_Check_Options;
21383 Set_Default_Style_Check_Options;
21387 elsif Chars (A) = Name_On then
21388 if not Ignore_Style_Checks_Pragmas then
21389 Style_Check := True;
21392 elsif Chars (A) = Name_Off then
21393 if not Ignore_Style_Checks_Pragmas then
21394 Style_Check := False;
21405 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21407 when Pragma_Subtitle =>
21409 Check_Arg_Count (1);
21410 Check_Optional_Identifier (Arg1, Name_Subtitle);
21411 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21418 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21420 when Pragma_Suppress =>
21421 Process_Suppress_Unsuppress (Suppress_Case => True);
21427 -- pragma Suppress_All;
21429 -- The only check made here is that the pragma has no arguments.
21430 -- There are no placement rules, and the processing required (setting
21431 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21432 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21433 -- then creates and inserts a pragma Suppress (All_Checks).
21435 when Pragma_Suppress_All =>
21437 Check_Arg_Count (0);
21439 -------------------------
21440 -- Suppress_Debug_Info --
21441 -------------------------
21443 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21445 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21446 Nam_Id : Entity_Id;
21450 Check_Arg_Count (1);
21451 Check_Optional_Identifier (Arg1, Name_Entity);
21452 Check_Arg_Is_Local_Name (Arg1);
21454 Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21456 -- A pragma that applies to a Ghost entity becomes Ghost for the
21457 -- purposes of legality checks and removal of ignored Ghost code.
21459 Mark_Pragma_As_Ghost (N, Nam_Id);
21460 Set_Debug_Info_Off (Nam_Id);
21461 end Suppress_Debug_Info;
21463 ----------------------------------
21464 -- Suppress_Exception_Locations --
21465 ----------------------------------
21467 -- pragma Suppress_Exception_Locations;
21469 when Pragma_Suppress_Exception_Locations =>
21471 Check_Arg_Count (0);
21472 Check_Valid_Configuration_Pragma;
21473 Exception_Locations_Suppressed := True;
21475 -----------------------------
21476 -- Suppress_Initialization --
21477 -----------------------------
21479 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21481 when Pragma_Suppress_Initialization => Suppress_Init : declare
21487 Check_Arg_Count (1);
21488 Check_Optional_Identifier (Arg1, Name_Entity);
21489 Check_Arg_Is_Local_Name (Arg1);
21491 E_Id := Get_Pragma_Arg (Arg1);
21493 if Etype (E_Id) = Any_Type then
21497 E := Entity (E_Id);
21499 -- A pragma that applies to a Ghost entity becomes Ghost for the
21500 -- purposes of legality checks and removal of ignored Ghost code.
21502 Mark_Pragma_As_Ghost (N, E);
21504 if not Is_Type (E) and then Ekind (E) /= E_Variable then
21506 ("pragma% requires variable, type or subtype", Arg1);
21509 if Rep_Item_Too_Early (E, N)
21511 Rep_Item_Too_Late (E, N, FOnly => True)
21516 -- For incomplete/private type, set flag on full view
21518 if Is_Incomplete_Or_Private_Type (E) then
21519 if No (Full_View (Base_Type (E))) then
21521 ("argument of pragma% cannot be an incomplete type", Arg1);
21523 Set_Suppress_Initialization (Full_View (Base_Type (E)));
21526 -- For first subtype, set flag on base type
21528 elsif Is_First_Subtype (E) then
21529 Set_Suppress_Initialization (Base_Type (E));
21531 -- For other than first subtype, set flag on subtype or variable
21534 Set_Suppress_Initialization (E);
21542 -- pragma System_Name (DIRECT_NAME);
21544 -- Syntax check: one argument, which must be the identifier GNAT or
21545 -- the identifier GCC, no other identifiers are acceptable.
21547 when Pragma_System_Name =>
21549 Check_No_Identifiers;
21550 Check_Arg_Count (1);
21551 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21553 -----------------------------
21554 -- Task_Dispatching_Policy --
21555 -----------------------------
21557 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21559 when Pragma_Task_Dispatching_Policy => declare
21563 Check_Ada_83_Warning;
21564 Check_Arg_Count (1);
21565 Check_No_Identifiers;
21566 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21567 Check_Valid_Configuration_Pragma;
21568 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21569 DP := Fold_Upper (Name_Buffer (1));
21571 if Task_Dispatching_Policy /= ' '
21572 and then Task_Dispatching_Policy /= DP
21574 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21576 ("task dispatching policy incompatible with policy#");
21578 -- Set new policy, but always preserve System_Location since we
21579 -- like the error message with the run time name.
21582 Task_Dispatching_Policy := DP;
21584 if Task_Dispatching_Policy_Sloc /= System_Location then
21585 Task_Dispatching_Policy_Sloc := Loc;
21594 -- pragma Task_Info (EXPRESSION);
21596 when Pragma_Task_Info => Task_Info : declare
21597 P : constant Node_Id := Parent (N);
21603 if Warn_On_Obsolescent_Feature then
21605 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21606 & "instead?j?", N);
21609 if Nkind (P) /= N_Task_Definition then
21610 Error_Pragma ("pragma% must appear in task definition");
21613 Check_No_Identifiers;
21614 Check_Arg_Count (1);
21616 Analyze_And_Resolve
21617 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21619 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21623 Ent := Defining_Identifier (Parent (P));
21625 -- Check duplicate pragma before we chain the pragma in the Rep
21626 -- Item chain of Ent.
21629 (Ent, Name_Task_Info, Check_Parents => False)
21631 Error_Pragma ("duplicate pragma% not allowed");
21634 Record_Rep_Item (Ent, N);
21641 -- pragma Task_Name (string_EXPRESSION);
21643 when Pragma_Task_Name => Task_Name : declare
21644 P : constant Node_Id := Parent (N);
21649 Check_No_Identifiers;
21650 Check_Arg_Count (1);
21652 Arg := Get_Pragma_Arg (Arg1);
21654 -- The expression is used in the call to Create_Task, and must be
21655 -- expanded there, not in the context of the current spec. It must
21656 -- however be analyzed to capture global references, in case it
21657 -- appears in a generic context.
21659 Preanalyze_And_Resolve (Arg, Standard_String);
21661 if Nkind (P) /= N_Task_Definition then
21665 Ent := Defining_Identifier (Parent (P));
21667 -- Check duplicate pragma before we chain the pragma in the Rep
21668 -- Item chain of Ent.
21671 (Ent, Name_Task_Name, Check_Parents => False)
21673 Error_Pragma ("duplicate pragma% not allowed");
21676 Record_Rep_Item (Ent, N);
21683 -- pragma Task_Storage (
21684 -- [Task_Type =>] LOCAL_NAME,
21685 -- [Top_Guard =>] static_integer_EXPRESSION);
21687 when Pragma_Task_Storage => Task_Storage : declare
21688 Args : Args_List (1 .. 2);
21689 Names : constant Name_List (1 .. 2) := (
21693 Task_Type : Node_Id renames Args (1);
21694 Top_Guard : Node_Id renames Args (2);
21700 Gather_Associations (Names, Args);
21702 if No (Task_Type) then
21704 ("missing task_type argument for pragma%");
21707 Check_Arg_Is_Local_Name (Task_Type);
21709 Ent := Entity (Task_Type);
21711 if not Is_Task_Type (Ent) then
21713 ("argument for pragma% must be task type", Task_Type);
21716 if No (Top_Guard) then
21718 ("pragma% takes two arguments", Task_Type);
21720 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
21723 Check_First_Subtype (Task_Type);
21725 if Rep_Item_Too_Late (Ent, N) then
21734 -- pragma Test_Case
21735 -- ([Name =>] Static_String_EXPRESSION
21736 -- ,[Mode =>] MODE_TYPE
21737 -- [, Requires => Boolean_EXPRESSION]
21738 -- [, Ensures => Boolean_EXPRESSION]);
21740 -- MODE_TYPE ::= Nominal | Robustness
21742 -- Characteristics:
21744 -- * Analysis - The annotation undergoes initial checks to verify
21745 -- the legal placement and context. Secondary checks preanalyze the
21748 -- Analyze_Test_Case_In_Decl_Part
21750 -- * Expansion - None.
21752 -- * Template - The annotation utilizes the generic template of the
21753 -- related subprogram when it is:
21755 -- aspect on subprogram declaration
21757 -- The annotation must prepare its own template when it is:
21759 -- pragma on subprogram declaration
21761 -- * Globals - Capture of global references must occur after full
21764 -- * Instance - The annotation is instantiated automatically when
21765 -- the related generic subprogram is instantiated except for the
21766 -- "pragma on subprogram declaration" case. In that scenario the
21767 -- annotation must instantiate itself.
21769 when Pragma_Test_Case => Test_Case : declare
21770 procedure Check_Distinct_Name (Subp_Id : Entity_Id);
21771 -- Ensure that the contract of subprogram Subp_Id does not contain
21772 -- another Test_Case pragma with the same Name as the current one.
21774 -------------------------
21775 -- Check_Distinct_Name --
21776 -------------------------
21778 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
21779 Items : constant Node_Id := Contract (Subp_Id);
21780 Name : constant String_Id := Get_Name_From_CTC_Pragma (N);
21784 -- Inspect all Test_Case pragma of the related subprogram
21785 -- looking for one with a duplicate "Name" argument.
21787 if Present (Items) then
21788 Prag := Contract_Test_Cases (Items);
21789 while Present (Prag) loop
21790 if Pragma_Name (Prag) = Name_Test_Case
21792 and then String_Equal
21793 (Name, Get_Name_From_CTC_Pragma (Prag))
21795 Error_Msg_Sloc := Sloc (Prag);
21796 Error_Pragma ("name for pragma % is already used #");
21799 Prag := Next_Pragma (Prag);
21802 end Check_Distinct_Name;
21806 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
21809 Subp_Decl : Node_Id;
21810 Subp_Id : Entity_Id;
21812 -- Start of processing for Test_Case
21816 Check_At_Least_N_Arguments (2);
21817 Check_At_Most_N_Arguments (4);
21819 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
21823 Check_Optional_Identifier (Arg1, Name_Name);
21824 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21828 Check_Optional_Identifier (Arg2, Name_Mode);
21829 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
21831 -- Arguments "Requires" and "Ensures"
21833 if Present (Arg3) then
21834 if Present (Arg4) then
21835 Check_Identifier (Arg3, Name_Requires);
21836 Check_Identifier (Arg4, Name_Ensures);
21838 Check_Identifier_Is_One_Of
21839 (Arg3, Name_Requires, Name_Ensures);
21843 -- Pragma Test_Case must be associated with a subprogram declared
21844 -- in a library-level package. First determine whether the current
21845 -- compilation unit is a legal context.
21847 if Nkind_In (Pack_Decl, N_Package_Declaration,
21848 N_Generic_Package_Declaration)
21852 -- Otherwise the placement is illegal
21856 ("pragma % must be specified within a package declaration");
21860 Subp_Decl := Find_Related_Declaration_Or_Body (N);
21862 -- Find the enclosing context
21864 Context := Parent (Subp_Decl);
21866 if Present (Context) then
21867 Context := Parent (Context);
21870 -- Verify the placement of the pragma
21872 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
21874 ("pragma % cannot be applied to abstract subprogram");
21877 elsif Nkind (Subp_Decl) = N_Entry_Declaration then
21878 Error_Pragma ("pragma % cannot be applied to entry");
21881 -- The context is a [generic] subprogram declared at the top level
21882 -- of the [generic] package unit.
21884 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
21885 N_Subprogram_Declaration)
21886 and then Present (Context)
21887 and then Nkind_In (Context, N_Generic_Package_Declaration,
21888 N_Package_Declaration)
21892 -- Otherwise the placement is illegal
21896 ("pragma % must be applied to a library-level subprogram "
21901 Subp_Id := Defining_Entity (Subp_Decl);
21903 -- Chain the pragma on the contract for further processing by
21904 -- Analyze_Test_Case_In_Decl_Part.
21906 Add_Contract_Item (N, Subp_Id);
21908 -- A pragma that applies to a Ghost entity becomes Ghost for the
21909 -- purposes of legality checks and removal of ignored Ghost code.
21911 Mark_Pragma_As_Ghost (N, Subp_Id);
21913 -- Preanalyze the original aspect argument "Name" for ASIS or for
21914 -- a generic subprogram to properly capture global references.
21916 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
21917 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
21919 if Present (Asp_Arg) then
21921 -- The argument appears with an identifier in association
21924 if Nkind (Asp_Arg) = N_Component_Association then
21925 Asp_Arg := Expression (Asp_Arg);
21928 Check_Expr_Is_OK_Static_Expression
21929 (Asp_Arg, Standard_String);
21933 -- Ensure that the all Test_Case pragmas of the related subprogram
21934 -- have distinct names.
21936 Check_Distinct_Name (Subp_Id);
21938 -- Fully analyze the pragma when it appears inside an entry
21939 -- or subprogram body because it cannot benefit from forward
21942 if Nkind_In (Subp_Decl, N_Entry_Body,
21944 N_Subprogram_Body_Stub)
21946 -- The legality checks of pragma Test_Case are affected by the
21947 -- SPARK mode in effect and the volatility of the context.
21948 -- Analyze all pragmas in a specific order.
21950 Analyze_If_Present (Pragma_SPARK_Mode);
21951 Analyze_If_Present (Pragma_Volatile_Function);
21952 Analyze_Test_Case_In_Decl_Part (N);
21956 --------------------------
21957 -- Thread_Local_Storage --
21958 --------------------------
21960 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21962 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
21968 Check_Arg_Count (1);
21969 Check_Optional_Identifier (Arg1, Name_Entity);
21970 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21972 Id := Get_Pragma_Arg (Arg1);
21975 if not Is_Entity_Name (Id)
21976 or else Ekind (Entity (Id)) /= E_Variable
21978 Error_Pragma_Arg ("local variable name required", Arg1);
21983 -- A pragma that applies to a Ghost entity becomes Ghost for the
21984 -- purposes of legality checks and removal of ignored Ghost code.
21986 Mark_Pragma_As_Ghost (N, E);
21988 if Rep_Item_Too_Early (E, N)
21990 Rep_Item_Too_Late (E, N)
21995 Set_Has_Pragma_Thread_Local_Storage (E);
21996 Set_Has_Gigi_Rep_Item (E);
21997 end Thread_Local_Storage;
22003 -- pragma Time_Slice (static_duration_EXPRESSION);
22005 when Pragma_Time_Slice => Time_Slice : declare
22011 Check_Arg_Count (1);
22012 Check_No_Identifiers;
22013 Check_In_Main_Program;
22014 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22016 if not Error_Posted (Arg1) then
22018 while Present (Nod) loop
22019 if Nkind (Nod) = N_Pragma
22020 and then Pragma_Name (Nod) = Name_Time_Slice
22022 Error_Msg_Name_1 := Pname;
22023 Error_Msg_N ("duplicate pragma% not permitted", Nod);
22030 -- Process only if in main unit
22032 if Get_Source_Unit (Loc) = Main_Unit then
22033 Opt.Time_Slice_Set := True;
22034 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22036 if Val <= Ureal_0 then
22037 Opt.Time_Slice_Value := 0;
22039 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22040 Opt.Time_Slice_Value := 1_000_000_000;
22043 Opt.Time_Slice_Value :=
22044 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22053 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22055 -- TITLING_OPTION ::=
22056 -- [Title =>] STRING_LITERAL
22057 -- | [Subtitle =>] STRING_LITERAL
22059 when Pragma_Title => Title : declare
22060 Args : Args_List (1 .. 2);
22061 Names : constant Name_List (1 .. 2) := (
22067 Gather_Associations (Names, Args);
22070 for J in 1 .. 2 loop
22071 if Present (Args (J)) then
22072 Check_Arg_Is_OK_Static_Expression
22073 (Args (J), Standard_String);
22078 ----------------------------
22079 -- Type_Invariant[_Class] --
22080 ----------------------------
22082 -- pragma Type_Invariant[_Class]
22083 -- ([Entity =>] type_LOCAL_NAME,
22084 -- [Check =>] EXPRESSION);
22086 when Pragma_Type_Invariant |
22087 Pragma_Type_Invariant_Class =>
22088 Type_Invariant : declare
22089 I_Pragma : Node_Id;
22092 Check_Arg_Count (2);
22094 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22095 -- setting Class_Present for the Type_Invariant_Class case.
22097 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22098 I_Pragma := New_Copy (N);
22099 Set_Pragma_Identifier
22100 (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22101 Rewrite (N, I_Pragma);
22102 Set_Analyzed (N, False);
22104 end Type_Invariant;
22106 ---------------------
22107 -- Unchecked_Union --
22108 ---------------------
22110 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22112 when Pragma_Unchecked_Union => Unchecked_Union : declare
22113 Assoc : constant Node_Id := Arg1;
22114 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22124 Check_No_Identifiers;
22125 Check_Arg_Count (1);
22126 Check_Arg_Is_Local_Name (Arg1);
22128 Find_Type (Type_Id);
22130 Typ := Entity (Type_Id);
22132 -- A pragma that applies to a Ghost entity becomes Ghost for the
22133 -- purposes of legality checks and removal of ignored Ghost code.
22135 Mark_Pragma_As_Ghost (N, Typ);
22138 or else Rep_Item_Too_Early (Typ, N)
22142 Typ := Underlying_Type (Typ);
22145 if Rep_Item_Too_Late (Typ, N) then
22149 Check_First_Subtype (Arg1);
22151 -- Note remaining cases are references to a type in the current
22152 -- declarative part. If we find an error, we post the error on
22153 -- the relevant type declaration at an appropriate point.
22155 if not Is_Record_Type (Typ) then
22156 Error_Msg_N ("unchecked union must be record type", Typ);
22159 elsif Is_Tagged_Type (Typ) then
22160 Error_Msg_N ("unchecked union must not be tagged", Typ);
22163 elsif not Has_Discriminants (Typ) then
22165 ("unchecked union must have one discriminant", Typ);
22168 -- Note: in previous versions of GNAT we used to check for limited
22169 -- types and give an error, but in fact the standard does allow
22170 -- Unchecked_Union on limited types, so this check was removed.
22172 -- Similarly, GNAT used to require that all discriminants have
22173 -- default values, but this is not mandated by the RM.
22175 -- Proceed with basic error checks completed
22178 Tdef := Type_Definition (Declaration_Node (Typ));
22179 Clist := Component_List (Tdef);
22181 -- Check presence of component list and variant part
22183 if No (Clist) or else No (Variant_Part (Clist)) then
22185 ("unchecked union must have variant part", Tdef);
22189 -- Check components
22191 Comp := First (Component_Items (Clist));
22192 while Present (Comp) loop
22193 Check_Component (Comp, Typ);
22197 -- Check variant part
22199 Vpart := Variant_Part (Clist);
22201 Variant := First (Variants (Vpart));
22202 while Present (Variant) loop
22203 Check_Variant (Variant, Typ);
22208 Set_Is_Unchecked_Union (Typ);
22209 Set_Convention (Typ, Convention_C);
22210 Set_Has_Unchecked_Union (Base_Type (Typ));
22211 Set_Is_Unchecked_Union (Base_Type (Typ));
22212 end Unchecked_Union;
22214 ------------------------
22215 -- Unimplemented_Unit --
22216 ------------------------
22218 -- pragma Unimplemented_Unit;
22220 -- Note: this only gives an error if we are generating code, or if
22221 -- we are in a generic library unit (where the pragma appears in the
22222 -- body, not in the spec).
22224 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
22225 Cunitent : constant Entity_Id :=
22226 Cunit_Entity (Get_Source_Unit (Loc));
22227 Ent_Kind : constant Entity_Kind :=
22232 Check_Arg_Count (0);
22234 if Operating_Mode = Generate_Code
22235 or else Ent_Kind = E_Generic_Function
22236 or else Ent_Kind = E_Generic_Procedure
22237 or else Ent_Kind = E_Generic_Package
22239 Get_Name_String (Chars (Cunitent));
22240 Set_Casing (Mixed_Case);
22241 Write_Str (Name_Buffer (1 .. Name_Len));
22242 Write_Str (" is not supported in this configuration");
22244 raise Unrecoverable_Error;
22246 end Unimplemented_Unit;
22248 ------------------------
22249 -- Universal_Aliasing --
22250 ------------------------
22252 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22254 when Pragma_Universal_Aliasing => Universal_Alias : declare
22259 Check_Arg_Count (1);
22260 Check_Optional_Identifier (Arg2, Name_Entity);
22261 Check_Arg_Is_Local_Name (Arg1);
22262 E_Id := Entity (Get_Pragma_Arg (Arg1));
22264 if E_Id = Any_Type then
22266 elsif No (E_Id) or else not Is_Type (E_Id) then
22267 Error_Pragma_Arg ("pragma% requires type", Arg1);
22270 -- A pragma that applies to a Ghost entity becomes Ghost for the
22271 -- purposes of legality checks and removal of ignored Ghost code.
22273 Mark_Pragma_As_Ghost (N, E_Id);
22274 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
22275 Record_Rep_Item (E_Id, N);
22276 end Universal_Alias;
22278 --------------------
22279 -- Universal_Data --
22280 --------------------
22282 -- pragma Universal_Data [(library_unit_NAME)];
22284 when Pragma_Universal_Data =>
22287 -- If this is a configuration pragma, then set the universal
22288 -- addressing option, otherwise confirm that the pragma satisfies
22289 -- the requirements of library unit pragma placement and leave it
22290 -- to the GNAAMP back end to detect the pragma (avoids transitive
22291 -- setting of the option due to withed units).
22293 if Is_Configuration_Pragma then
22294 Universal_Addressing_On_AAMP := True;
22296 Check_Valid_Library_Unit_Pragma;
22299 if not AAMP_On_Target then
22300 Error_Pragma ("??pragma% ignored (applies only to AAMP)");
22307 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22309 when Pragma_Unmodified => Unmodified : declare
22311 Arg_Expr : Node_Id;
22312 Arg_Id : Entity_Id;
22314 Ghost_Error_Posted : Boolean := False;
22315 -- Flag set when an error concerning the illegal mix of Ghost and
22316 -- non-Ghost variables is emitted.
22318 Ghost_Id : Entity_Id := Empty;
22319 -- The entity of the first Ghost variable encountered while
22320 -- processing the arguments of the pragma.
22324 Check_At_Least_N_Arguments (1);
22326 -- Loop through arguments
22329 while Present (Arg) loop
22330 Check_No_Identifier (Arg);
22332 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
22333 -- in fact generate reference, so that the entity will have a
22334 -- reference, which will inhibit any warnings about it not
22335 -- being referenced, and also properly show up in the ali file
22336 -- as a reference. But this reference is recorded before the
22337 -- Has_Pragma_Unreferenced flag is set, so that no warning is
22338 -- generated for this reference.
22340 Check_Arg_Is_Local_Name (Arg);
22341 Arg_Expr := Get_Pragma_Arg (Arg);
22343 if Is_Entity_Name (Arg_Expr) then
22344 Arg_Id := Entity (Arg_Expr);
22346 if Is_Assignable (Arg_Id) then
22347 Set_Has_Pragma_Unmodified (Arg_Id);
22349 -- A pragma that applies to a Ghost entity becomes Ghost
22350 -- for the purposes of legality checks and removal of
22351 -- ignored Ghost code.
22353 Mark_Pragma_As_Ghost (N, Arg_Id);
22355 -- Capture the entity of the first Ghost variable being
22356 -- processed for error detection purposes.
22358 if Is_Ghost_Entity (Arg_Id) then
22359 if No (Ghost_Id) then
22360 Ghost_Id := Arg_Id;
22363 -- Otherwise the variable is non-Ghost. It is illegal
22364 -- to mix references to Ghost and non-Ghost entities
22367 elsif Present (Ghost_Id)
22368 and then not Ghost_Error_Posted
22370 Ghost_Error_Posted := True;
22372 Error_Msg_Name_1 := Pname;
22374 ("pragma % cannot mention ghost and non-ghost "
22377 Error_Msg_Sloc := Sloc (Ghost_Id);
22378 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22380 Error_Msg_Sloc := Sloc (Arg_Id);
22381 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22384 -- Otherwise the pragma referenced an illegal entity
22388 ("pragma% can only be applied to a variable", Arg_Expr);
22400 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22402 -- or when used in a context clause:
22404 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22406 when Pragma_Unreferenced => Unreferenced : declare
22408 Arg_Expr : Node_Id;
22409 Arg_Id : Entity_Id;
22412 Ghost_Error_Posted : Boolean := False;
22413 -- Flag set when an error concerning the illegal mix of Ghost and
22414 -- non-Ghost names is emitted.
22416 Ghost_Id : Entity_Id := Empty;
22417 -- The entity of the first Ghost name encountered while processing
22418 -- the arguments of the pragma.
22422 Check_At_Least_N_Arguments (1);
22424 -- Check case of appearing within context clause
22426 if Is_In_Context_Clause then
22428 -- The arguments must all be units mentioned in a with clause
22429 -- in the same context clause. Note we already checked (in
22430 -- Par.Prag) that the arguments are either identifiers or
22431 -- selected components.
22434 while Present (Arg) loop
22435 Citem := First (List_Containing (N));
22436 while Citem /= N loop
22437 Arg_Expr := Get_Pragma_Arg (Arg);
22439 if Nkind (Citem) = N_With_Clause
22440 and then Same_Name (Name (Citem), Arg_Expr)
22442 Set_Has_Pragma_Unreferenced
22445 (Library_Unit (Citem))));
22446 Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
22455 ("argument of pragma% is not withed unit", Arg);
22461 -- Case of not in list of context items
22465 while Present (Arg) loop
22466 Check_No_Identifier (Arg);
22468 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22469 -- will in fact generate reference, so that the entity will
22470 -- have a reference, which will inhibit any warnings about
22471 -- it not being referenced, and also properly show up in the
22472 -- ali file as a reference. But this reference is recorded
22473 -- before the Has_Pragma_Unreferenced flag is set, so that
22474 -- no warning is generated for this reference.
22476 Check_Arg_Is_Local_Name (Arg);
22477 Arg_Expr := Get_Pragma_Arg (Arg);
22479 if Is_Entity_Name (Arg_Expr) then
22480 Arg_Id := Entity (Arg_Expr);
22482 -- If the entity is overloaded, the pragma applies to the
22483 -- most recent overloading, as documented. In this case,
22484 -- name resolution does not generate a reference, so it
22485 -- must be done here explicitly.
22487 if Is_Overloaded (Arg_Expr) then
22488 Generate_Reference (Arg_Id, N);
22491 Set_Has_Pragma_Unreferenced (Arg_Id);
22493 -- A pragma that applies to a Ghost entity becomes Ghost
22494 -- for the purposes of legality checks and removal of
22495 -- ignored Ghost code.
22497 Mark_Pragma_As_Ghost (N, Arg_Id);
22499 -- Capture the entity of the first Ghost name being
22500 -- processed for error detection purposes.
22502 if Is_Ghost_Entity (Arg_Id) then
22503 if No (Ghost_Id) then
22504 Ghost_Id := Arg_Id;
22507 -- Otherwise the name is non-Ghost. It is illegal to mix
22508 -- references to Ghost and non-Ghost entities
22511 elsif Present (Ghost_Id)
22512 and then not Ghost_Error_Posted
22514 Ghost_Error_Posted := True;
22516 Error_Msg_Name_1 := Pname;
22518 ("pragma % cannot mention ghost and non-ghost names",
22521 Error_Msg_Sloc := Sloc (Ghost_Id);
22522 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22524 Error_Msg_Sloc := Sloc (Arg_Id);
22525 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22534 --------------------------
22535 -- Unreferenced_Objects --
22536 --------------------------
22538 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22540 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22542 Arg_Expr : Node_Id;
22543 Arg_Id : Entity_Id;
22545 Ghost_Error_Posted : Boolean := False;
22546 -- Flag set when an error concerning the illegal mix of Ghost and
22547 -- non-Ghost types is emitted.
22549 Ghost_Id : Entity_Id := Empty;
22550 -- The entity of the first Ghost type encountered while processing
22551 -- the arguments of the pragma.
22555 Check_At_Least_N_Arguments (1);
22558 while Present (Arg) loop
22559 Check_No_Identifier (Arg);
22560 Check_Arg_Is_Local_Name (Arg);
22561 Arg_Expr := Get_Pragma_Arg (Arg);
22563 if Is_Entity_Name (Arg_Expr) then
22564 Arg_Id := Entity (Arg_Expr);
22566 if Is_Type (Arg_Id) then
22567 Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22569 -- A pragma that applies to a Ghost entity becomes Ghost
22570 -- for the purposes of legality checks and removal of
22571 -- ignored Ghost code.
22573 Mark_Pragma_As_Ghost (N, Arg_Id);
22575 -- Capture the entity of the first Ghost type being
22576 -- processed for error detection purposes.
22578 if Is_Ghost_Entity (Arg_Id) then
22579 if No (Ghost_Id) then
22580 Ghost_Id := Arg_Id;
22583 -- Otherwise the type is non-Ghost. It is illegal to mix
22584 -- references to Ghost and non-Ghost entities
22587 elsif Present (Ghost_Id)
22588 and then not Ghost_Error_Posted
22590 Ghost_Error_Posted := True;
22592 Error_Msg_Name_1 := Pname;
22594 ("pragma % cannot mention ghost and non-ghost types",
22597 Error_Msg_Sloc := Sloc (Ghost_Id);
22598 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22600 Error_Msg_Sloc := Sloc (Arg_Id);
22601 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22605 ("argument for pragma% must be type or subtype", Arg);
22609 ("argument for pragma% must be type or subtype", Arg);
22614 end Unreferenced_Objects;
22616 ------------------------------
22617 -- Unreserve_All_Interrupts --
22618 ------------------------------
22620 -- pragma Unreserve_All_Interrupts;
22622 when Pragma_Unreserve_All_Interrupts =>
22624 Check_Arg_Count (0);
22626 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22627 Unreserve_All_Interrupts := True;
22634 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22636 when Pragma_Unsuppress =>
22638 Process_Suppress_Unsuppress (Suppress_Case => False);
22640 ----------------------------
22641 -- Unevaluated_Use_Of_Old --
22642 ----------------------------
22644 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22646 when Pragma_Unevaluated_Use_Of_Old =>
22648 Check_Arg_Count (1);
22649 Check_No_Identifiers;
22650 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22652 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22653 -- a declarative part or a package spec.
22655 if not Is_Configuration_Pragma then
22656 Check_Is_In_Decl_Part_Or_Package_Spec;
22659 -- Store proper setting of Uneval_Old
22661 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22662 Uneval_Old := Fold_Upper (Name_Buffer (1));
22664 -------------------
22665 -- Use_VADS_Size --
22666 -------------------
22668 -- pragma Use_VADS_Size;
22670 when Pragma_Use_VADS_Size =>
22672 Check_Arg_Count (0);
22673 Check_Valid_Configuration_Pragma;
22674 Use_VADS_Size := True;
22676 ---------------------
22677 -- Validity_Checks --
22678 ---------------------
22680 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22682 when Pragma_Validity_Checks => Validity_Checks : declare
22683 A : constant Node_Id := Get_Pragma_Arg (Arg1);
22689 Check_Arg_Count (1);
22690 Check_No_Identifiers;
22692 -- Pragma always active unless in CodePeer or GNATprove modes,
22693 -- which use a fixed configuration of validity checks.
22695 if not (CodePeer_Mode or GNATprove_Mode) then
22696 if Nkind (A) = N_String_Literal then
22700 Slen : constant Natural := Natural (String_Length (S));
22701 Options : String (1 .. Slen);
22705 -- Couldn't we use a for loop here over Options'Range???
22709 C := Get_String_Char (S, Pos (J));
22711 -- This is a weird test, it skips setting validity
22712 -- checks entirely if any element of S is out of
22713 -- range of Character, what is that about ???
22715 exit when not In_Character_Range (C);
22716 Options (J) := Get_Character (C);
22719 Set_Validity_Check_Options (Options);
22727 elsif Nkind (A) = N_Identifier then
22728 if Chars (A) = Name_All_Checks then
22729 Set_Validity_Check_Options ("a");
22730 elsif Chars (A) = Name_On then
22731 Validity_Checks_On := True;
22732 elsif Chars (A) = Name_Off then
22733 Validity_Checks_On := False;
22737 end Validity_Checks;
22743 -- pragma Volatile (LOCAL_NAME);
22745 when Pragma_Volatile =>
22746 Process_Atomic_Independent_Shared_Volatile;
22748 -------------------------
22749 -- Volatile_Components --
22750 -------------------------
22752 -- pragma Volatile_Components (array_LOCAL_NAME);
22754 -- Volatile is handled by the same circuit as Atomic_Components
22756 --------------------------
22757 -- Volatile_Full_Access --
22758 --------------------------
22760 -- pragma Volatile_Full_Access (LOCAL_NAME);
22762 when Pragma_Volatile_Full_Access =>
22764 Process_Atomic_Independent_Shared_Volatile;
22766 -----------------------
22767 -- Volatile_Function --
22768 -----------------------
22770 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22772 when Pragma_Volatile_Function => Volatile_Function : declare
22773 Over_Id : Entity_Id;
22774 Spec_Id : Entity_Id;
22775 Subp_Decl : Node_Id;
22779 Check_No_Identifiers;
22780 Check_At_Most_N_Arguments (1);
22783 Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22785 -- Generic subprogram
22787 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22790 -- Body acts as spec
22792 elsif Nkind (Subp_Decl) = N_Subprogram_Body
22793 and then No (Corresponding_Spec (Subp_Decl))
22797 -- Body stub acts as spec
22799 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22800 and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22806 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22814 Spec_Id := Unique_Defining_Entity (Subp_Decl);
22816 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22821 -- Chain the pragma on the contract for completeness
22823 Add_Contract_Item (N, Spec_Id);
22825 -- The legality checks of pragma Volatile_Function are affected by
22826 -- the SPARK mode in effect. Analyze all pragmas in a specific
22829 Analyze_If_Present (Pragma_SPARK_Mode);
22831 -- A pragma that applies to a Ghost entity becomes Ghost for the
22832 -- purposes of legality checks and removal of ignored Ghost code.
22834 Mark_Pragma_As_Ghost (N, Spec_Id);
22836 -- A volatile function cannot override a non-volatile function
22837 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22838 -- in New_Overloaded_Entity, however at that point the pragma has
22839 -- not been processed yet.
22841 Over_Id := Overridden_Operation (Spec_Id);
22843 if Present (Over_Id)
22844 and then not Is_Volatile_Function (Over_Id)
22847 ("incompatible volatile function values in effect", Spec_Id);
22849 Error_Msg_Sloc := Sloc (Over_Id);
22851 ("\& declared # with Volatile_Function value False",
22854 Error_Msg_Sloc := Sloc (Spec_Id);
22856 ("\overridden # with Volatile_Function value True",
22860 -- Analyze the Boolean expression (if any)
22862 if Present (Arg1) then
22863 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22865 end Volatile_Function;
22867 ----------------------
22868 -- Warning_As_Error --
22869 ----------------------
22871 -- pragma Warning_As_Error (static_string_EXPRESSION);
22873 when Pragma_Warning_As_Error =>
22875 Check_Arg_Count (1);
22876 Check_No_Identifiers;
22877 Check_Valid_Configuration_Pragma;
22879 if not Is_Static_String_Expression (Arg1) then
22881 ("argument of pragma% must be static string expression",
22884 -- OK static string expression
22887 Acquire_Warning_Match_String (Arg1);
22888 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
22889 Warnings_As_Errors (Warnings_As_Errors_Count) :=
22890 new String'(Name_Buffer (1 .. Name_Len));
22897 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22899 -- DETAILS ::= On | Off
22900 -- DETAILS ::= On | Off, local_NAME
22901 -- DETAILS ::= static_string_EXPRESSION
22902 -- DETAILS ::= On | Off, static_string_EXPRESSION
22904 -- TOOL_NAME ::= GNAT | GNATProve
22906 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22908 -- Note: If the first argument matches an allowed tool name, it is
22909 -- always considered to be a tool name, even if there is a string
22910 -- variable of that name.
22912 -- Note if the second argument of DETAILS is a local_NAME then the
22913 -- second form is always understood. If the intention is to use
22914 -- the fourth form, then you can write NAME & "" to force the
22915 -- intepretation as a static_string_EXPRESSION.
22917 when Pragma_Warnings => Warnings : declare
22918 Reason : String_Id;
22922 Check_At_Least_N_Arguments (1);
22924 -- See if last argument is labeled Reason. If so, make sure we
22925 -- have a string literal or a concatenation of string literals,
22926 -- and acquire the REASON string. Then remove the REASON argument
22927 -- by decreasing Num_Args by one; Remaining processing looks only
22928 -- at first Num_Args arguments).
22931 Last_Arg : constant Node_Id :=
22932 Last (Pragma_Argument_Associations (N));
22935 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22936 and then Chars (Last_Arg) = Name_Reason
22939 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22940 Reason := End_String;
22941 Arg_Count := Arg_Count - 1;
22943 -- Not allowed in compiler units (bootstrap issues)
22945 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22947 -- No REASON string, set null string as reason
22950 Reason := Null_String_Id;
22954 -- Now proceed with REASON taken care of and eliminated
22956 Check_No_Identifiers;
22958 -- If debug flag -gnatd.i is set, pragma is ignored
22960 if Debug_Flag_Dot_I then
22964 -- Process various forms of the pragma
22967 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22968 Shifted_Args : List_Id;
22971 -- See if first argument is a tool name, currently either
22972 -- GNAT or GNATprove. If so, either ignore the pragma if the
22973 -- tool used does not match, or continue as if no tool name
22974 -- was given otherwise, by shifting the arguments.
22976 if Nkind (Argx) = N_Identifier
22977 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22979 if Chars (Argx) = Name_Gnat then
22980 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22981 Rewrite (N, Make_Null_Statement (Loc));
22986 elsif Chars (Argx) = Name_Gnatprove then
22987 if not GNATprove_Mode then
22988 Rewrite (N, Make_Null_Statement (Loc));
22994 raise Program_Error;
22997 -- At this point, the pragma Warnings applies to the tool,
22998 -- so continue with shifted arguments.
23000 Arg_Count := Arg_Count - 1;
23002 if Arg_Count = 1 then
23003 Shifted_Args := New_List (New_Copy (Arg2));
23004 elsif Arg_Count = 2 then
23005 Shifted_Args := New_List (New_Copy (Arg2),
23007 elsif Arg_Count = 3 then
23008 Shifted_Args := New_List (New_Copy (Arg2),
23012 raise Program_Error;
23017 Chars => Name_Warnings,
23018 Pragma_Argument_Associations => Shifted_Args));
23023 -- One argument case
23025 if Arg_Count = 1 then
23027 -- On/Off one argument case was processed by parser
23029 if Nkind (Argx) = N_Identifier
23030 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23034 -- One argument case must be ON/OFF or static string expr
23036 elsif not Is_Static_String_Expression (Arg1) then
23038 ("argument of pragma% must be On/Off or static string "
23039 & "expression", Arg1);
23041 -- One argument string expression case
23045 Lit : constant Node_Id := Expr_Value_S (Argx);
23046 Str : constant String_Id := Strval (Lit);
23047 Len : constant Nat := String_Length (Str);
23055 while J <= Len loop
23056 C := Get_String_Char (Str, J);
23057 OK := In_Character_Range (C);
23060 Chr := Get_Character (C);
23062 -- Dash case: only -Wxxx is accepted
23069 C := Get_String_Char (Str, J);
23070 Chr := Get_Character (C);
23071 exit when Chr = 'W';
23076 elsif J < Len and then Chr = '.' then
23078 C := Get_String_Char (Str, J);
23079 Chr := Get_Character (C);
23081 if not Set_Dot_Warning_Switch (Chr) then
23083 ("invalid warning switch character "
23084 & '.' & Chr, Arg1);
23090 OK := Set_Warning_Switch (Chr);
23096 ("invalid warning switch character " & Chr,
23105 -- Two or more arguments (must be two)
23108 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23109 Check_Arg_Count (2);
23117 E_Id := Get_Pragma_Arg (Arg2);
23120 -- In the expansion of an inlined body, a reference to
23121 -- the formal may be wrapped in a conversion if the
23122 -- actual is a conversion. Retrieve the real entity name.
23124 if (In_Instance_Body or In_Inlined_Body)
23125 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23127 E_Id := Expression (E_Id);
23130 -- Entity name case
23132 if Is_Entity_Name (E_Id) then
23133 E := Entity (E_Id);
23140 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23143 -- For OFF case, make entry in warnings off
23144 -- pragma table for later processing. But we do
23145 -- not do that within an instance, since these
23146 -- warnings are about what is needed in the
23147 -- template, not an instance of it.
23149 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23150 and then Warn_On_Warnings_Off
23151 and then not In_Instance
23153 Warnings_Off_Pragmas.Append ((N, E, Reason));
23156 if Is_Enumeration_Type (E) then
23160 Lit := First_Literal (E);
23161 while Present (Lit) loop
23162 Set_Warnings_Off (Lit);
23163 Next_Literal (Lit);
23168 exit when No (Homonym (E));
23173 -- Error if not entity or static string expression case
23175 elsif not Is_Static_String_Expression (Arg2) then
23177 ("second argument of pragma% must be entity name "
23178 & "or static string expression", Arg2);
23180 -- Static string expression case
23183 Acquire_Warning_Match_String (Arg2);
23185 -- Note on configuration pragma case: If this is a
23186 -- configuration pragma, then for an OFF pragma, we
23187 -- just set Config True in the call, which is all
23188 -- that needs to be done. For the case of ON, this
23189 -- is normally an error, unless it is canceling the
23190 -- effect of a previous OFF pragma in the same file.
23191 -- In any other case, an error will be signalled (ON
23192 -- with no matching OFF).
23194 -- Note: We set Used if we are inside a generic to
23195 -- disable the test that the non-config case actually
23196 -- cancels a warning. That's because we can't be sure
23197 -- there isn't an instantiation in some other unit
23198 -- where a warning is suppressed.
23200 -- We could do a little better here by checking if the
23201 -- generic unit we are inside is public, but for now
23202 -- we don't bother with that refinement.
23204 if Chars (Argx) = Name_Off then
23205 Set_Specific_Warning_Off
23206 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23207 Config => Is_Configuration_Pragma,
23208 Used => Inside_A_Generic or else In_Instance);
23210 elsif Chars (Argx) = Name_On then
23211 Set_Specific_Warning_On
23212 (Loc, Name_Buffer (1 .. Name_Len), Err);
23216 ("??pragma Warnings On with no matching "
23217 & "Warnings Off", Loc);
23226 -------------------
23227 -- Weak_External --
23228 -------------------
23230 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23232 when Pragma_Weak_External => Weak_External : declare
23237 Check_Arg_Count (1);
23238 Check_Optional_Identifier (Arg1, Name_Entity);
23239 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23240 Ent := Entity (Get_Pragma_Arg (Arg1));
23242 if Rep_Item_Too_Early (Ent, N) then
23245 Ent := Underlying_Type (Ent);
23248 -- The only processing required is to link this item on to the
23249 -- list of rep items for the given entity. This is accomplished
23250 -- by the call to Rep_Item_Too_Late (when no error is detected
23251 -- and False is returned).
23253 if Rep_Item_Too_Late (Ent, N) then
23256 Set_Has_Gigi_Rep_Item (Ent);
23260 -----------------------------
23261 -- Wide_Character_Encoding --
23262 -----------------------------
23264 -- pragma Wide_Character_Encoding (IDENTIFIER);
23266 when Pragma_Wide_Character_Encoding =>
23269 -- Nothing to do, handled in parser. Note that we do not enforce
23270 -- configuration pragma placement, this pragma can appear at any
23271 -- place in the source, allowing mixed encodings within a single
23276 --------------------
23277 -- Unknown_Pragma --
23278 --------------------
23280 -- Should be impossible, since the case of an unknown pragma is
23281 -- separately processed before the case statement is entered.
23283 when Unknown_Pragma =>
23284 raise Program_Error;
23287 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23288 -- until AI is formally approved.
23290 -- Check_Order_Dependence;
23293 when Pragma_Exit => null;
23294 end Analyze_Pragma;
23296 ---------------------------------------------
23297 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23298 ---------------------------------------------
23300 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23302 Freeze_Id : Entity_Id := Empty)
23304 Disp_Typ : Entity_Id;
23305 -- The dispatching type of the subprogram subject to the pre- or
23308 function Check_References (Nod : Node_Id) return Traverse_Result;
23309 -- Check that expression Nod does not mention non-primitives of the
23310 -- type, global objects of the type, or other illegalities described
23311 -- and implied by AI12-0113.
23313 ----------------------
23314 -- Check_References --
23315 ----------------------
23317 function Check_References (Nod : Node_Id) return Traverse_Result is
23319 if Nkind (Nod) = N_Function_Call
23320 and then Is_Entity_Name (Name (Nod))
23323 Func : constant Entity_Id := Entity (Name (Nod));
23327 -- An operation of the type must be a primitive
23329 if No (Find_Dispatching_Type (Func)) then
23330 Form := First_Formal (Func);
23331 while Present (Form) loop
23332 if Etype (Form) = Disp_Typ then
23334 ("operation in class-wide condition must be "
23335 & "primitive of &", Nod, Disp_Typ);
23338 Next_Formal (Form);
23341 -- A return object of the type is illegal as well
23343 if Etype (Func) = Disp_Typ
23344 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23347 ("operation in class-wide condition must be primitive "
23348 & "of &", Nod, Disp_Typ);
23353 elsif Is_Entity_Name (Nod)
23355 (Etype (Nod) = Disp_Typ
23356 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23357 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23360 ("object in class-wide condition must be formal of type &",
23363 elsif Nkind (Nod) = N_Explicit_Dereference
23364 and then (Etype (Nod) = Disp_Typ
23365 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23366 and then (not Is_Entity_Name (Prefix (Nod))
23367 or else not Is_Formal (Entity (Prefix (Nod))))
23370 ("operation in class-wide condition must be primitive of &",
23375 end Check_References;
23377 procedure Check_Class_Wide_Condition is
23378 new Traverse_Proc (Check_References);
23382 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23383 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23384 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23386 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23389 Restore_Scope : Boolean := False;
23391 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23394 -- Do not analyze the pragma multiple times
23396 if Is_Analyzed_Pragma (N) then
23400 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23401 -- analysis of the pragma, the Ghost mode at point of declaration and
23402 -- point of analysis may not necessarily be the same. Use the mode in
23403 -- effect at the point of declaration.
23405 Set_Ghost_Mode (N);
23407 -- Ensure that the subprogram and its formals are visible when analyzing
23408 -- the expression of the pragma.
23410 if not In_Open_Scopes (Spec_Id) then
23411 Restore_Scope := True;
23412 Push_Scope (Spec_Id);
23414 if Is_Generic_Subprogram (Spec_Id) then
23415 Install_Generic_Formals (Spec_Id);
23417 Install_Formals (Spec_Id);
23421 Errors := Serious_Errors_Detected;
23422 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23424 -- Emit a clarification message when the expression contains at least
23425 -- one undefined reference, possibly due to contract "freezing".
23427 if Errors /= Serious_Errors_Detected
23428 and then Present (Freeze_Id)
23429 and then Has_Undefined_Reference (Expr)
23431 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23434 if Class_Present (N) then
23436 -- Verify that a class-wide condition is legal, i.e. the operation is
23437 -- a primitive of a tagged type. Note that a generic subprogram is
23438 -- not a primitive operation.
23440 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23442 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23443 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23445 if From_Aspect_Specification (N) then
23447 ("aspect % can only be specified for a primitive operation "
23448 & "of a tagged type", Corresponding_Aspect (N));
23450 -- The pragma is a source construct
23454 ("pragma % can only be specified for a primitive operation "
23455 & "of a tagged type", N);
23458 -- Remaining semantic checks require a full tree traversal
23461 Check_Class_Wide_Condition (Expr);
23466 if Restore_Scope then
23470 -- Currently it is not possible to inline pre/postconditions on a
23471 -- subprogram subject to pragma Inline_Always.
23473 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23474 Ghost_Mode := Save_Ghost_Mode;
23476 Set_Is_Analyzed_Pragma (N);
23477 end Analyze_Pre_Post_Condition_In_Decl_Part;
23479 ------------------------------------------
23480 -- Analyze_Refined_Depends_In_Decl_Part --
23481 ------------------------------------------
23483 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23484 Body_Inputs : Elist_Id := No_Elist;
23485 Body_Outputs : Elist_Id := No_Elist;
23486 -- The inputs and outputs of the subprogram body synthesized from pragma
23487 -- Refined_Depends.
23489 Dependencies : List_Id := No_List;
23491 -- The corresponding Depends pragma along with its clauses
23493 Matched_Items : Elist_Id := No_Elist;
23494 -- A list containing the entities of all successfully matched items
23495 -- found in pragma Depends.
23497 Refinements : List_Id := No_List;
23498 -- The clauses of pragma Refined_Depends
23500 Spec_Id : Entity_Id;
23501 -- The entity of the subprogram subject to pragma Refined_Depends
23503 Spec_Inputs : Elist_Id := No_Elist;
23504 Spec_Outputs : Elist_Id := No_Elist;
23505 -- The inputs and outputs of the subprogram spec synthesized from pragma
23508 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23509 -- Try to match a single dependency clause Dep_Clause against one or
23510 -- more refinement clauses found in list Refinements. Each successful
23511 -- match eliminates at least one refinement clause from Refinements.
23513 procedure Check_Output_States;
23514 -- Determine whether pragma Depends contains an output state with a
23515 -- visible refinement and if so, ensure that pragma Refined_Depends
23516 -- mentions all its constituents as outputs.
23518 procedure Normalize_Clauses (Clauses : List_Id);
23519 -- Given a list of dependence or refinement clauses Clauses, normalize
23520 -- each clause by creating multiple dependencies with exactly one input
23523 procedure Report_Extra_Clauses;
23524 -- Emit an error for each extra clause found in list Refinements
23526 -----------------------------
23527 -- Check_Dependency_Clause --
23528 -----------------------------
23530 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23531 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23532 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23534 function Is_In_Out_State_Clause return Boolean;
23535 -- Determine whether dependence clause Dep_Clause denotes an abstract
23536 -- state that depends on itself (State => State).
23538 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23539 -- Determine whether item Item denotes an abstract state with visible
23540 -- null refinement.
23542 procedure Match_Items
23543 (Dep_Item : Node_Id;
23544 Ref_Item : Node_Id;
23545 Matched : out Boolean);
23546 -- Try to match dependence item Dep_Item against refinement item
23547 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23548 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23549 -- the following conformance scenarios is in effect:
23550 -- 1) Both items denote null
23551 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23552 -- 3) Both items denote attribute 'Result
23553 -- 4) Both items denote the same object
23554 -- 5) Both items denote the same formal parameter
23555 -- 6) Both items denote the same current instance of a type
23556 -- 7) Both items denote the same discriminant
23557 -- 8) Dep_Item is an abstract state with visible null refinement
23558 -- and Ref_Item denotes null.
23559 -- 9) Dep_Item is an abstract state with visible null refinement
23560 -- and Ref_Item is Empty (special case).
23561 -- 10) Dep_Item is an abstract state with visible non-null
23562 -- refinement and Ref_Item denotes one of its constituents.
23563 -- 11) Dep_Item is an abstract state without a visible refinement
23564 -- and Ref_Item denotes the same state.
23565 -- When scenario 10 is in effect, the entity of the abstract state
23566 -- denoted by Dep_Item is added to list Refined_States.
23568 procedure Record_Item (Item_Id : Entity_Id);
23569 -- Store the entity of an item denoted by Item_Id in Matched_Items
23571 ----------------------------
23572 -- Is_In_Out_State_Clause --
23573 ----------------------------
23575 function Is_In_Out_State_Clause return Boolean is
23576 Dep_Input_Id : Entity_Id;
23577 Dep_Output_Id : Entity_Id;
23580 -- Detect the following clause:
23583 if Is_Entity_Name (Dep_Input)
23584 and then Is_Entity_Name (Dep_Output)
23586 -- Handle abstract views generated for limited with clauses
23588 Dep_Input_Id := Available_View (Entity_Of (Dep_Input));
23589 Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23592 Ekind (Dep_Input_Id) = E_Abstract_State
23593 and then Dep_Input_Id = Dep_Output_Id;
23597 end Is_In_Out_State_Clause;
23599 ---------------------------
23600 -- Is_Null_Refined_State --
23601 ---------------------------
23603 function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23604 Item_Id : Entity_Id;
23607 if Is_Entity_Name (Item) then
23609 -- Handle abstract views generated for limited with clauses
23611 Item_Id := Available_View (Entity_Of (Item));
23614 Ekind (Item_Id) = E_Abstract_State
23615 and then Has_Null_Visible_Refinement (Item_Id);
23619 end Is_Null_Refined_State;
23625 procedure Match_Items
23626 (Dep_Item : Node_Id;
23627 Ref_Item : Node_Id;
23628 Matched : out Boolean)
23630 Dep_Item_Id : Entity_Id;
23631 Ref_Item_Id : Entity_Id;
23634 -- Assume that the two items do not match
23638 -- A null matches null or Empty (special case)
23640 if Nkind (Dep_Item) = N_Null
23641 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23645 -- Attribute 'Result matches attribute 'Result
23647 elsif Is_Attribute_Result (Dep_Item)
23648 and then Is_Attribute_Result (Dep_Item)
23652 -- Abstract states, current instances of concurrent types,
23653 -- discriminants, formal parameters and objects.
23655 elsif Is_Entity_Name (Dep_Item) then
23657 -- Handle abstract views generated for limited with clauses
23659 Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23661 if Ekind (Dep_Item_Id) = E_Abstract_State then
23663 -- An abstract state with visible null refinement matches
23664 -- null or Empty (special case).
23666 if Has_Null_Visible_Refinement (Dep_Item_Id)
23667 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23669 Record_Item (Dep_Item_Id);
23672 -- An abstract state with visible non-null refinement
23673 -- matches one of its constituents.
23675 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
23676 if Is_Entity_Name (Ref_Item) then
23677 Ref_Item_Id := Entity_Of (Ref_Item);
23679 if Ekind_In (Ref_Item_Id, E_Abstract_State,
23682 and then Present (Encapsulating_State (Ref_Item_Id))
23683 and then Encapsulating_State (Ref_Item_Id) =
23686 Record_Item (Dep_Item_Id);
23691 -- An abstract state without a visible refinement matches
23694 elsif Is_Entity_Name (Ref_Item)
23695 and then Entity_Of (Ref_Item) = Dep_Item_Id
23697 Record_Item (Dep_Item_Id);
23701 -- A current instance of a concurrent type, discriminant,
23702 -- formal parameter or an object matches itself.
23704 elsif Is_Entity_Name (Ref_Item)
23705 and then Entity_Of (Ref_Item) = Dep_Item_Id
23707 Record_Item (Dep_Item_Id);
23717 procedure Record_Item (Item_Id : Entity_Id) is
23719 if not Contains (Matched_Items, Item_Id) then
23720 Append_New_Elmt (Item_Id, Matched_Items);
23726 Clause_Matched : Boolean := False;
23727 Dummy : Boolean := False;
23728 Inputs_Match : Boolean;
23729 Next_Ref_Clause : Node_Id;
23730 Outputs_Match : Boolean;
23731 Ref_Clause : Node_Id;
23732 Ref_Input : Node_Id;
23733 Ref_Output : Node_Id;
23735 -- Start of processing for Check_Dependency_Clause
23738 -- Do not perform this check in an instance because it was already
23739 -- performed successfully in the generic template.
23741 if Is_Generic_Instance (Spec_Id) then
23745 -- Examine all refinement clauses and compare them against the
23746 -- dependence clause.
23748 Ref_Clause := First (Refinements);
23749 while Present (Ref_Clause) loop
23750 Next_Ref_Clause := Next (Ref_Clause);
23752 -- Obtain the attributes of the current refinement clause
23754 Ref_Input := Expression (Ref_Clause);
23755 Ref_Output := First (Choices (Ref_Clause));
23757 -- The current refinement clause matches the dependence clause
23758 -- when both outputs match and both inputs match. See routine
23759 -- Match_Items for all possible conformance scenarios.
23761 -- Depends Dep_Output => Dep_Input
23765 -- Refined_Depends Ref_Output => Ref_Input
23768 (Dep_Item => Dep_Input,
23769 Ref_Item => Ref_Input,
23770 Matched => Inputs_Match);
23773 (Dep_Item => Dep_Output,
23774 Ref_Item => Ref_Output,
23775 Matched => Outputs_Match);
23777 -- An In_Out state clause may be matched against a refinement with
23778 -- a null input or null output as long as the non-null side of the
23779 -- relation contains a valid constituent of the In_Out_State.
23781 if Is_In_Out_State_Clause then
23783 -- Depends => (State => State)
23784 -- Refined_Depends => (null => Constit) -- OK
23787 and then not Outputs_Match
23788 and then Nkind (Ref_Output) = N_Null
23790 Outputs_Match := True;
23793 -- Depends => (State => State)
23794 -- Refined_Depends => (Constit => null) -- OK
23796 if not Inputs_Match
23797 and then Outputs_Match
23798 and then Nkind (Ref_Input) = N_Null
23800 Inputs_Match := True;
23804 -- The current refinement clause is legally constructed following
23805 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23806 -- the pool of candidates. The seach continues because a single
23807 -- dependence clause may have multiple matching refinements.
23809 if Inputs_Match and Outputs_Match then
23810 Clause_Matched := True;
23811 Remove (Ref_Clause);
23814 Ref_Clause := Next_Ref_Clause;
23817 -- Depending on the order or composition of refinement clauses, an
23818 -- In_Out state clause may not be directly refinable.
23820 -- Depends => ((Output, State) => (Input, State))
23821 -- Refined_State => (State => (Constit_1, Constit_2))
23822 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23824 -- Matching normalized clause (State => State) fails because there is
23825 -- no direct refinement capable of satisfying this relation. Another
23826 -- similar case arises when clauses (Constit_1 => Input) and (Output
23827 -- => Constit_2) are matched first, leaving no candidates for clause
23828 -- (State => State). Both scenarios are legal as long as one of the
23829 -- previous clauses mentioned a valid constituent of State.
23831 if not Clause_Matched
23832 and then Is_In_Out_State_Clause
23834 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23836 Clause_Matched := True;
23839 -- A clause where the input is an abstract state with visible null
23840 -- refinement is implicitly matched when the output has already been
23841 -- matched in a previous clause.
23843 -- Depends => (Output => State) -- implicitly OK
23844 -- Refined_State => (State => null)
23845 -- Refined_Depends => (Output => ...)
23847 if not Clause_Matched
23848 and then Is_Null_Refined_State (Dep_Input)
23849 and then Is_Entity_Name (Dep_Output)
23851 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23853 Clause_Matched := True;
23856 -- A clause where the output is an abstract state with visible null
23857 -- refinement is implicitly matched when the input has already been
23858 -- matched in a previous clause.
23860 -- Depends => (State => Input) -- implicitly OK
23861 -- Refined_State => (State => null)
23862 -- Refined_Depends => (... => Input)
23864 if not Clause_Matched
23865 and then Is_Null_Refined_State (Dep_Output)
23866 and then Is_Entity_Name (Dep_Input)
23868 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23870 Clause_Matched := True;
23873 -- At this point either all refinement clauses have been examined or
23874 -- pragma Refined_Depends contains a solitary null. Only an abstract
23875 -- state with null refinement can possibly match these cases.
23877 -- Depends => (State => null)
23878 -- Refined_State => (State => null)
23879 -- Refined_Depends => null -- OK
23881 if not Clause_Matched then
23883 (Dep_Item => Dep_Input,
23885 Matched => Inputs_Match);
23888 (Dep_Item => Dep_Output,
23890 Matched => Outputs_Match);
23892 Clause_Matched := Inputs_Match and Outputs_Match;
23895 -- If the contents of Refined_Depends are legal, then the current
23896 -- dependence clause should be satisfied either by an explicit match
23897 -- or by one of the special cases.
23899 if not Clause_Matched then
23901 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
23902 & "matching refinement in body"), Dep_Clause, Spec_Id);
23904 end Check_Dependency_Clause;
23906 -------------------------
23907 -- Check_Output_States --
23908 -------------------------
23910 procedure Check_Output_States is
23911 procedure Check_Constituent_Usage (State_Id : Entity_Id);
23912 -- Determine whether all constituents of state State_Id with visible
23913 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23914 -- error if this is not the case.
23916 -----------------------------
23917 -- Check_Constituent_Usage --
23918 -----------------------------
23920 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
23921 Constits : constant Elist_Id :=
23922 Refinement_Constituents (State_Id);
23923 Constit_Elmt : Elmt_Id;
23924 Constit_Id : Entity_Id;
23925 Posted : Boolean := False;
23928 if Present (Constits) then
23929 Constit_Elmt := First_Elmt (Constits);
23930 while Present (Constit_Elmt) loop
23931 Constit_Id := Node (Constit_Elmt);
23933 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23935 if Present (Body_Inputs)
23936 and then Appears_In (Body_Inputs, Constit_Id)
23938 Error_Msg_Name_1 := Chars (State_Id);
23940 ("constituent & of state % must act as output in "
23941 & "dependence refinement", N, Constit_Id);
23943 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23945 elsif No (Body_Outputs)
23946 or else not Appears_In (Body_Outputs, Constit_Id)
23951 ("output state & must be replaced by all its "
23952 & "constituents in dependence refinement",
23957 ("\constituent & is missing in output list",
23961 Next_Elmt (Constit_Elmt);
23964 end Check_Constituent_Usage;
23969 Item_Elmt : Elmt_Id;
23970 Item_Id : Entity_Id;
23972 -- Start of processing for Check_Output_States
23975 -- Do not perform this check in an instance because it was already
23976 -- performed successfully in the generic template.
23978 if Is_Generic_Instance (Spec_Id) then
23981 -- Inspect the outputs of pragma Depends looking for a state with a
23982 -- visible refinement.
23984 elsif Present (Spec_Outputs) then
23985 Item_Elmt := First_Elmt (Spec_Outputs);
23986 while Present (Item_Elmt) loop
23987 Item := Node (Item_Elmt);
23989 -- Deal with the mixed nature of the input and output lists
23991 if Nkind (Item) = N_Defining_Identifier then
23994 Item_Id := Available_View (Entity_Of (Item));
23997 if Ekind (Item_Id) = E_Abstract_State then
23999 -- The state acts as an input-output, skip it
24001 if Present (Spec_Inputs)
24002 and then Appears_In (Spec_Inputs, Item_Id)
24006 -- Ensure that all of the constituents are utilized as
24007 -- outputs in pragma Refined_Depends.
24009 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24010 Check_Constituent_Usage (Item_Id);
24014 Next_Elmt (Item_Elmt);
24017 end Check_Output_States;
24019 -----------------------
24020 -- Normalize_Clauses --
24021 -----------------------
24023 procedure Normalize_Clauses (Clauses : List_Id) is
24024 procedure Normalize_Inputs (Clause : Node_Id);
24025 -- Normalize clause Clause by creating multiple clauses for each
24026 -- input item of Clause. It is assumed that Clause has exactly one
24027 -- output. The transformation is as follows:
24029 -- Output => (Input_1, Input_2) -- original
24031 -- Output => Input_1 -- normalizations
24032 -- Output => Input_2
24034 procedure Normalize_Outputs (Clause : Node_Id);
24035 -- Normalize clause Clause by creating multiple clause for each
24036 -- output item of Clause. The transformation is as follows:
24038 -- (Output_1, Output_2) => Input -- original
24040 -- Output_1 => Input -- normalization
24041 -- Output_2 => Input
24043 ----------------------
24044 -- Normalize_Inputs --
24045 ----------------------
24047 procedure Normalize_Inputs (Clause : Node_Id) is
24048 Inputs : constant Node_Id := Expression (Clause);
24049 Loc : constant Source_Ptr := Sloc (Clause);
24050 Output : constant List_Id := Choices (Clause);
24051 Last_Input : Node_Id;
24053 New_Clause : Node_Id;
24054 Next_Input : Node_Id;
24057 -- Normalization is performed only when the original clause has
24058 -- more than one input. Multiple inputs appear as an aggregate.
24060 if Nkind (Inputs) = N_Aggregate then
24061 Last_Input := Last (Expressions (Inputs));
24063 -- Create a new clause for each input
24065 Input := First (Expressions (Inputs));
24066 while Present (Input) loop
24067 Next_Input := Next (Input);
24069 -- Unhook the current input from the original input list
24070 -- because it will be relocated to a new clause.
24074 -- Special processing for the last input. At this point the
24075 -- original aggregate has been stripped down to one element.
24076 -- Replace the aggregate by the element itself.
24078 if Input = Last_Input then
24079 Rewrite (Inputs, Input);
24081 -- Generate a clause of the form:
24086 Make_Component_Association (Loc,
24087 Choices => New_Copy_List_Tree (Output),
24088 Expression => Input);
24090 -- The new clause contains replicated content that has
24091 -- already been analyzed, mark the clause as analyzed.
24093 Set_Analyzed (New_Clause);
24094 Insert_After (Clause, New_Clause);
24097 Input := Next_Input;
24100 end Normalize_Inputs;
24102 -----------------------
24103 -- Normalize_Outputs --
24104 -----------------------
24106 procedure Normalize_Outputs (Clause : Node_Id) is
24107 Inputs : constant Node_Id := Expression (Clause);
24108 Loc : constant Source_Ptr := Sloc (Clause);
24109 Outputs : constant Node_Id := First (Choices (Clause));
24110 Last_Output : Node_Id;
24111 New_Clause : Node_Id;
24112 Next_Output : Node_Id;
24116 -- Multiple outputs appear as an aggregate. Nothing to do when
24117 -- the clause has exactly one output.
24119 if Nkind (Outputs) = N_Aggregate then
24120 Last_Output := Last (Expressions (Outputs));
24122 -- Create a clause for each output. Note that each time a new
24123 -- clause is created, the original output list slowly shrinks
24124 -- until there is one item left.
24126 Output := First (Expressions (Outputs));
24127 while Present (Output) loop
24128 Next_Output := Next (Output);
24130 -- Unhook the output from the original output list as it
24131 -- will be relocated to a new clause.
24135 -- Special processing for the last output. At this point
24136 -- the original aggregate has been stripped down to one
24137 -- element. Replace the aggregate by the element itself.
24139 if Output = Last_Output then
24140 Rewrite (Outputs, Output);
24143 -- Generate a clause of the form:
24144 -- (Output => Inputs)
24147 Make_Component_Association (Loc,
24148 Choices => New_List (Output),
24149 Expression => New_Copy_Tree (Inputs));
24151 -- The new clause contains replicated content that has
24152 -- already been analyzed. There is not need to reanalyze
24155 Set_Analyzed (New_Clause);
24156 Insert_After (Clause, New_Clause);
24159 Output := Next_Output;
24162 end Normalize_Outputs;
24168 -- Start of processing for Normalize_Clauses
24171 Clause := First (Clauses);
24172 while Present (Clause) loop
24173 Normalize_Outputs (Clause);
24177 Clause := First (Clauses);
24178 while Present (Clause) loop
24179 Normalize_Inputs (Clause);
24182 end Normalize_Clauses;
24184 --------------------------
24185 -- Report_Extra_Clauses --
24186 --------------------------
24188 procedure Report_Extra_Clauses is
24192 -- Do not perform this check in an instance because it was already
24193 -- performed successfully in the generic template.
24195 if Is_Generic_Instance (Spec_Id) then
24198 elsif Present (Refinements) then
24199 Clause := First (Refinements);
24200 while Present (Clause) loop
24202 -- Do not complain about a null input refinement, since a null
24203 -- input legitimately matches anything.
24205 if Nkind (Clause) = N_Component_Association
24206 and then Nkind (Expression (Clause)) = N_Null
24212 ("unmatched or extra clause in dependence refinement",
24219 end Report_Extra_Clauses;
24223 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24224 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
24225 Errors : constant Nat := Serious_Errors_Detected;
24231 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24234 -- Do not analyze the pragma multiple times
24236 if Is_Analyzed_Pragma (N) then
24240 Spec_Id := Unique_Defining_Entity (Body_Decl);
24242 -- Use the anonymous object as the proper spec when Refined_Depends
24243 -- applies to the body of a single task type. The object carries the
24244 -- proper Chars as well as all non-refined versions of pragmas.
24246 if Is_Single_Concurrent_Type (Spec_Id) then
24247 Spec_Id := Anonymous_Object (Spec_Id);
24250 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
24252 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24253 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24255 if No (Depends) then
24257 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24258 & "& lacks aspect or pragma Depends"), N, Spec_Id);
24262 Deps := Expression (Get_Argument (Depends, Spec_Id));
24264 -- A null dependency relation renders the refinement useless because it
24265 -- cannot possibly mention abstract states with visible refinement. Note
24266 -- that the inverse is not true as states may be refined to null
24267 -- (SPARK RM 7.2.5(2)).
24269 if Nkind (Deps) = N_Null then
24271 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24272 & "depend on abstract state with visible refinement"), N, Spec_Id);
24276 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24277 -- This ensures that the categorization of all refined dependency items
24278 -- is consistent with their role.
24280 Analyze_Depends_In_Decl_Part (N);
24282 -- Do not match dependencies against refinements if Refined_Depends is
24283 -- illegal to avoid emitting misleading error.
24285 if Serious_Errors_Detected = Errors then
24287 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24288 -- the inputs and outputs of the subprogram spec and body to verify
24289 -- the use of states with visible refinement and their constituents.
24291 if No (Get_Pragma (Spec_Id, Pragma_Global))
24292 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
24294 Collect_Subprogram_Inputs_Outputs
24295 (Subp_Id => Spec_Id,
24296 Synthesize => True,
24297 Subp_Inputs => Spec_Inputs,
24298 Subp_Outputs => Spec_Outputs,
24299 Global_Seen => Dummy);
24301 Collect_Subprogram_Inputs_Outputs
24302 (Subp_Id => Body_Id,
24303 Synthesize => True,
24304 Subp_Inputs => Body_Inputs,
24305 Subp_Outputs => Body_Outputs,
24306 Global_Seen => Dummy);
24308 -- For an output state with a visible refinement, ensure that all
24309 -- constituents appear as outputs in the dependency refinement.
24311 Check_Output_States;
24314 -- Matching is disabled in ASIS because clauses are not normalized as
24315 -- this is a tree altering activity similar to expansion.
24321 -- Multiple dependency clauses appear as component associations of an
24322 -- aggregate. Note that the clauses are copied because the algorithm
24323 -- modifies them and this should not be visible in Depends.
24325 pragma Assert (Nkind (Deps) = N_Aggregate);
24326 Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
24327 Normalize_Clauses (Dependencies);
24329 Refs := Expression (Get_Argument (N, Spec_Id));
24331 if Nkind (Refs) = N_Null then
24332 Refinements := No_List;
24334 -- Multiple dependency clauses appear as component associations of an
24335 -- aggregate. Note that the clauses are copied because the algorithm
24336 -- modifies them and this should not be visible in Refined_Depends.
24338 else pragma Assert (Nkind (Refs) = N_Aggregate);
24339 Refinements := New_Copy_List_Tree (Component_Associations (Refs));
24340 Normalize_Clauses (Refinements);
24343 -- At this point the clauses of pragmas Depends and Refined_Depends
24344 -- have been normalized into simple dependencies between one output
24345 -- and one input. Examine all clauses of pragma Depends looking for
24346 -- matching clauses in pragma Refined_Depends.
24348 Clause := First (Dependencies);
24349 while Present (Clause) loop
24350 Check_Dependency_Clause (Clause);
24354 if Serious_Errors_Detected = Errors then
24355 Report_Extra_Clauses;
24360 Set_Is_Analyzed_Pragma (N);
24361 end Analyze_Refined_Depends_In_Decl_Part;
24363 -----------------------------------------
24364 -- Analyze_Refined_Global_In_Decl_Part --
24365 -----------------------------------------
24367 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24369 -- The corresponding Global pragma
24371 Has_In_State : Boolean := False;
24372 Has_In_Out_State : Boolean := False;
24373 Has_Out_State : Boolean := False;
24374 Has_Proof_In_State : Boolean := False;
24375 -- These flags are set when the corresponding Global pragma has a state
24376 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24379 Has_Null_State : Boolean := False;
24380 -- This flag is set when the corresponding Global pragma has at least
24381 -- one state with a null refinement.
24383 In_Constits : Elist_Id := No_Elist;
24384 In_Out_Constits : Elist_Id := No_Elist;
24385 Out_Constits : Elist_Id := No_Elist;
24386 Proof_In_Constits : Elist_Id := No_Elist;
24387 -- These lists contain the entities of all Input, In_Out, Output and
24388 -- Proof_In constituents that appear in Refined_Global and participate
24389 -- in state refinement.
24391 In_Items : Elist_Id := No_Elist;
24392 In_Out_Items : Elist_Id := No_Elist;
24393 Out_Items : Elist_Id := No_Elist;
24394 Proof_In_Items : Elist_Id := No_Elist;
24395 -- These list contain the entities of all Input, In_Out, Output and
24396 -- Proof_In items defined in the corresponding Global pragma.
24398 Spec_Id : Entity_Id;
24399 -- The entity of the subprogram subject to pragma Refined_Global
24401 States : Elist_Id := No_Elist;
24402 -- A list of all states with visible refinement found in pragma Global
24404 procedure Check_In_Out_States;
24405 -- Determine whether the corresponding Global pragma mentions In_Out
24406 -- states with visible refinement and if so, ensure that one of the
24407 -- following completions apply to the constituents of the state:
24408 -- 1) there is at least one constituent of mode In_Out
24409 -- 2) there is at least one Input and one Output constituent
24410 -- 3) not all constituents are present and one of them is of mode
24412 -- This routine may remove elements from In_Constits, In_Out_Constits,
24413 -- Out_Constits and Proof_In_Constits.
24415 procedure Check_Input_States;
24416 -- Determine whether the corresponding Global pragma mentions Input
24417 -- states with visible refinement and if so, ensure that at least one of
24418 -- its constituents appears as an Input item in Refined_Global.
24419 -- This routine may remove elements from In_Constits, In_Out_Constits,
24420 -- Out_Constits and Proof_In_Constits.
24422 procedure Check_Output_States;
24423 -- Determine whether the corresponding Global pragma mentions Output
24424 -- states with visible refinement and if so, ensure that all of its
24425 -- constituents appear as Output items in Refined_Global.
24426 -- This routine may remove elements from In_Constits, In_Out_Constits,
24427 -- Out_Constits and Proof_In_Constits.
24429 procedure Check_Proof_In_States;
24430 -- Determine whether the corresponding Global pragma mentions Proof_In
24431 -- states with visible refinement and if so, ensure that at least one of
24432 -- its constituents appears as a Proof_In item in Refined_Global.
24433 -- This routine may remove elements from In_Constits, In_Out_Constits,
24434 -- Out_Constits and Proof_In_Constits.
24436 procedure Check_Refined_Global_List
24438 Global_Mode : Name_Id := Name_Input);
24439 -- Verify the legality of a single global list declaration. Global_Mode
24440 -- denotes the current mode in effect.
24442 procedure Collect_Global_Items
24444 Mode : Name_Id := Name_Input);
24445 -- Gather all input, in out, output and Proof_In items from node List
24446 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24447 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24448 -- and Has_Proof_In_State are set when there is at least one abstract
24449 -- state with visible refinement available in the corresponding mode.
24450 -- Flag Has_Null_State is set when at least state has a null refinement.
24451 -- Mode enotes the current global mode in effect.
24453 function Present_Then_Remove
24455 Item : Entity_Id) return Boolean;
24456 -- Search List for a particular entity Item. If Item has been found,
24457 -- remove it from List. This routine is used to strip lists In_Constits,
24458 -- In_Out_Constits and Out_Constits of valid constituents.
24460 procedure Report_Extra_Constituents;
24461 -- Emit an error for each constituent found in lists In_Constits,
24462 -- In_Out_Constits and Out_Constits.
24464 -------------------------
24465 -- Check_In_Out_States --
24466 -------------------------
24468 procedure Check_In_Out_States is
24469 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24470 -- Determine whether one of the following coverage scenarios is in
24472 -- 1) there is at least one constituent of mode In_Out or Output
24473 -- 2) there is at least one pair of constituents with modes Input
24474 -- and Output, or Proof_In and Output.
24475 -- 3) there is at least one constituent of mode Output and not all
24476 -- constituents are present.
24477 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24479 -----------------------------
24480 -- Check_Constituent_Usage --
24481 -----------------------------
24483 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24484 Constits : constant Elist_Id :=
24485 Refinement_Constituents (State_Id);
24486 Constit_Elmt : Elmt_Id;
24487 Constit_Id : Entity_Id;
24488 Has_Missing : Boolean := False;
24489 In_Out_Seen : Boolean := False;
24490 Input_Seen : Boolean := False;
24491 Output_Seen : Boolean := False;
24492 Proof_In_Seen : Boolean := False;
24495 -- Process all the constituents of the state and note their modes
24496 -- within the global refinement.
24498 if Present (Constits) then
24499 Constit_Elmt := First_Elmt (Constits);
24500 while Present (Constit_Elmt) loop
24501 Constit_Id := Node (Constit_Elmt);
24503 if Present_Then_Remove (In_Constits, Constit_Id) then
24504 Input_Seen := True;
24506 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24507 In_Out_Seen := True;
24509 elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24510 Output_Seen := True;
24512 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24514 Proof_In_Seen := True;
24517 Has_Missing := True;
24520 Next_Elmt (Constit_Elmt);
24524 -- An In_Out constituent is a valid completion
24526 if In_Out_Seen then
24529 -- A pair of one Input/Proof_In and one Output constituent is a
24530 -- valid completion.
24532 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
24535 elsif Output_Seen then
24537 -- A single Output constituent is a valid completion only when
24538 -- some of the other constituents are missing.
24540 if Has_Missing then
24543 -- Otherwise all constituents are of mode Output
24547 ("global refinement of state & must include at least one "
24548 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24552 -- The state lacks a completion
24554 elsif not Input_Seen
24555 and not In_Out_Seen
24556 and not Output_Seen
24557 and not Proof_In_Seen
24560 ("missing global refinement of state &", N, State_Id);
24562 -- Otherwise the state has a malformed completion where at least
24563 -- one of the constituents has a different mode.
24567 ("global refinement of state & redefines the mode of its "
24568 & "constituents", N, State_Id);
24570 end Check_Constituent_Usage;
24574 Item_Elmt : Elmt_Id;
24575 Item_Id : Entity_Id;
24577 -- Start of processing for Check_In_Out_States
24580 -- Do not perform this check in an instance because it was already
24581 -- performed successfully in the generic template.
24583 if Is_Generic_Instance (Spec_Id) then
24586 -- Inspect the In_Out items of the corresponding Global pragma
24587 -- looking for a state with a visible refinement.
24589 elsif Has_In_Out_State and then Present (In_Out_Items) then
24590 Item_Elmt := First_Elmt (In_Out_Items);
24591 while Present (Item_Elmt) loop
24592 Item_Id := Node (Item_Elmt);
24594 -- Ensure that one of the three coverage variants is satisfied
24596 if Ekind (Item_Id) = E_Abstract_State
24597 and then Has_Non_Null_Visible_Refinement (Item_Id)
24599 Check_Constituent_Usage (Item_Id);
24602 Next_Elmt (Item_Elmt);
24605 end Check_In_Out_States;
24607 ------------------------
24608 -- Check_Input_States --
24609 ------------------------
24611 procedure Check_Input_States is
24612 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24613 -- Determine whether at least one constituent of state State_Id with
24614 -- visible refinement is used and has mode Input. Ensure that the
24615 -- remaining constituents do not have In_Out or Output modes. Emit an
24616 -- error if this is not the case (SPARK RM 7.2.4(5)).
24618 -----------------------------
24619 -- Check_Constituent_Usage --
24620 -----------------------------
24622 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24623 Constits : constant Elist_Id :=
24624 Refinement_Constituents (State_Id);
24625 Constit_Elmt : Elmt_Id;
24626 Constit_Id : Entity_Id;
24627 In_Seen : Boolean := False;
24630 if Present (Constits) then
24631 Constit_Elmt := First_Elmt (Constits);
24632 while Present (Constit_Elmt) loop
24633 Constit_Id := Node (Constit_Elmt);
24635 -- At least one of the constituents appears as an Input
24637 if Present_Then_Remove (In_Constits, Constit_Id) then
24640 -- A Proof_In constituent can refine an Input state as long
24641 -- as there is at least one Input constituent present.
24643 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24647 -- The constituent appears in the global refinement, but has
24648 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24650 elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24651 or else Present_Then_Remove (Out_Constits, Constit_Id)
24653 Error_Msg_Name_1 := Chars (State_Id);
24655 ("constituent & of state % must have mode `Input` in "
24656 & "global refinement", N, Constit_Id);
24659 Next_Elmt (Constit_Elmt);
24663 -- Not one of the constituents appeared as Input
24665 if not In_Seen then
24667 ("global refinement of state & must include at least one "
24668 & "constituent of mode `Input`", N, State_Id);
24670 end Check_Constituent_Usage;
24674 Item_Elmt : Elmt_Id;
24675 Item_Id : Entity_Id;
24677 -- Start of processing for Check_Input_States
24680 -- Do not perform this check in an instance because it was already
24681 -- performed successfully in the generic template.
24683 if Is_Generic_Instance (Spec_Id) then
24686 -- Inspect the Input items of the corresponding Global pragma looking
24687 -- for a state with a visible refinement.
24689 elsif Has_In_State and then Present (In_Items) then
24690 Item_Elmt := First_Elmt (In_Items);
24691 while Present (Item_Elmt) loop
24692 Item_Id := Node (Item_Elmt);
24694 -- Ensure that at least one of the constituents is utilized and
24695 -- is of mode Input.
24697 if Ekind (Item_Id) = E_Abstract_State
24698 and then Has_Non_Null_Visible_Refinement (Item_Id)
24700 Check_Constituent_Usage (Item_Id);
24703 Next_Elmt (Item_Elmt);
24706 end Check_Input_States;
24708 -------------------------
24709 -- Check_Output_States --
24710 -------------------------
24712 procedure Check_Output_States is
24713 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24714 -- Determine whether all constituents of state State_Id with visible
24715 -- refinement are used and have mode Output. Emit an error if this is
24716 -- not the case (SPARK RM 7.2.4(5)).
24718 -----------------------------
24719 -- Check_Constituent_Usage --
24720 -----------------------------
24722 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24723 Constits : constant Elist_Id :=
24724 Refinement_Constituents (State_Id);
24725 Constit_Elmt : Elmt_Id;
24726 Constit_Id : Entity_Id;
24727 Posted : Boolean := False;
24730 if Present (Constits) then
24731 Constit_Elmt := First_Elmt (Constits);
24732 while Present (Constit_Elmt) loop
24733 Constit_Id := Node (Constit_Elmt);
24735 if Present_Then_Remove (Out_Constits, Constit_Id) then
24738 -- The constituent appears in the global refinement, but has
24739 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24741 elsif Present_Then_Remove (In_Constits, Constit_Id)
24742 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24743 or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24745 Error_Msg_Name_1 := Chars (State_Id);
24747 ("constituent & of state % must have mode `Output` in "
24748 & "global refinement", N, Constit_Id);
24750 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24756 ("`Output` state & must be replaced by all its "
24757 & "constituents in global refinement", N, State_Id);
24761 ("\constituent & is missing in output list",
24765 Next_Elmt (Constit_Elmt);
24768 end Check_Constituent_Usage;
24772 Item_Elmt : Elmt_Id;
24773 Item_Id : Entity_Id;
24775 -- Start of processing for Check_Output_States
24778 -- Do not perform this check in an instance because it was already
24779 -- performed successfully in the generic template.
24781 if Is_Generic_Instance (Spec_Id) then
24784 -- Inspect the Output items of the corresponding Global pragma
24785 -- looking for a state with a visible refinement.
24787 elsif Has_Out_State and then Present (Out_Items) then
24788 Item_Elmt := First_Elmt (Out_Items);
24789 while Present (Item_Elmt) loop
24790 Item_Id := Node (Item_Elmt);
24792 -- Ensure that all of the constituents are utilized and they
24793 -- have mode Output.
24795 if Ekind (Item_Id) = E_Abstract_State
24796 and then Has_Non_Null_Visible_Refinement (Item_Id)
24798 Check_Constituent_Usage (Item_Id);
24801 Next_Elmt (Item_Elmt);
24804 end Check_Output_States;
24806 ---------------------------
24807 -- Check_Proof_In_States --
24808 ---------------------------
24810 procedure Check_Proof_In_States is
24811 procedure Check_Constituent_Usage (State_Id : Entity_Id);
24812 -- Determine whether at least one constituent of state State_Id with
24813 -- visible refinement is used and has mode Proof_In. Ensure that the
24814 -- remaining constituents do not have Input, In_Out or Output modes.
24815 -- Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24817 -----------------------------
24818 -- Check_Constituent_Usage --
24819 -----------------------------
24821 procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24822 Constits : constant Elist_Id :=
24823 Refinement_Constituents (State_Id);
24824 Constit_Elmt : Elmt_Id;
24825 Constit_Id : Entity_Id;
24826 Proof_In_Seen : Boolean := False;
24829 if Present (Constits) then
24830 Constit_Elmt := First_Elmt (Constits);
24831 while Present (Constit_Elmt) loop
24832 Constit_Id := Node (Constit_Elmt);
24834 -- At least one of the constituents appears as Proof_In
24836 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24837 Proof_In_Seen := True;
24839 -- The constituent appears in the global refinement, but has
24840 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24842 elsif Present_Then_Remove (In_Constits, Constit_Id)
24843 or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24844 or else Present_Then_Remove (Out_Constits, Constit_Id)
24846 Error_Msg_Name_1 := Chars (State_Id);
24848 ("constituent & of state % must have mode `Proof_In` "
24849 & "in global refinement", N, Constit_Id);
24852 Next_Elmt (Constit_Elmt);
24856 -- Not one of the constituents appeared as Proof_In
24858 if not Proof_In_Seen then
24860 ("global refinement of state & must include at least one "
24861 & "constituent of mode `Proof_In`", N, State_Id);
24863 end Check_Constituent_Usage;
24867 Item_Elmt : Elmt_Id;
24868 Item_Id : Entity_Id;
24870 -- Start of processing for Check_Proof_In_States
24873 -- Do not perform this check in an instance because it was already
24874 -- performed successfully in the generic template.
24876 if Is_Generic_Instance (Spec_Id) then
24879 -- Inspect the Proof_In items of the corresponding Global pragma
24880 -- looking for a state with a visible refinement.
24882 elsif Has_Proof_In_State and then Present (Proof_In_Items) then
24883 Item_Elmt := First_Elmt (Proof_In_Items);
24884 while Present (Item_Elmt) loop
24885 Item_Id := Node (Item_Elmt);
24887 -- Ensure that at least one of the constituents is utilized and
24888 -- is of mode Proof_In
24890 if Ekind (Item_Id) = E_Abstract_State
24891 and then Has_Non_Null_Visible_Refinement (Item_Id)
24893 Check_Constituent_Usage (Item_Id);
24896 Next_Elmt (Item_Elmt);
24899 end Check_Proof_In_States;
24901 -------------------------------
24902 -- Check_Refined_Global_List --
24903 -------------------------------
24905 procedure Check_Refined_Global_List
24907 Global_Mode : Name_Id := Name_Input)
24909 procedure Check_Refined_Global_Item
24911 Global_Mode : Name_Id);
24912 -- Verify the legality of a single global item declaration. Parameter
24913 -- Global_Mode denotes the current mode in effect.
24915 -------------------------------
24916 -- Check_Refined_Global_Item --
24917 -------------------------------
24919 procedure Check_Refined_Global_Item
24921 Global_Mode : Name_Id)
24923 Item_Id : constant Entity_Id := Entity_Of (Item);
24925 procedure Inconsistent_Mode_Error (Expect : Name_Id);
24926 -- Issue a common error message for all mode mismatches. Expect
24927 -- denotes the expected mode.
24929 -----------------------------
24930 -- Inconsistent_Mode_Error --
24931 -----------------------------
24933 procedure Inconsistent_Mode_Error (Expect : Name_Id) is
24936 ("global item & has inconsistent modes", Item, Item_Id);
24938 Error_Msg_Name_1 := Global_Mode;
24939 Error_Msg_Name_2 := Expect;
24940 SPARK_Msg_N ("\expected mode %, found mode %", Item);
24941 end Inconsistent_Mode_Error;
24943 -- Start of processing for Check_Refined_Global_Item
24946 -- When the state or object acts as a constituent of another
24947 -- state with a visible refinement, collect it for the state
24948 -- completeness checks performed later on. Note that the item
24949 -- acts as a constituent only when the encapsulating state is
24950 -- present in pragma Global.
24952 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
24953 and then Present (Encapsulating_State (Item_Id))
24954 and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
24955 and then Contains (States, Encapsulating_State (Item_Id))
24957 if Global_Mode = Name_Input then
24958 Append_New_Elmt (Item_Id, In_Constits);
24960 elsif Global_Mode = Name_In_Out then
24961 Append_New_Elmt (Item_Id, In_Out_Constits);
24963 elsif Global_Mode = Name_Output then
24964 Append_New_Elmt (Item_Id, Out_Constits);
24966 elsif Global_Mode = Name_Proof_In then
24967 Append_New_Elmt (Item_Id, Proof_In_Constits);
24970 -- When not a constituent, ensure that both occurrences of the
24971 -- item in pragmas Global and Refined_Global match.
24973 elsif Contains (In_Items, Item_Id) then
24974 if Global_Mode /= Name_Input then
24975 Inconsistent_Mode_Error (Name_Input);
24978 elsif Contains (In_Out_Items, Item_Id) then
24979 if Global_Mode /= Name_In_Out then
24980 Inconsistent_Mode_Error (Name_In_Out);
24983 elsif Contains (Out_Items, Item_Id) then
24984 if Global_Mode /= Name_Output then
24985 Inconsistent_Mode_Error (Name_Output);
24988 elsif Contains (Proof_In_Items, Item_Id) then
24991 -- The item does not appear in the corresponding Global pragma,
24992 -- it must be an extra (SPARK RM 7.2.4(3)).
24995 SPARK_Msg_NE ("extra global item &", Item, Item_Id);
24997 end Check_Refined_Global_Item;
25003 -- Start of processing for Check_Refined_Global_List
25006 -- Do not perform this check in an instance because it was already
25007 -- performed successfully in the generic template.
25009 if Is_Generic_Instance (Spec_Id) then
25012 elsif Nkind (List) = N_Null then
25015 -- Single global item declaration
25017 elsif Nkind_In (List, N_Expanded_Name,
25019 N_Selected_Component)
25021 Check_Refined_Global_Item (List, Global_Mode);
25023 -- Simple global list or moded global list declaration
25025 elsif Nkind (List) = N_Aggregate then
25027 -- The declaration of a simple global list appear as a collection
25030 if Present (Expressions (List)) then
25031 Item := First (Expressions (List));
25032 while Present (Item) loop
25033 Check_Refined_Global_Item (Item, Global_Mode);
25037 -- The declaration of a moded global list appears as a collection
25038 -- of component associations where individual choices denote
25041 elsif Present (Component_Associations (List)) then
25042 Item := First (Component_Associations (List));
25043 while Present (Item) loop
25044 Check_Refined_Global_List
25045 (List => Expression (Item),
25046 Global_Mode => Chars (First (Choices (Item))));
25054 raise Program_Error;
25060 raise Program_Error;
25062 end Check_Refined_Global_List;
25064 --------------------------
25065 -- Collect_Global_Items --
25066 --------------------------
25068 procedure Collect_Global_Items
25070 Mode : Name_Id := Name_Input)
25072 procedure Collect_Global_Item
25074 Item_Mode : Name_Id);
25075 -- Add a single item to the appropriate list. Item_Mode denotes the
25076 -- current mode in effect.
25078 -------------------------
25079 -- Collect_Global_Item --
25080 -------------------------
25082 procedure Collect_Global_Item
25084 Item_Mode : Name_Id)
25086 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25087 -- The above handles abstract views of variables and states built
25088 -- for limited with clauses.
25091 -- Signal that the global list contains at least one abstract
25092 -- state with a visible refinement. Note that the refinement may
25093 -- be null in which case there are no constituents.
25095 if Ekind (Item_Id) = E_Abstract_State then
25096 if Has_Null_Visible_Refinement (Item_Id) then
25097 Has_Null_State := True;
25099 elsif Has_Non_Null_Visible_Refinement (Item_Id) then
25100 Append_New_Elmt (Item_Id, States);
25102 if Item_Mode = Name_Input then
25103 Has_In_State := True;
25104 elsif Item_Mode = Name_In_Out then
25105 Has_In_Out_State := True;
25106 elsif Item_Mode = Name_Output then
25107 Has_Out_State := True;
25108 elsif Item_Mode = Name_Proof_In then
25109 Has_Proof_In_State := True;
25114 -- Add the item to the proper list
25116 if Item_Mode = Name_Input then
25117 Append_New_Elmt (Item_Id, In_Items);
25118 elsif Item_Mode = Name_In_Out then
25119 Append_New_Elmt (Item_Id, In_Out_Items);
25120 elsif Item_Mode = Name_Output then
25121 Append_New_Elmt (Item_Id, Out_Items);
25122 elsif Item_Mode = Name_Proof_In then
25123 Append_New_Elmt (Item_Id, Proof_In_Items);
25125 end Collect_Global_Item;
25131 -- Start of processing for Collect_Global_Items
25134 if Nkind (List) = N_Null then
25137 -- Single global item declaration
25139 elsif Nkind_In (List, N_Expanded_Name,
25141 N_Selected_Component)
25143 Collect_Global_Item (List, Mode);
25145 -- Single global list or moded global list declaration
25147 elsif Nkind (List) = N_Aggregate then
25149 -- The declaration of a simple global list appear as a collection
25152 if Present (Expressions (List)) then
25153 Item := First (Expressions (List));
25154 while Present (Item) loop
25155 Collect_Global_Item (Item, Mode);
25159 -- The declaration of a moded global list appears as a collection
25160 -- of component associations where individual choices denote mode.
25162 elsif Present (Component_Associations (List)) then
25163 Item := First (Component_Associations (List));
25164 while Present (Item) loop
25165 Collect_Global_Items
25166 (List => Expression (Item),
25167 Mode => Chars (First (Choices (Item))));
25175 raise Program_Error;
25178 -- To accomodate partial decoration of disabled SPARK features, this
25179 -- routine may be called with illegal input. If this is the case, do
25180 -- not raise Program_Error.
25185 end Collect_Global_Items;
25187 -------------------------
25188 -- Present_Then_Remove --
25189 -------------------------
25191 function Present_Then_Remove
25193 Item : Entity_Id) return Boolean
25198 if Present (List) then
25199 Elmt := First_Elmt (List);
25200 while Present (Elmt) loop
25201 if Node (Elmt) = Item then
25202 Remove_Elmt (List, Elmt);
25211 end Present_Then_Remove;
25213 -------------------------------
25214 -- Report_Extra_Constituents --
25215 -------------------------------
25217 procedure Report_Extra_Constituents is
25218 procedure Report_Extra_Constituents_In_List (List : Elist_Id);
25219 -- Emit an error for every element of List
25221 ---------------------------------------
25222 -- Report_Extra_Constituents_In_List --
25223 ---------------------------------------
25225 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
25226 Constit_Elmt : Elmt_Id;
25229 if Present (List) then
25230 Constit_Elmt := First_Elmt (List);
25231 while Present (Constit_Elmt) loop
25232 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
25233 Next_Elmt (Constit_Elmt);
25236 end Report_Extra_Constituents_In_List;
25238 -- Start of processing for Report_Extra_Constituents
25241 -- Do not perform this check in an instance because it was already
25242 -- performed successfully in the generic template.
25244 if Is_Generic_Instance (Spec_Id) then
25248 Report_Extra_Constituents_In_List (In_Constits);
25249 Report_Extra_Constituents_In_List (In_Out_Constits);
25250 Report_Extra_Constituents_In_List (Out_Constits);
25251 Report_Extra_Constituents_In_List (Proof_In_Constits);
25253 end Report_Extra_Constituents;
25257 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25258 Errors : constant Nat := Serious_Errors_Detected;
25261 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25264 -- Do not analyze the pragma multiple times
25266 if Is_Analyzed_Pragma (N) then
25270 Spec_Id := Unique_Defining_Entity (Body_Decl);
25272 -- Use the anonymous object as the proper spec when Refined_Global
25273 -- applies to the body of a single task type. The object carries the
25274 -- proper Chars as well as all non-refined versions of pragmas.
25276 if Is_Single_Concurrent_Type (Spec_Id) then
25277 Spec_Id := Anonymous_Object (Spec_Id);
25280 Global := Get_Pragma (Spec_Id, Pragma_Global);
25281 Items := Expression (Get_Argument (N, Spec_Id));
25283 -- The subprogram declaration lacks pragma Global. This renders
25284 -- Refined_Global useless as there is nothing to refine.
25286 if No (Global) then
25288 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25289 & "& lacks aspect or pragma Global"), N, Spec_Id);
25293 -- Extract all relevant items from the corresponding Global pragma
25295 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
25297 -- Package and subprogram bodies are instantiated individually in
25298 -- a separate compiler pass. Due to this mode of instantiation, the
25299 -- refinement of a state may no longer be visible when a subprogram
25300 -- body contract is instantiated. Since the generic template is legal,
25301 -- do not perform this check in the instance to circumvent this oddity.
25303 if Is_Generic_Instance (Spec_Id) then
25306 -- Non-instance case
25309 -- The corresponding Global pragma must mention at least one state
25310 -- witha visible refinement at the point Refined_Global is processed.
25311 -- States with null refinements need Refined_Global pragma
25312 -- (SPARK RM 7.2.4(2)).
25314 if not Has_In_State
25315 and then not Has_In_Out_State
25316 and then not Has_Out_State
25317 and then not Has_Proof_In_State
25318 and then not Has_Null_State
25321 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25322 & "depend on abstract state with visible refinement"),
25326 -- The global refinement of inputs and outputs cannot be null when
25327 -- the corresponding Global pragma contains at least one item except
25328 -- in the case where we have states with null refinements.
25330 elsif Nkind (Items) = N_Null
25332 (Present (In_Items)
25333 or else Present (In_Out_Items)
25334 or else Present (Out_Items)
25335 or else Present (Proof_In_Items))
25336 and then not Has_Null_State
25339 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
25340 & "global items"), N, Spec_Id);
25345 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25346 -- This ensures that the categorization of all refined global items is
25347 -- consistent with their role.
25349 Analyze_Global_In_Decl_Part (N);
25351 -- Perform all refinement checks with respect to completeness and mode
25354 if Serious_Errors_Detected = Errors then
25355 Check_Refined_Global_List (Items);
25358 -- For Input states with visible refinement, at least one constituent
25359 -- must be used as an Input in the global refinement.
25361 if Serious_Errors_Detected = Errors then
25362 Check_Input_States;
25365 -- Verify all possible completion variants for In_Out states with
25366 -- visible refinement.
25368 if Serious_Errors_Detected = Errors then
25369 Check_In_Out_States;
25372 -- For Output states with visible refinement, all constituents must be
25373 -- used as Outputs in the global refinement.
25375 if Serious_Errors_Detected = Errors then
25376 Check_Output_States;
25379 -- For Proof_In states with visible refinement, at least one constituent
25380 -- must be used as Proof_In in the global refinement.
25382 if Serious_Errors_Detected = Errors then
25383 Check_Proof_In_States;
25386 -- Emit errors for all constituents that belong to other states with
25387 -- visible refinement that do not appear in Global.
25389 if Serious_Errors_Detected = Errors then
25390 Report_Extra_Constituents;
25394 Set_Is_Analyzed_Pragma (N);
25395 end Analyze_Refined_Global_In_Decl_Part;
25397 ----------------------------------------
25398 -- Analyze_Refined_State_In_Decl_Part --
25399 ----------------------------------------
25401 procedure Analyze_Refined_State_In_Decl_Part
25403 Freeze_Id : Entity_Id := Empty)
25405 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
25406 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
25407 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl);
25409 Available_States : Elist_Id := No_Elist;
25410 -- A list of all abstract states defined in the package declaration that
25411 -- are available for refinement. The list is used to report unrefined
25414 Body_States : Elist_Id := No_Elist;
25415 -- A list of all hidden states that appear in the body of the related
25416 -- package. The list is used to report unused hidden states.
25418 Constituents_Seen : Elist_Id := No_Elist;
25419 -- A list that contains all constituents processed so far. The list is
25420 -- used to detect multiple uses of the same constituent.
25422 Freeze_Posted : Boolean := False;
25423 -- A flag that controls the output of a freezing-related error (see use
25426 Refined_States_Seen : Elist_Id := No_Elist;
25427 -- A list that contains all refined states processed so far. The list is
25428 -- used to detect duplicate refinements.
25430 procedure Analyze_Refinement_Clause (Clause : Node_Id);
25431 -- Perform full analysis of a single refinement clause
25433 procedure Report_Unrefined_States (States : Elist_Id);
25434 -- Emit errors for all unrefined abstract states found in list States
25436 -------------------------------
25437 -- Analyze_Refinement_Clause --
25438 -------------------------------
25440 procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25441 AR_Constit : Entity_Id := Empty;
25442 AW_Constit : Entity_Id := Empty;
25443 ER_Constit : Entity_Id := Empty;
25444 EW_Constit : Entity_Id := Empty;
25445 -- The entities of external constituents that contain one of the
25446 -- following enabled properties: Async_Readers, Async_Writers,
25447 -- Effective_Reads and Effective_Writes.
25449 External_Constit_Seen : Boolean := False;
25450 -- Flag used to mark when at least one external constituent is part
25451 -- of the state refinement.
25453 Non_Null_Seen : Boolean := False;
25454 Null_Seen : Boolean := False;
25455 -- Flags used to detect multiple uses of null in a single clause or a
25456 -- mixture of null and non-null constituents.
25458 Part_Of_Constits : Elist_Id := No_Elist;
25459 -- A list of all candidate constituents subject to indicator Part_Of
25460 -- where the encapsulating state is the current state.
25463 State_Id : Entity_Id;
25464 -- The current state being refined
25466 procedure Analyze_Constituent (Constit : Node_Id);
25467 -- Perform full analysis of a single constituent
25469 procedure Check_External_Property
25470 (Prop_Nam : Name_Id;
25472 Constit : Entity_Id);
25473 -- Determine whether a property denoted by name Prop_Nam is present
25474 -- in the refined state. Emit an error if this is not the case. Flag
25475 -- Enabled should be set when the property applies to the refined
25476 -- state. Constit denotes the constituent (if any) which introduces
25477 -- the property in the refinement.
25479 procedure Match_State;
25480 -- Determine whether the state being refined appears in list
25481 -- Available_States. Emit an error when attempting to re-refine the
25482 -- state or when the state is not defined in the package declaration,
25483 -- otherwise remove the state from Available_States.
25485 procedure Report_Unused_Constituents (Constits : Elist_Id);
25486 -- Emit errors for all unused Part_Of constituents in list Constits
25488 -------------------------
25489 -- Analyze_Constituent --
25490 -------------------------
25492 procedure Analyze_Constituent (Constit : Node_Id) is
25493 procedure Match_Constituent (Constit_Id : Entity_Id);
25494 -- Determine whether constituent Constit denoted by its entity
25495 -- Constit_Id appears in Body_States. Emit an error when the
25496 -- constituent is not a valid hidden state of the related package
25497 -- or when it is used more than once. Otherwise remove the
25498 -- constituent from Body_States.
25500 -----------------------
25501 -- Match_Constituent --
25502 -----------------------
25504 procedure Match_Constituent (Constit_Id : Entity_Id) is
25505 procedure Collect_Constituent;
25506 -- Verify the legality of constituent Constit_Id and add it to
25507 -- the refinements of State_Id.
25509 -------------------------
25510 -- Collect_Constituent --
25511 -------------------------
25513 procedure Collect_Constituent is
25514 Constits : Elist_Id;
25517 -- The Ghost policy in effect at the point of abstract state
25518 -- declaration and constituent must match (SPARK RM 6.9(15))
25520 Check_Ghost_Refinement
25521 (State, State_Id, Constit, Constit_Id);
25523 -- A synchronized state must be refined by a synchronized
25524 -- object or another synchronized state (SPARK RM 9.6).
25526 if Is_Synchronized_State (State_Id)
25527 and then not Is_Synchronized_Object (Constit_Id)
25528 and then not Is_Synchronized_State (Constit_Id)
25531 ("constituent of synchronized state & must be "
25532 & "synchronized", Constit, State_Id);
25535 -- Add the constituent to the list of processed items to aid
25536 -- with the detection of duplicates.
25538 Append_New_Elmt (Constit_Id, Constituents_Seen);
25540 -- Collect the constituent in the list of refinement items
25541 -- and establish a relation between the refined state and
25544 Constits := Refinement_Constituents (State_Id);
25546 if No (Constits) then
25547 Constits := New_Elmt_List;
25548 Set_Refinement_Constituents (State_Id, Constits);
25551 Append_Elmt (Constit_Id, Constits);
25552 Set_Encapsulating_State (Constit_Id, State_Id);
25554 -- The state has at least one legal constituent, mark the
25555 -- start of the refinement region. The region ends when the
25556 -- body declarations end (see routine Analyze_Declarations).
25558 Set_Has_Visible_Refinement (State_Id);
25560 -- When the constituent is external, save its relevant
25561 -- property for further checks.
25563 if Async_Readers_Enabled (Constit_Id) then
25564 AR_Constit := Constit_Id;
25565 External_Constit_Seen := True;
25568 if Async_Writers_Enabled (Constit_Id) then
25569 AW_Constit := Constit_Id;
25570 External_Constit_Seen := True;
25573 if Effective_Reads_Enabled (Constit_Id) then
25574 ER_Constit := Constit_Id;
25575 External_Constit_Seen := True;
25578 if Effective_Writes_Enabled (Constit_Id) then
25579 EW_Constit := Constit_Id;
25580 External_Constit_Seen := True;
25582 end Collect_Constituent;
25586 State_Elmt : Elmt_Id;
25588 -- Start of processing for Match_Constituent
25591 -- Detect a duplicate use of a constituent
25593 if Contains (Constituents_Seen, Constit_Id) then
25595 ("duplicate use of constituent &", Constit, Constit_Id);
25599 -- The constituent is subject to a Part_Of indicator
25601 if Present (Encapsulating_State (Constit_Id)) then
25602 if Encapsulating_State (Constit_Id) = State_Id then
25603 Remove (Part_Of_Constits, Constit_Id);
25604 Collect_Constituent;
25606 -- The constituent is part of another state and is used
25607 -- incorrectly in the refinement of the current state.
25610 Error_Msg_Name_1 := Chars (State_Id);
25612 ("& cannot act as constituent of state %",
25613 Constit, Constit_Id);
25615 ("\Part_Of indicator specifies encapsulator &",
25616 Constit, Encapsulating_State (Constit_Id));
25619 -- The only other source of legal constituents is the body
25620 -- state space of the related package.
25623 if Present (Body_States) then
25624 State_Elmt := First_Elmt (Body_States);
25625 while Present (State_Elmt) loop
25627 -- Consume a valid constituent to signal that it has
25628 -- been encountered.
25630 if Node (State_Elmt) = Constit_Id then
25631 Remove_Elmt (Body_States, State_Elmt);
25632 Collect_Constituent;
25636 Next_Elmt (State_Elmt);
25640 -- Constants are part of the hidden state of a package, but
25641 -- the compiler cannot determine whether they have variable
25642 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25643 -- hidden state. Accept the constant quietly even if it is
25644 -- a visible state or lacks a Part_Of indicator.
25646 if Ekind (Constit_Id) = E_Constant then
25647 Collect_Constituent;
25649 -- If we get here, then the constituent is not a hidden
25650 -- state of the related package and may not be used in a
25651 -- refinement (SPARK RM 7.2.2(9)).
25654 Error_Msg_Name_1 := Chars (Spec_Id);
25656 ("cannot use & in refinement, constituent is not a "
25657 & "hidden state of package %", Constit, Constit_Id);
25660 end Match_Constituent;
25664 Constit_Id : Entity_Id;
25665 Constits : Elist_Id;
25667 -- Start of processing for Analyze_Constituent
25670 -- Detect multiple uses of null in a single refinement clause or a
25671 -- mixture of null and non-null constituents.
25673 if Nkind (Constit) = N_Null then
25676 ("multiple null constituents not allowed", Constit);
25678 elsif Non_Null_Seen then
25680 ("cannot mix null and non-null constituents", Constit);
25685 -- Collect the constituent in the list of refinement items
25687 Constits := Refinement_Constituents (State_Id);
25689 if No (Constits) then
25690 Constits := New_Elmt_List;
25691 Set_Refinement_Constituents (State_Id, Constits);
25694 Append_Elmt (Constit, Constits);
25696 -- The state has at least one legal constituent, mark the
25697 -- start of the refinement region. The region ends when the
25698 -- body declarations end (see Analyze_Declarations).
25700 Set_Has_Visible_Refinement (State_Id);
25703 -- Non-null constituents
25706 Non_Null_Seen := True;
25710 ("cannot mix null and non-null constituents", Constit);
25714 Resolve_State (Constit);
25716 -- Ensure that the constituent denotes a valid state or a
25717 -- whole object (SPARK RM 7.2.2(5)).
25719 if Is_Entity_Name (Constit) then
25720 Constit_Id := Entity_Of (Constit);
25722 -- When a constituent is declared after a subprogram body
25723 -- that caused "freezing" of the related contract where
25724 -- pragma Refined_State resides, the constituent appears
25725 -- undefined and carries Any_Id as its entity.
25727 -- package body Pack
25728 -- with Refined_State => (State => Constit)
25731 -- with Refined_Global => (Input => Constit)
25739 if Constit_Id = Any_Id then
25740 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25742 -- Emit a specialized info message when the contract of
25743 -- the related package body was "frozen" by another body.
25744 -- Note that it is not possible to precisely identify why
25745 -- the constituent is undefined because it is not visible
25746 -- when pragma Refined_State is analyzed. This message is
25747 -- a reasonable approximation.
25749 if Present (Freeze_Id) and then not Freeze_Posted then
25750 Freeze_Posted := True;
25752 Error_Msg_Name_1 := Chars (Body_Id);
25753 Error_Msg_Sloc := Sloc (Freeze_Id);
25755 ("body & declared # freezes the contract of %",
25758 ("\all constituents must be declared before body #",
25761 -- A misplaced constituent is a critical error because
25762 -- pragma Refined_Depends or Refined_Global depends on
25763 -- the proper link between a state and a constituent.
25764 -- Stop the compilation, as this leads to a multitude
25765 -- of misleading cascaded errors.
25767 raise Program_Error;
25770 -- The constituent is a valid state or object
25772 elsif Ekind_In (Constit_Id, E_Abstract_State,
25776 Match_Constituent (Constit_Id);
25778 -- The variable may eventually become a constituent of a
25779 -- single protected/task type. Record the reference now
25780 -- and verify its legality when analyzing the contract of
25781 -- the variable (SPARK RM 9.3).
25783 if Ekind (Constit_Id) = E_Variable then
25784 Record_Possible_Part_Of_Reference
25785 (Var_Id => Constit_Id,
25789 -- Otherwise the constituent is illegal
25793 ("constituent & must denote object or state",
25794 Constit, Constit_Id);
25797 -- The constituent is illegal
25800 SPARK_Msg_N ("malformed constituent", Constit);
25803 end Analyze_Constituent;
25805 -----------------------------
25806 -- Check_External_Property --
25807 -----------------------------
25809 procedure Check_External_Property
25810 (Prop_Nam : Name_Id;
25812 Constit : Entity_Id)
25815 -- The property is missing in the declaration of the state, but
25816 -- a constituent is introducing it in the state refinement
25817 -- (SPARK RM 7.2.8(2)).
25819 if not Enabled and then Present (Constit) then
25820 Error_Msg_Name_1 := Prop_Nam;
25821 Error_Msg_Name_2 := Chars (State_Id);
25823 ("constituent & introduces external property % in refinement "
25824 & "of state %", State, Constit);
25826 Error_Msg_Sloc := Sloc (State_Id);
25828 ("\property is missing in abstract state declaration #",
25831 end Check_External_Property;
25837 procedure Match_State is
25838 State_Elmt : Elmt_Id;
25841 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25843 if Contains (Refined_States_Seen, State_Id) then
25845 ("duplicate refinement of state &", State, State_Id);
25849 -- Inspect the abstract states defined in the package declaration
25850 -- looking for a match.
25852 State_Elmt := First_Elmt (Available_States);
25853 while Present (State_Elmt) loop
25855 -- A valid abstract state is being refined in the body. Add
25856 -- the state to the list of processed refined states to aid
25857 -- with the detection of duplicate refinements. Remove the
25858 -- state from Available_States to signal that it has already
25861 if Node (State_Elmt) = State_Id then
25862 Append_New_Elmt (State_Id, Refined_States_Seen);
25863 Remove_Elmt (Available_States, State_Elmt);
25867 Next_Elmt (State_Elmt);
25870 -- If we get here, we are refining a state that is not defined in
25871 -- the package declaration.
25873 Error_Msg_Name_1 := Chars (Spec_Id);
25875 ("cannot refine state, & is not defined in package %",
25879 --------------------------------
25880 -- Report_Unused_Constituents --
25881 --------------------------------
25883 procedure Report_Unused_Constituents (Constits : Elist_Id) is
25884 Constit_Elmt : Elmt_Id;
25885 Constit_Id : Entity_Id;
25886 Posted : Boolean := False;
25889 if Present (Constits) then
25890 Constit_Elmt := First_Elmt (Constits);
25891 while Present (Constit_Elmt) loop
25892 Constit_Id := Node (Constit_Elmt);
25894 -- Generate an error message of the form:
25896 -- state ... has unused Part_Of constituents
25897 -- abstract state ... defined at ...
25898 -- constant ... defined at ...
25899 -- variable ... defined at ...
25904 ("state & has unused Part_Of constituents",
25908 Error_Msg_Sloc := Sloc (Constit_Id);
25910 if Ekind (Constit_Id) = E_Abstract_State then
25912 ("\abstract state & defined #", State, Constit_Id);
25914 elsif Ekind (Constit_Id) = E_Constant then
25916 ("\constant & defined #", State, Constit_Id);
25919 pragma Assert (Ekind (Constit_Id) = E_Variable);
25920 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
25923 Next_Elmt (Constit_Elmt);
25926 end Report_Unused_Constituents;
25928 -- Local declarations
25930 Body_Ref : Node_Id;
25931 Body_Ref_Elmt : Elmt_Id;
25933 Extra_State : Node_Id;
25935 -- Start of processing for Analyze_Refinement_Clause
25938 -- A refinement clause appears as a component association where the
25939 -- sole choice is the state and the expressions are the constituents.
25940 -- This is a syntax error, always report.
25942 if Nkind (Clause) /= N_Component_Association then
25943 Error_Msg_N ("malformed state refinement clause", Clause);
25947 -- Analyze the state name of a refinement clause
25949 State := First (Choices (Clause));
25952 Resolve_State (State);
25954 -- Ensure that the state name denotes a valid abstract state that is
25955 -- defined in the spec of the related package.
25957 if Is_Entity_Name (State) then
25958 State_Id := Entity_Of (State);
25960 -- When the abstract state is undefined, it appears as Any_Id. Do
25961 -- not continue with the analysis of the clause.
25963 if State_Id = Any_Id then
25966 -- Catch any attempts to re-refine a state or refine a state that
25967 -- is not defined in the package declaration.
25969 elsif Ekind (State_Id) = E_Abstract_State then
25973 SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
25977 -- References to a state with visible refinement are illegal.
25978 -- When nested packages are involved, detecting such references is
25979 -- tricky because pragma Refined_State is analyzed later than the
25980 -- offending pragma Depends or Global. References that occur in
25981 -- such nested context are stored in a list. Emit errors for all
25982 -- references found in Body_References (SPARK RM 6.1.4(8)).
25984 if Present (Body_References (State_Id)) then
25985 Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
25986 while Present (Body_Ref_Elmt) loop
25987 Body_Ref := Node (Body_Ref_Elmt);
25989 SPARK_Msg_N ("reference to & not allowed", Body_Ref);
25990 Error_Msg_Sloc := Sloc (State);
25991 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
25993 Next_Elmt (Body_Ref_Elmt);
25997 -- The state name is illegal. This is a syntax error, always report.
26000 Error_Msg_N ("malformed state name in refinement clause", State);
26004 -- A refinement clause may only refine one state at a time
26006 Extra_State := Next (State);
26008 if Present (Extra_State) then
26010 ("refinement clause cannot cover multiple states", Extra_State);
26013 -- Replicate the Part_Of constituents of the refined state because
26014 -- the algorithm will consume items.
26016 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
26018 -- Analyze all constituents of the refinement. Multiple constituents
26019 -- appear as an aggregate.
26021 Constit := Expression (Clause);
26023 if Nkind (Constit) = N_Aggregate then
26024 if Present (Component_Associations (Constit)) then
26026 ("constituents of refinement clause must appear in "
26027 & "positional form", Constit);
26029 else pragma Assert (Present (Expressions (Constit)));
26030 Constit := First (Expressions (Constit));
26031 while Present (Constit) loop
26032 Analyze_Constituent (Constit);
26037 -- Various forms of a single constituent. Note that these may include
26038 -- malformed constituents.
26041 Analyze_Constituent (Constit);
26044 -- Verify that external constituents do not introduce new external
26045 -- property in the state refinement (SPARK RM 7.2.8(2)).
26047 if Is_External_State (State_Id) then
26048 Check_External_Property
26049 (Prop_Nam => Name_Async_Readers,
26050 Enabled => Async_Readers_Enabled (State_Id),
26051 Constit => AR_Constit);
26053 Check_External_Property
26054 (Prop_Nam => Name_Async_Writers,
26055 Enabled => Async_Writers_Enabled (State_Id),
26056 Constit => AW_Constit);
26058 Check_External_Property
26059 (Prop_Nam => Name_Effective_Reads,
26060 Enabled => Effective_Reads_Enabled (State_Id),
26061 Constit => ER_Constit);
26063 Check_External_Property
26064 (Prop_Nam => Name_Effective_Writes,
26065 Enabled => Effective_Writes_Enabled (State_Id),
26066 Constit => EW_Constit);
26068 -- When a refined state is not external, it should not have external
26069 -- constituents (SPARK RM 7.2.8(1)).
26071 elsif External_Constit_Seen then
26073 ("non-external state & cannot contain external constituents in "
26074 & "refinement", State, State_Id);
26077 -- Ensure that all Part_Of candidate constituents have been mentioned
26078 -- in the refinement clause.
26080 Report_Unused_Constituents (Part_Of_Constits);
26081 end Analyze_Refinement_Clause;
26083 -----------------------------
26084 -- Report_Unrefined_States --
26085 -----------------------------
26087 procedure Report_Unrefined_States (States : Elist_Id) is
26088 State_Elmt : Elmt_Id;
26091 if Present (States) then
26092 State_Elmt := First_Elmt (States);
26093 while Present (State_Elmt) loop
26095 ("abstract state & must be refined", Node (State_Elmt));
26097 Next_Elmt (State_Elmt);
26100 end Report_Unrefined_States;
26102 -- Local declarations
26104 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26107 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26110 -- Do not analyze the pragma multiple times
26112 if Is_Analyzed_Pragma (N) then
26116 -- Replicate the abstract states declared by the package because the
26117 -- matching algorithm will consume states.
26119 Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
26121 -- Gather all abstract states and objects declared in the visible
26122 -- state space of the package body. These items must be utilized as
26123 -- constituents in a state refinement.
26125 Body_States := Collect_Body_States (Body_Id);
26127 -- Multiple non-null state refinements appear as an aggregate
26129 if Nkind (Clauses) = N_Aggregate then
26130 if Present (Expressions (Clauses)) then
26132 ("state refinements must appear as component associations",
26135 else pragma Assert (Present (Component_Associations (Clauses)));
26136 Clause := First (Component_Associations (Clauses));
26137 while Present (Clause) loop
26138 Analyze_Refinement_Clause (Clause);
26143 -- Various forms of a single state refinement. Note that these may
26144 -- include malformed refinements.
26147 Analyze_Refinement_Clause (Clauses);
26150 -- List all abstract states that were left unrefined
26152 Report_Unrefined_States (Available_States);
26154 Set_Is_Analyzed_Pragma (N);
26155 end Analyze_Refined_State_In_Decl_Part;
26157 ------------------------------------
26158 -- Analyze_Test_Case_In_Decl_Part --
26159 ------------------------------------
26161 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
26162 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26163 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26165 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
26166 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26167 -- denoted by Arg_Nam.
26169 ------------------------------
26170 -- Preanalyze_Test_Case_Arg --
26171 ------------------------------
26173 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
26177 -- Preanalyze the original aspect argument for ASIS or for a generic
26178 -- subprogram to properly capture global references.
26180 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
26184 Arg_Nam => Arg_Nam,
26185 From_Aspect => True);
26187 if Present (Arg) then
26188 Preanalyze_Assert_Expression
26189 (Expression (Arg), Standard_Boolean);
26193 Arg := Test_Case_Arg (N, Arg_Nam);
26195 if Present (Arg) then
26196 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
26198 end Preanalyze_Test_Case_Arg;
26202 Restore_Scope : Boolean := False;
26204 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26207 -- Do not analyze the pragma multiple times
26209 if Is_Analyzed_Pragma (N) then
26213 -- Ensure that the formal parameters are visible when analyzing all
26214 -- clauses. This falls out of the general rule of aspects pertaining
26215 -- to subprogram declarations.
26217 if not In_Open_Scopes (Spec_Id) then
26218 Restore_Scope := True;
26219 Push_Scope (Spec_Id);
26221 if Is_Generic_Subprogram (Spec_Id) then
26222 Install_Generic_Formals (Spec_Id);
26224 Install_Formals (Spec_Id);
26228 Preanalyze_Test_Case_Arg (Name_Requires);
26229 Preanalyze_Test_Case_Arg (Name_Ensures);
26231 if Restore_Scope then
26235 -- Currently it is not possible to inline pre/postconditions on a
26236 -- subprogram subject to pragma Inline_Always.
26238 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26240 Set_Is_Analyzed_Pragma (N);
26241 end Analyze_Test_Case_In_Decl_Part;
26247 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
26252 if Present (List) then
26253 Elmt := First_Elmt (List);
26254 while Present (Elmt) loop
26255 if Nkind (Node (Elmt)) = N_Defining_Identifier then
26258 Id := Entity_Of (Node (Elmt));
26261 if Id = Item_Id then
26272 -----------------------------------
26273 -- Build_Pragma_Check_Equivalent --
26274 -----------------------------------
26276 function Build_Pragma_Check_Equivalent
26278 Subp_Id : Entity_Id := Empty;
26279 Inher_Id : Entity_Id := Empty;
26280 Keep_Pragma_Id : Boolean := False) return Node_Id
26283 -- List containing the following mappings
26284 -- * Formal parameters of inherited subprogram Inher_Id and subprogram
26287 -- * The dispatching type of Inher_Id and the dispatching type of
26290 -- * Primitives of the dispatching type of Inher_Id and primitives of
26291 -- the dispatching type of Subp_Id.
26293 function Replace_Entity (N : Node_Id) return Traverse_Result;
26294 -- Replace reference to formal of inherited operation or to primitive
26295 -- operation of root type, with corresponding entity for derived type.
26297 function Suppress_Reference (N : Node_Id) return Traverse_Result;
26298 -- Detect whether node N references a formal parameter subject to
26299 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26300 -- to False to suppress the generation of a reference when analyzing
26303 --------------------
26304 -- Replace_Entity --
26305 --------------------
26307 function Replace_Entity (N : Node_Id) return Traverse_Result is
26312 if Nkind (N) = N_Identifier
26313 and then Present (Entity (N))
26315 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
26317 (Nkind (Parent (N)) /= N_Attribute_Reference
26318 or else Attribute_Name (Parent (N)) /= Name_Class)
26320 -- The replacement does not apply to dispatching calls within the
26321 -- condition, but only to calls whose static tag is that of the
26324 if Is_Subprogram (Entity (N))
26325 and then Nkind (Parent (N)) = N_Function_Call
26326 and then Present (Controlling_Argument (Parent (N)))
26331 -- Loop to find out if entity has a renaming
26334 Elmt := First_Elmt (Map);
26335 while Present (Elmt) loop
26336 if Node (Elmt) = Entity (N) then
26337 New_E := Node (Next_Elmt (Elmt));
26344 if Present (New_E) then
26345 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
26348 -- Check that there are no calls left to abstract operations if
26349 -- the current subprogram is not abstract.
26351 if Nkind (Parent (N)) = N_Function_Call
26352 and then N = Name (Parent (N))
26353 and then not Is_Abstract_Subprogram (Subp_Id)
26354 and then Is_Abstract_Subprogram (Entity (N))
26356 Error_Msg_Sloc := Sloc (Current_Scope);
26358 ("cannot call abstract subprogram in inherited condition "
26359 & "for&#", N, Current_Scope);
26362 -- Update type of function call node, which should be the same as
26363 -- the function's return type.
26365 if Is_Subprogram (Entity (N))
26366 and then Nkind (Parent (N)) = N_Function_Call
26368 Set_Etype (Parent (N), Etype (Entity (N)));
26371 -- The whole expression will be reanalyzed
26373 elsif Nkind (N) in N_Has_Etype then
26374 Set_Analyzed (N, False);
26378 end Replace_Entity;
26380 ------------------------
26381 -- Suppress_Reference --
26382 ------------------------
26384 function Suppress_Reference (N : Node_Id) return Traverse_Result is
26385 Formal : Entity_Id;
26388 if Is_Entity_Name (N) and then Present (Entity (N)) then
26389 Formal := Entity (N);
26391 -- The formal parameter is subject to pragma Unreferenced.
26392 -- Prevent the generation of a reference by resetting the
26393 -- Comes_From_Source flag.
26395 if Is_Formal (Formal)
26396 and then Has_Pragma_Unreferenced (Formal)
26398 Set_Comes_From_Source (N, False);
26403 end Suppress_Reference;
26405 procedure Replace_Condition_Entities is
26406 new Traverse_Proc (Replace_Entity);
26408 procedure Suppress_References is
26409 new Traverse_Proc (Suppress_Reference);
26413 Loc : constant Source_Ptr := Sloc (Prag);
26414 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
26415 Check_Prag : Node_Id;
26416 Inher_Formal : Entity_Id;
26419 Subp_Formal : Entity_Id;
26421 -- Start of processing for Build_Pragma_Check_Equivalent
26426 -- When the pre- or postcondition is inherited, map the formals of the
26427 -- inherited subprogram to those of the current subprogram. In addition,
26428 -- map primitive operations of the parent type into the corresponding
26429 -- primitive operations of the descendant.
26431 if Present (Inher_Id) then
26432 pragma Assert (Present (Subp_Id));
26434 Map := New_Elmt_List;
26436 -- Create a mapping <inherited formal> => <subprogram formal>
26438 Inher_Formal := First_Formal (Inher_Id);
26439 Subp_Formal := First_Formal (Subp_Id);
26440 while Present (Inher_Formal) and then Present (Subp_Formal) loop
26441 Append_Elmt (Inher_Formal, Map);
26442 Append_Elmt (Subp_Formal, Map);
26444 Next_Formal (Inher_Formal);
26445 Next_Formal (Subp_Formal);
26448 -- Map primitive operations of the parent type to the corresponding
26449 -- operations of the descendant. Note that the descendant type may
26450 -- not be frozen yet, so we cannot use the dispatch table directly.
26452 -- Note : the construction of the map involves a full traversal of
26453 -- the list of primitive operations, as well as a scan of the
26454 -- declarations in the scope of the operation. Given that class-wide
26455 -- conditions are typically short expressions, it might be much more
26456 -- efficient to collect the identifiers in the expression first, and
26457 -- then determine the ones that have to be mapped. Optimization ???
26459 Primitive_Mapping : declare
26460 function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
26461 -- Given the controlling type of the overridden operation and a
26462 -- primitive of the current type, find the corresponding operation
26463 -- of the parent type.
26465 -------------------------
26466 -- Overridden_Ancestor --
26467 -------------------------
26469 function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
26470 Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
26476 -- Locate the ancestor subprogram with the proper controlling
26479 while Present (Overridden_Operation (Anc)) loop
26480 Anc := Overridden_Operation (Anc);
26481 exit when Find_Dispatching_Type (Anc) = Par;
26485 end Overridden_Ancestor;
26489 Old_Typ : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
26490 Typ : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
26492 Old_Elmt : Elmt_Id;
26493 Old_Prim : Entity_Id;
26496 -- Start of processing for Primitive_Mapping
26499 Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
26501 -- Look for primitive operations of the current type that have
26502 -- overridden an operation of the type related to the original
26503 -- class-wide precondition. There may be several intermediate
26504 -- overridings between them.
26506 while Present (Decl) loop
26507 if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
26508 N_Subprogram_Declaration)
26510 Prim := Defining_Entity (Decl);
26512 if Is_Subprogram (Prim)
26513 and then Present (Overridden_Operation (Prim))
26514 and then Find_Dispatching_Type (Prim) = Typ
26516 Old_Prim := Overridden_Ancestor (Prim);
26518 Append_Elmt (Old_Prim, Map);
26519 Append_Elmt (Prim, Map);
26526 -- Now examine inherited operations. These do not override, but
26527 -- have an alias, which is the entity used in a call. In turn
26528 -- that alias may be inherited or comes from source, in which
26529 -- case it may override an earlier operation. We only need to
26530 -- examine inherited functions, that may appear within the
26531 -- inherited expression.
26533 Prim := First_Entity (Scope (Subp_Id));
26534 while Present (Prim) loop
26535 if not Comes_From_Source (Prim)
26536 and then Ekind (Prim) = E_Function
26537 and then Present (Alias (Prim))
26539 Old_Prim := Alias (Prim);
26541 if Comes_From_Source (Old_Prim) then
26542 Old_Prim := Overridden_Ancestor (Old_Prim);
26545 while Present (Alias (Old_Prim))
26546 and then Scope (Old_Prim) /= Scope (Inher_Id)
26548 Old_Prim := Alias (Old_Prim);
26550 if Comes_From_Source (Old_Prim) then
26551 Old_Prim := Overridden_Ancestor (Old_Prim);
26557 Append_Elmt (Old_Prim, Map);
26558 Append_Elmt (Prim, Map);
26561 Next_Entity (Prim);
26564 -- If the parent operation is an interface operation, the
26565 -- overriding indicator is not present. Instead, we get from
26566 -- the interface operation the primitive of the current type
26567 -- that implements it.
26569 if Is_Interface (Old_Typ) then
26570 Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
26571 while Present (Old_Elmt) loop
26572 Old_Prim := Node (Old_Elmt);
26573 Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
26575 if Present (Prim) then
26576 Append_Elmt (Old_Prim, Map);
26577 Append_Elmt (Prim, Map);
26580 Next_Elmt (Old_Elmt);
26584 if Map /= No_Elist then
26585 Append_Elmt (Old_Typ, Map);
26586 Append_Elmt (Typ, Map);
26588 end Primitive_Mapping;
26591 -- Copy the original pragma while performing substitutions (if
26594 Check_Prag := New_Copy_Tree (Source => Prag);
26596 if Map /= No_Elist then
26597 Replace_Condition_Entities (Check_Prag);
26600 -- Mark the pragma as being internally generated and reset the Analyzed
26603 Set_Analyzed (Check_Prag, False);
26604 Set_Comes_From_Source (Check_Prag, False);
26606 -- The tree of the original pragma may contain references to the
26607 -- formal parameters of the related subprogram. At the same time
26608 -- the corresponding body may mark the formals as unreferenced:
26610 -- procedure Proc (Formal : ...)
26611 -- with Pre => Formal ...;
26613 -- procedure Proc (Formal : ...) is
26614 -- pragma Unreferenced (Formal);
26617 -- This creates problems because all pragma Check equivalents are
26618 -- analyzed at the end of the body declarations. Since all source
26619 -- references have already been accounted for, reset any references
26620 -- to such formals in the generated pragma Check equivalent.
26622 Suppress_References (Check_Prag);
26624 if Present (Corresponding_Aspect (Prag)) then
26625 Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
26630 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
26631 -- the copied pragma in the newly created pragma, convert the copy into
26632 -- pragma Check by correcting the name and adding a check_kind argument.
26634 if not Keep_Pragma_Id then
26635 Set_Class_Present (Check_Prag, False);
26637 Set_Pragma_Identifier
26638 (Check_Prag, Make_Identifier (Loc, Name_Check));
26640 Prepend_To (Pragma_Argument_Associations (Check_Prag),
26641 Make_Pragma_Argument_Association (Loc,
26642 Expression => Make_Identifier (Loc, Nam)));
26645 -- Update the error message when the pragma is inherited
26647 if Present (Inher_Id) then
26648 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
26650 if Chars (Msg_Arg) = Name_Message then
26651 String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
26653 -- Insert "inherited" to improve the error message
26655 if Name_Buffer (1 .. 8) = "failed p" then
26656 Insert_Str_In_Name_Buffer ("inherited ", 8);
26657 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
26663 end Build_Pragma_Check_Equivalent;
26665 -----------------------------
26666 -- Check_Applicable_Policy --
26667 -----------------------------
26669 procedure Check_Applicable_Policy (N : Node_Id) is
26673 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
26676 -- No effect if not valid assertion kind name
26678 if not Is_Valid_Assertion_Kind (Ename) then
26682 -- Loop through entries in check policy list
26684 PP := Opt.Check_Policy_List;
26685 while Present (PP) loop
26687 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26688 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26692 or else Pnm = Name_Assertion
26693 or else (Pnm = Name_Statement_Assertions
26694 and then Nam_In (Ename, Name_Assert,
26695 Name_Assert_And_Cut,
26697 Name_Loop_Invariant,
26698 Name_Loop_Variant))
26700 Policy := Chars (Get_Pragma_Arg (Last (PPA)));
26703 when Name_Off | Name_Ignore =>
26704 Set_Is_Ignored (N, True);
26705 Set_Is_Checked (N, False);
26707 when Name_On | Name_Check =>
26708 Set_Is_Checked (N, True);
26709 Set_Is_Ignored (N, False);
26711 when Name_Disable =>
26712 Set_Is_Ignored (N, True);
26713 Set_Is_Checked (N, False);
26714 Set_Is_Disabled (N, True);
26716 -- That should be exhaustive, the null here is a defence
26717 -- against a malformed tree from previous errors.
26726 PP := Next_Pragma (PP);
26730 -- If there are no specific entries that matched, then we let the
26731 -- setting of assertions govern. Note that this provides the needed
26732 -- compatibility with the RM for the cases of assertion, invariant,
26733 -- precondition, predicate, and postcondition.
26735 if Assertions_Enabled then
26736 Set_Is_Checked (N, True);
26737 Set_Is_Ignored (N, False);
26739 Set_Is_Checked (N, False);
26740 Set_Is_Ignored (N, True);
26742 end Check_Applicable_Policy;
26744 -------------------------------
26745 -- Check_External_Properties --
26746 -------------------------------
26748 procedure Check_External_Properties
26756 -- All properties enabled
26758 if AR and AW and ER and EW then
26761 -- Async_Readers + Effective_Writes
26762 -- Async_Readers + Async_Writers + Effective_Writes
26764 elsif AR and EW and not ER then
26767 -- Async_Writers + Effective_Reads
26768 -- Async_Readers + Async_Writers + Effective_Reads
26770 elsif AW and ER and not EW then
26773 -- Async_Readers + Async_Writers
26775 elsif AR and AW and not ER and not EW then
26780 elsif AR and not AW and not ER and not EW then
26785 elsif AW and not AR and not ER and not EW then
26790 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26793 end Check_External_Properties;
26799 function Check_Kind (Nam : Name_Id) return Name_Id is
26803 -- Loop through entries in check policy list
26805 PP := Opt.Check_Policy_List;
26806 while Present (PP) loop
26808 PPA : constant List_Id := Pragma_Argument_Associations (PP);
26809 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26813 or else (Pnm = Name_Assertion
26814 and then Is_Valid_Assertion_Kind (Nam))
26815 or else (Pnm = Name_Statement_Assertions
26816 and then Nam_In (Nam, Name_Assert,
26817 Name_Assert_And_Cut,
26819 Name_Loop_Invariant,
26820 Name_Loop_Variant))
26822 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26823 when Name_On | Name_Check =>
26825 when Name_Off | Name_Ignore =>
26826 return Name_Ignore;
26827 when Name_Disable =>
26828 return Name_Disable;
26830 raise Program_Error;
26834 PP := Next_Pragma (PP);
26839 -- If there are no specific entries that matched, then we let the
26840 -- setting of assertions govern. Note that this provides the needed
26841 -- compatibility with the RM for the cases of assertion, invariant,
26842 -- precondition, predicate, and postcondition.
26844 if Assertions_Enabled then
26847 return Name_Ignore;
26851 ---------------------------
26852 -- Check_Missing_Part_Of --
26853 ---------------------------
26855 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26856 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26857 -- Determine whether a package denoted by Pack_Id declares at least one
26860 -----------------------
26861 -- Has_Visible_State --
26862 -----------------------
26864 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26865 Item_Id : Entity_Id;
26868 -- Traverse the entity chain of the package trying to find at least
26869 -- one visible abstract state, variable or a package [instantiation]
26870 -- that declares a visible state.
26872 Item_Id := First_Entity (Pack_Id);
26873 while Present (Item_Id)
26874 and then not In_Private_Part (Item_Id)
26876 -- Do not consider internally generated items
26878 if not Comes_From_Source (Item_Id) then
26881 -- A visible state has been found
26883 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26886 -- Recursively peek into nested packages and instantiations
26888 elsif Ekind (Item_Id) = E_Package
26889 and then Has_Visible_State (Item_Id)
26894 Next_Entity (Item_Id);
26898 end Has_Visible_State;
26902 Pack_Id : Entity_Id;
26903 Placement : State_Space_Kind;
26905 -- Start of processing for Check_Missing_Part_Of
26908 -- Do not consider abstract states, variables or package instantiations
26909 -- coming from an instance as those always inherit the Part_Of indicator
26910 -- of the instance itself.
26912 if In_Instance then
26915 -- Do not consider internally generated entities as these can never
26916 -- have a Part_Of indicator.
26918 elsif not Comes_From_Source (Item_Id) then
26921 -- Perform these checks only when SPARK_Mode is enabled as they will
26922 -- interfere with standard Ada rules and produce false positives.
26924 elsif SPARK_Mode /= On then
26927 -- Do not consider constants, because the compiler cannot accurately
26928 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26929 -- act as a hidden state of a package.
26931 elsif Ekind (Item_Id) = E_Constant then
26935 -- Find where the abstract state, variable or package instantiation
26936 -- lives with respect to the state space.
26938 Find_Placement_In_State_Space
26939 (Item_Id => Item_Id,
26940 Placement => Placement,
26941 Pack_Id => Pack_Id);
26943 -- Items that appear in a non-package construct (subprogram, block, etc)
26944 -- do not require a Part_Of indicator because they can never act as a
26947 if Placement = Not_In_Package then
26950 -- An item declared in the body state space of a package always act as a
26951 -- constituent and does not need explicit Part_Of indicator.
26953 elsif Placement = Body_State_Space then
26956 -- In general an item declared in the visible state space of a package
26957 -- does not require a Part_Of indicator. The only exception is when the
26958 -- related package is a private child unit in which case Part_Of must
26959 -- denote a state in the parent unit or in one of its descendants.
26961 elsif Placement = Visible_State_Space then
26962 if Is_Child_Unit (Pack_Id)
26963 and then Is_Private_Descendant (Pack_Id)
26965 -- A package instantiation does not need a Part_Of indicator when
26966 -- the related generic template has no visible state.
26968 if Ekind (Item_Id) = E_Package
26969 and then Is_Generic_Instance (Item_Id)
26970 and then not Has_Visible_State (Item_Id)
26974 -- All other cases require Part_Of
26978 ("indicator Part_Of is required in this context "
26979 & "(SPARK RM 7.2.6(3))", Item_Id);
26980 Error_Msg_Name_1 := Chars (Pack_Id);
26982 ("\& is declared in the visible part of private child "
26983 & "unit %", Item_Id);
26987 -- When the item appears in the private state space of a packge, it must
26988 -- be a part of some state declared by the said package.
26990 else pragma Assert (Placement = Private_State_Space);
26992 -- The related package does not declare a state, the item cannot act
26993 -- as a Part_Of constituent.
26995 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
26998 -- A package instantiation does not need a Part_Of indicator when the
26999 -- related generic template has no visible state.
27001 elsif Ekind (Pack_Id) = E_Package
27002 and then Is_Generic_Instance (Pack_Id)
27003 and then not Has_Visible_State (Pack_Id)
27007 -- All other cases require Part_Of
27011 ("indicator Part_Of is required in this context "
27012 & "(SPARK RM 7.2.6(2))", Item_Id);
27013 Error_Msg_Name_1 := Chars (Pack_Id);
27015 ("\& is declared in the private part of package %", Item_Id);
27018 end Check_Missing_Part_Of;
27020 ---------------------------------------------------
27021 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27022 ---------------------------------------------------
27024 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27026 Spec_Id : Entity_Id)
27029 if Warn_On_Redundant_Constructs
27030 and then Has_Pragma_Inline_Always (Spec_Id)
27032 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27034 if From_Aspect_Specification (Prag) then
27036 ("aspect % not enforced on inlined subprogram &?r?",
27037 Corresponding_Aspect (Prag), Spec_Id);
27040 ("pragma % not enforced on inlined subprogram &?r?",
27044 end Check_Postcondition_Use_In_Inlined_Subprogram;
27046 -------------------------------------
27047 -- Check_State_And_Constituent_Use --
27048 -------------------------------------
27050 procedure Check_State_And_Constituent_Use
27051 (States : Elist_Id;
27052 Constits : Elist_Id;
27055 function Find_Encapsulating_State
27056 (Constit_Id : Entity_Id) return Entity_Id;
27057 -- Given the entity of a constituent, try to find a corresponding
27058 -- encapsulating state that appears in the same context. The routine
27059 -- returns Empty is no such state is found.
27061 ------------------------------
27062 -- Find_Encapsulating_State --
27063 ------------------------------
27065 function Find_Encapsulating_State
27066 (Constit_Id : Entity_Id) return Entity_Id
27068 State_Id : Entity_Id;
27071 -- Since a constituent may be part of a larger constituent set, climb
27072 -- the encapsulating state chain looking for a state that appears in
27073 -- the same context.
27075 State_Id := Encapsulating_State (Constit_Id);
27076 while Present (State_Id) loop
27077 if Contains (States, State_Id) then
27081 State_Id := Encapsulating_State (State_Id);
27085 end Find_Encapsulating_State;
27089 Constit_Elmt : Elmt_Id;
27090 Constit_Id : Entity_Id;
27091 State_Id : Entity_Id;
27093 -- Start of processing for Check_State_And_Constituent_Use
27096 -- Nothing to do if there are no states or constituents
27098 if No (States) or else No (Constits) then
27102 -- Inspect the list of constituents and try to determine whether its
27103 -- encapsulating state is in list States.
27105 Constit_Elmt := First_Elmt (Constits);
27106 while Present (Constit_Elmt) loop
27107 Constit_Id := Node (Constit_Elmt);
27109 -- Determine whether the constituent is part of an encapsulating
27110 -- state that appears in the same context and if this is the case,
27111 -- emit an error (SPARK RM 7.2.6(7)).
27113 State_Id := Find_Encapsulating_State (Constit_Id);
27115 if Present (State_Id) then
27116 Error_Msg_Name_1 := Chars (Constit_Id);
27118 ("cannot mention state & and its constituent % in the same "
27119 & "context", Context, State_Id);
27123 Next_Elmt (Constit_Elmt);
27125 end Check_State_And_Constituent_Use;
27127 ---------------------------------------------
27128 -- Collect_Inherited_Class_Wide_Conditions --
27129 ---------------------------------------------
27131 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27132 Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
27133 Prags : constant Node_Id := Contract (Parent_Subp);
27134 In_Spec_Expr : Boolean;
27135 Installed : Boolean;
27137 New_Prag : Node_Id;
27140 Installed := False;
27142 -- Iterate over the contract of the overridden subprogram to find all
27143 -- inherited class-wide pre- and postconditions.
27145 if Present (Prags) then
27146 Prag := Pre_Post_Conditions (Prags);
27148 while Present (Prag) loop
27149 if Nam_In (Pragma_Name (Prag), Name_Precondition,
27150 Name_Postcondition)
27151 and then Class_Present (Prag)
27153 -- The generated pragma must be analyzed in the context of
27154 -- the subprogram, to make its formals visible. In addition,
27155 -- we must inhibit freezing and full analysis because the
27156 -- controlling type of the subprogram is not frozen yet, and
27157 -- may have further primitives.
27159 if not Installed then
27162 Install_Formals (Subp);
27163 In_Spec_Expr := In_Spec_Expression;
27164 In_Spec_Expression := True;
27168 Build_Pragma_Check_Equivalent
27169 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
27171 Insert_After (Unit_Declaration_Node (Subp), New_Prag);
27172 Preanalyze (New_Prag);
27174 -- Prevent further analysis in subsequent processing of the
27175 -- current list of declarations
27177 Set_Analyzed (New_Prag);
27180 Prag := Next_Pragma (Prag);
27184 In_Spec_Expression := In_Spec_Expr;
27188 end Collect_Inherited_Class_Wide_Conditions;
27190 ---------------------------------------
27191 -- Collect_Subprogram_Inputs_Outputs --
27192 ---------------------------------------
27194 procedure Collect_Subprogram_Inputs_Outputs
27195 (Subp_Id : Entity_Id;
27196 Synthesize : Boolean := False;
27197 Subp_Inputs : in out Elist_Id;
27198 Subp_Outputs : in out Elist_Id;
27199 Global_Seen : out Boolean)
27201 procedure Collect_Dependency_Clause (Clause : Node_Id);
27202 -- Collect all relevant items from a dependency clause
27204 procedure Collect_Global_List
27206 Mode : Name_Id := Name_Input);
27207 -- Collect all relevant items from a global list
27209 -------------------------------
27210 -- Collect_Dependency_Clause --
27211 -------------------------------
27213 procedure Collect_Dependency_Clause (Clause : Node_Id) is
27214 procedure Collect_Dependency_Item
27216 Is_Input : Boolean);
27217 -- Add an item to the proper subprogram input or output collection
27219 -----------------------------
27220 -- Collect_Dependency_Item --
27221 -----------------------------
27223 procedure Collect_Dependency_Item
27225 Is_Input : Boolean)
27230 -- Nothing to collect when the item is null
27232 if Nkind (Item) = N_Null then
27235 -- Ditto for attribute 'Result
27237 elsif Is_Attribute_Result (Item) then
27240 -- Multiple items appear as an aggregate
27242 elsif Nkind (Item) = N_Aggregate then
27243 Extra := First (Expressions (Item));
27244 while Present (Extra) loop
27245 Collect_Dependency_Item (Extra, Is_Input);
27249 -- Otherwise this is a solitary item
27253 Append_New_Elmt (Item, Subp_Inputs);
27255 Append_New_Elmt (Item, Subp_Outputs);
27258 end Collect_Dependency_Item;
27260 -- Start of processing for Collect_Dependency_Clause
27263 if Nkind (Clause) = N_Null then
27266 -- A dependency cause appears as component association
27268 elsif Nkind (Clause) = N_Component_Association then
27269 Collect_Dependency_Item
27270 (Item => Expression (Clause),
27273 Collect_Dependency_Item
27274 (Item => First (Choices (Clause)),
27275 Is_Input => False);
27277 -- To accomodate partial decoration of disabled SPARK features, this
27278 -- routine may be called with illegal input. If this is the case, do
27279 -- not raise Program_Error.
27284 end Collect_Dependency_Clause;
27286 -------------------------
27287 -- Collect_Global_List --
27288 -------------------------
27290 procedure Collect_Global_List
27292 Mode : Name_Id := Name_Input)
27294 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
27295 -- Add an item to the proper subprogram input or output collection
27297 -------------------------
27298 -- Collect_Global_Item --
27299 -------------------------
27301 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
27303 if Nam_In (Mode, Name_In_Out, Name_Input) then
27304 Append_New_Elmt (Item, Subp_Inputs);
27307 if Nam_In (Mode, Name_In_Out, Name_Output) then
27308 Append_New_Elmt (Item, Subp_Outputs);
27310 end Collect_Global_Item;
27317 -- Start of processing for Collect_Global_List
27320 if Nkind (List) = N_Null then
27323 -- Single global item declaration
27325 elsif Nkind_In (List, N_Expanded_Name,
27327 N_Selected_Component)
27329 Collect_Global_Item (List, Mode);
27331 -- Simple global list or moded global list declaration
27333 elsif Nkind (List) = N_Aggregate then
27334 if Present (Expressions (List)) then
27335 Item := First (Expressions (List));
27336 while Present (Item) loop
27337 Collect_Global_Item (Item, Mode);
27342 Assoc := First (Component_Associations (List));
27343 while Present (Assoc) loop
27344 Collect_Global_List
27345 (List => Expression (Assoc),
27346 Mode => Chars (First (Choices (Assoc))));
27351 -- To accomodate partial decoration of disabled SPARK features, this
27352 -- routine may be called with illegal input. If this is the case, do
27353 -- not raise Program_Error.
27358 end Collect_Global_List;
27365 Formal : Entity_Id;
27367 Spec_Id : Entity_Id;
27368 Subp_Decl : Node_Id;
27371 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27374 Global_Seen := False;
27376 -- Process all formal parameters of entries, [generic] subprograms, and
27379 if Ekind_In (Subp_Id, E_Entry,
27382 E_Generic_Function,
27383 E_Generic_Procedure,
27387 Subp_Decl := Unit_Declaration_Node (Subp_Id);
27388 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27390 -- Process all [generic] formal parameters
27392 Formal := First_Entity (Spec_Id);
27393 while Present (Formal) loop
27394 if Ekind_In (Formal, E_Generic_In_Parameter,
27395 E_In_Out_Parameter,
27398 Append_New_Elmt (Formal, Subp_Inputs);
27401 if Ekind_In (Formal, E_Generic_In_Out_Parameter,
27402 E_In_Out_Parameter,
27405 Append_New_Elmt (Formal, Subp_Outputs);
27407 -- Out parameters can act as inputs when the related type is
27408 -- tagged, unconstrained array, unconstrained record, or record
27409 -- with unconstrained components.
27411 if Ekind (Formal) = E_Out_Parameter
27412 and then Is_Unconstrained_Or_Tagged_Item (Formal)
27414 Append_New_Elmt (Formal, Subp_Inputs);
27418 Next_Entity (Formal);
27421 -- Otherwise the input denotes a task type, a task body, or the
27422 -- anonymous object created for a single task type.
27424 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
27425 or else Is_Single_Task_Object (Subp_Id)
27427 Subp_Decl := Declaration_Node (Subp_Id);
27428 Spec_Id := Unique_Defining_Entity (Subp_Decl);
27431 -- When processing an entry, subprogram or task body, look for pragmas
27432 -- Refined_Depends and Refined_Global as they specify the inputs and
27435 if Is_Entry_Body (Subp_Id)
27436 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
27438 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
27439 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global);
27441 -- Subprogram declaration or stand alone body case, look for pragmas
27442 -- Depends and Global
27445 Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27446 Global := Get_Pragma (Spec_Id, Pragma_Global);
27449 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27450 -- because it provides finer granularity of inputs and outputs.
27452 if Present (Global) then
27453 Global_Seen := True;
27454 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
27456 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27457 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27458 -- the inputs and outputs from [Refined_]Depends.
27460 elsif Synthesize and then Present (Depends) then
27461 Clauses := Expression (Get_Argument (Depends, Spec_Id));
27463 -- Multiple dependency clauses appear as an aggregate
27465 if Nkind (Clauses) = N_Aggregate then
27466 Clause := First (Component_Associations (Clauses));
27467 while Present (Clause) loop
27468 Collect_Dependency_Clause (Clause);
27472 -- Otherwise this is a single dependency clause
27475 Collect_Dependency_Clause (Clauses);
27479 -- The current instance of a protected type acts as a formal parameter
27480 -- of mode IN for functions and IN OUT for entries and procedures
27481 -- (SPARK RM 6.1.4).
27483 if Ekind (Scope (Spec_Id)) = E_Protected_Type then
27484 Typ := Scope (Spec_Id);
27486 -- Use the anonymous object when the type is single protected
27488 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27489 Typ := Anonymous_Object (Typ);
27492 Append_New_Elmt (Typ, Subp_Inputs);
27494 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
27495 Append_New_Elmt (Typ, Subp_Outputs);
27498 -- The current instance of a task type acts as a formal parameter of
27499 -- mode IN OUT (SPARK RM 6.1.4).
27501 elsif Ekind (Spec_Id) = E_Task_Type then
27504 -- Use the anonymous object when the type is single task
27506 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27507 Typ := Anonymous_Object (Typ);
27510 Append_New_Elmt (Typ, Subp_Inputs);
27511 Append_New_Elmt (Typ, Subp_Outputs);
27513 elsif Is_Single_Task_Object (Spec_Id) then
27514 Append_New_Elmt (Spec_Id, Subp_Inputs);
27515 Append_New_Elmt (Spec_Id, Subp_Outputs);
27517 end Collect_Subprogram_Inputs_Outputs;
27519 ---------------------------
27520 -- Contract_Freeze_Error --
27521 ---------------------------
27523 procedure Contract_Freeze_Error
27524 (Contract_Id : Entity_Id;
27525 Freeze_Id : Entity_Id)
27528 Error_Msg_Name_1 := Chars (Contract_Id);
27529 Error_Msg_Sloc := Sloc (Freeze_Id);
27532 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
27534 ("\all contractual items must be declared before body #", Contract_Id);
27535 end Contract_Freeze_Error;
27537 ---------------------------------
27538 -- Delay_Config_Pragma_Analyze --
27539 ---------------------------------
27541 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
27543 return Nam_In (Pragma_Name (N), Name_Interrupt_State,
27544 Name_Priority_Specific_Dispatching);
27545 end Delay_Config_Pragma_Analyze;
27547 -----------------------
27548 -- Duplication_Error --
27549 -----------------------
27551 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
27552 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
27553 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
27556 Error_Msg_Sloc := Sloc (Prev);
27557 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27559 -- Emit a precise message to distinguish between source pragmas and
27560 -- pragmas generated from aspects. The ordering of the two pragmas is
27564 -- Prag -- duplicate
27566 -- No error is emitted when both pragmas come from aspects because this
27567 -- is already detected by the general aspect analysis mechanism.
27569 if Prag_From_Asp and Prev_From_Asp then
27571 elsif Prag_From_Asp then
27572 Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
27573 elsif Prev_From_Asp then
27574 Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
27576 Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
27578 end Duplication_Error;
27580 --------------------------
27581 -- Find_Related_Context --
27582 --------------------------
27584 function Find_Related_Context
27586 Do_Checks : Boolean := False) return Node_Id
27591 Stmt := Prev (Prag);
27592 while Present (Stmt) loop
27594 -- Skip prior pragmas, but check for duplicates
27596 if Nkind (Stmt) = N_Pragma then
27597 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
27603 -- Skip internally generated code
27605 elsif not Comes_From_Source (Stmt) then
27607 -- The anonymous object created for a single concurrent type is a
27608 -- suitable context.
27610 if Nkind (Stmt) = N_Object_Declaration
27611 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27616 -- Return the current source construct
27626 end Find_Related_Context;
27628 --------------------------------------
27629 -- Find_Related_Declaration_Or_Body --
27630 --------------------------------------
27632 function Find_Related_Declaration_Or_Body
27634 Do_Checks : Boolean := False) return Node_Id
27636 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
27638 procedure Expression_Function_Error;
27639 -- Emit an error concerning pragma Prag that illegaly applies to an
27640 -- expression function.
27642 -------------------------------
27643 -- Expression_Function_Error --
27644 -------------------------------
27646 procedure Expression_Function_Error is
27648 Error_Msg_Name_1 := Prag_Nam;
27650 -- Emit a precise message to distinguish between source pragmas and
27651 -- pragmas generated from aspects.
27653 if From_Aspect_Specification (Prag) then
27655 ("aspect % cannot apply to a stand alone expression function",
27659 ("pragma % cannot apply to a stand alone expression function",
27662 end Expression_Function_Error;
27666 Context : constant Node_Id := Parent (Prag);
27669 Look_For_Body : constant Boolean :=
27670 Nam_In (Prag_Nam, Name_Refined_Depends,
27671 Name_Refined_Global,
27672 Name_Refined_Post);
27673 -- Refinement pragmas must be associated with a subprogram body [stub]
27675 -- Start of processing for Find_Related_Declaration_Or_Body
27678 Stmt := Prev (Prag);
27679 while Present (Stmt) loop
27681 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27682 -- by splitting a complex pre/postcondition are not considered to
27685 if Nkind (Stmt) = N_Pragma then
27687 and then not Split_PPC (Stmt)
27688 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
27695 -- Emit an error when a refinement pragma appears on an expression
27696 -- function without a completion.
27699 and then Look_For_Body
27700 and then Nkind (Stmt) = N_Subprogram_Declaration
27701 and then Nkind (Original_Node (Stmt)) = N_Expression_Function
27702 and then not Has_Completion (Defining_Entity (Stmt))
27704 Expression_Function_Error;
27707 -- The refinement pragma applies to a subprogram body stub
27709 elsif Look_For_Body
27710 and then Nkind (Stmt) = N_Subprogram_Body_Stub
27714 -- Skip internally generated code
27716 elsif not Comes_From_Source (Stmt) then
27718 -- The anonymous object created for a single concurrent type is a
27719 -- suitable context.
27721 if Nkind (Stmt) = N_Object_Declaration
27722 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27726 elsif Nkind (Stmt) = N_Subprogram_Declaration then
27728 -- The subprogram declaration is an internally generated spec
27729 -- for an expression function.
27731 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27734 -- The subprogram is actually an instance housed within an
27735 -- anonymous wrapper package.
27737 elsif Present (Generic_Parent (Specification (Stmt))) then
27742 -- Return the current construct which is either a subprogram body,
27743 -- a subprogram declaration or is illegal.
27752 -- If we fall through, then the pragma was either the first declaration
27753 -- or it was preceded by other pragmas and no source constructs.
27755 -- The pragma is associated with a library-level subprogram
27757 if Nkind (Context) = N_Compilation_Unit_Aux then
27758 return Unit (Parent (Context));
27760 -- The pragma appears inside the declarations of an entry body
27762 elsif Nkind (Context) = N_Entry_Body then
27765 -- The pragma appears inside the statements of a subprogram body. This
27766 -- placement is the result of subprogram contract expansion.
27768 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
27769 return Parent (Context);
27771 -- The pragma appears inside the declarative part of a subprogram body
27773 elsif Nkind (Context) = N_Subprogram_Body then
27776 -- The pragma appears inside the declarative part of a task body
27778 elsif Nkind (Context) = N_Task_Body then
27781 -- The pragma is a byproduct of aspect expansion, return the related
27782 -- context of the original aspect. This case has a lower priority as
27783 -- the above circuitry pinpoints precisely the related context.
27785 elsif Present (Corresponding_Aspect (Prag)) then
27786 return Parent (Corresponding_Aspect (Prag));
27788 -- No candidate subprogram [body] found
27793 end Find_Related_Declaration_Or_Body;
27795 ----------------------------------
27796 -- Find_Related_Package_Or_Body --
27797 ----------------------------------
27799 function Find_Related_Package_Or_Body
27801 Do_Checks : Boolean := False) return Node_Id
27803 Context : constant Node_Id := Parent (Prag);
27804 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27808 Stmt := Prev (Prag);
27809 while Present (Stmt) loop
27811 -- Skip prior pragmas, but check for duplicates
27813 if Nkind (Stmt) = N_Pragma then
27814 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
27820 -- Skip internally generated code
27822 elsif not Comes_From_Source (Stmt) then
27823 if Nkind (Stmt) = N_Subprogram_Declaration then
27825 -- The subprogram declaration is an internally generated spec
27826 -- for an expression function.
27828 if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27831 -- The subprogram is actually an instance housed within an
27832 -- anonymous wrapper package.
27834 elsif Present (Generic_Parent (Specification (Stmt))) then
27839 -- Return the current source construct which is illegal
27848 -- If we fall through, then the pragma was either the first declaration
27849 -- or it was preceded by other pragmas and no source constructs.
27851 -- The pragma is associated with a package. The immediate context in
27852 -- this case is the specification of the package.
27854 if Nkind (Context) = N_Package_Specification then
27855 return Parent (Context);
27857 -- The pragma appears in the declarations of a package body
27859 elsif Nkind (Context) = N_Package_Body then
27862 -- The pragma appears in the statements of a package body
27864 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
27865 and then Nkind (Parent (Context)) = N_Package_Body
27867 return Parent (Context);
27869 -- The pragma is a byproduct of aspect expansion, return the related
27870 -- context of the original aspect. This case has a lower priority as
27871 -- the above circuitry pinpoints precisely the related context.
27873 elsif Present (Corresponding_Aspect (Prag)) then
27874 return Parent (Corresponding_Aspect (Prag));
27876 -- No candidate packge [body] found
27881 end Find_Related_Package_Or_Body;
27887 function Get_Argument
27889 Context_Id : Entity_Id := Empty) return Node_Id
27891 Args : constant List_Id := Pragma_Argument_Associations (Prag);
27894 -- Use the expression of the original aspect when compiling for ASIS or
27895 -- when analyzing the template of a generic unit. In both cases the
27896 -- aspect's tree must be decorated to allow for ASIS queries or to save
27897 -- the global references in the generic context.
27899 if From_Aspect_Specification (Prag)
27900 and then (ASIS_Mode or else (Present (Context_Id)
27901 and then Is_Generic_Unit (Context_Id)))
27903 return Corresponding_Aspect (Prag);
27905 -- Otherwise use the expression of the pragma
27907 elsif Present (Args) then
27908 return First (Args);
27915 -------------------------
27916 -- Get_Base_Subprogram --
27917 -------------------------
27919 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27920 Result : Entity_Id;
27923 -- Follow subprogram renaming chain
27927 if Is_Subprogram (Result)
27929 Nkind (Parent (Declaration_Node (Result))) =
27930 N_Subprogram_Renaming_Declaration
27931 and then Present (Alias (Result))
27933 Result := Alias (Result);
27937 end Get_Base_Subprogram;
27939 -----------------------
27940 -- Get_SPARK_Mode_Type --
27941 -----------------------
27943 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27945 if N = Name_On then
27947 elsif N = Name_Off then
27950 -- Any other argument is illegal
27953 raise Program_Error;
27955 end Get_SPARK_Mode_Type;
27957 ------------------------------------
27958 -- Get_SPARK_Mode_From_Annotation --
27959 ------------------------------------
27961 function Get_SPARK_Mode_From_Annotation
27962 (N : Node_Id) return SPARK_Mode_Type
27967 if Nkind (N) = N_Aspect_Specification then
27968 Mode := Expression (N);
27970 else pragma Assert (Nkind (N) = N_Pragma);
27971 Mode := First (Pragma_Argument_Associations (N));
27973 if Present (Mode) then
27974 Mode := Get_Pragma_Arg (Mode);
27978 -- Aspect or pragma SPARK_Mode specifies an explicit mode
27980 if Present (Mode) then
27981 if Nkind (Mode) = N_Identifier then
27982 return Get_SPARK_Mode_Type (Chars (Mode));
27984 -- In case of a malformed aspect or pragma, return the default None
27990 -- Otherwise the lack of an expression defaults SPARK_Mode to On
27995 end Get_SPARK_Mode_From_Annotation;
27997 ---------------------------
27998 -- Has_Extra_Parentheses --
27999 ---------------------------
28001 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28005 -- The aggregate should not have an expression list because a clause
28006 -- is always interpreted as a component association. The only way an
28007 -- expression list can sneak in is by adding extra parentheses around
28008 -- the individual clauses:
28010 -- Depends (Output => Input) -- proper form
28011 -- Depends ((Output => Input)) -- extra parentheses
28013 -- Since the extra parentheses are not allowed by the syntax of the
28014 -- pragma, flag them now to avoid emitting misleading errors down the
28017 if Nkind (Clause) = N_Aggregate
28018 and then Present (Expressions (Clause))
28020 Expr := First (Expressions (Clause));
28021 while Present (Expr) loop
28023 -- A dependency clause surrounded by extra parentheses appears
28024 -- as an aggregate of component associations with an optional
28025 -- Paren_Count set.
28027 if Nkind (Expr) = N_Aggregate
28028 and then Present (Component_Associations (Expr))
28031 ("dependency clause contains extra parentheses", Expr);
28033 -- Otherwise the expression is a malformed construct
28036 SPARK_Msg_N ("malformed dependency clause", Expr);
28046 end Has_Extra_Parentheses;
28052 procedure Initialize is
28063 Dummy := Dummy + 1;
28066 -----------------------------
28067 -- Is_Config_Static_String --
28068 -----------------------------
28070 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28072 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28073 -- This is an internal recursive function that is just like the outer
28074 -- function except that it adds the string to the name buffer rather
28075 -- than placing the string in the name buffer.
28077 ------------------------------
28078 -- Add_Config_Static_String --
28079 ------------------------------
28081 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28088 if Nkind (N) = N_Op_Concat then
28089 if Add_Config_Static_String (Left_Opnd (N)) then
28090 N := Right_Opnd (N);
28096 if Nkind (N) /= N_String_Literal then
28097 Error_Msg_N ("string literal expected for pragma argument", N);
28101 for J in 1 .. String_Length (Strval (N)) loop
28102 C := Get_String_Char (Strval (N), J);
28104 if not In_Character_Range (C) then
28106 ("string literal contains invalid wide character",
28107 Sloc (N) + 1 + Source_Ptr (J));
28111 Add_Char_To_Name_Buffer (Get_Character (C));
28116 end Add_Config_Static_String;
28118 -- Start of processing for Is_Config_Static_String
28123 return Add_Config_Static_String (Arg);
28124 end Is_Config_Static_String;
28126 ---------------------
28127 -- Is_CCT_Instance --
28128 ---------------------
28130 function Is_CCT_Instance
28131 (Ref_Id : Entity_Id;
28132 Context_Id : Entity_Id) return Boolean
28138 -- When the reference denotes a single protected type, the context is
28139 -- either a protected subprogram or its body.
28141 if Is_Single_Protected_Object (Ref_Id) then
28142 Typ := Scope (Context_Id);
28145 Ekind (Typ) = E_Protected_Type
28146 and then Present (Anonymous_Object (Typ))
28147 and then Anonymous_Object (Typ) = Ref_Id;
28149 -- When the reference denotes a single task type, the context is either
28150 -- the same type or if inside the body, the anonymous task type.
28152 elsif Is_Single_Task_Object (Ref_Id) then
28153 if Ekind (Context_Id) = E_Task_Type then
28155 Present (Anonymous_Object (Context_Id))
28156 and then Anonymous_Object (Context_Id) = Ref_Id;
28158 return Ref_Id = Context_Id;
28161 -- Otherwise the reference denotes a protected or a task type. Climb the
28162 -- scope chain looking for an enclosing concurrent type that matches the
28163 -- referenced entity.
28166 pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
28168 S := Current_Scope;
28169 while Present (S) and then S /= Standard_Standard loop
28170 if Ekind_In (S, E_Protected_Type, E_Task_Type)
28171 and then S = Ref_Id
28181 end Is_CCT_Instance;
28183 -------------------------------
28184 -- Is_Elaboration_SPARK_Mode --
28185 -------------------------------
28187 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
28190 (Nkind (N) = N_Pragma
28191 and then Pragma_Name (N) = Name_SPARK_Mode
28192 and then Is_List_Member (N));
28194 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28195 -- appears in the statement part of the body.
28198 Present (Parent (N))
28199 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
28200 and then List_Containing (N) = Statements (Parent (N))
28201 and then Present (Parent (Parent (N)))
28202 and then Nkind (Parent (Parent (N))) = N_Package_Body;
28203 end Is_Elaboration_SPARK_Mode;
28205 -----------------------
28206 -- Is_Enabled_Pragma --
28207 -----------------------
28209 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
28213 if Present (Prag) then
28214 Arg := First (Pragma_Argument_Associations (Prag));
28216 if Present (Arg) then
28217 return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
28219 -- The lack of a Boolean argument automatically enables the pragma
28225 -- The pragma is missing, therefore it is not enabled
28230 end Is_Enabled_Pragma;
28232 -----------------------------------------
28233 -- Is_Non_Significant_Pragma_Reference --
28234 -----------------------------------------
28236 -- This function makes use of the following static table which indicates
28237 -- whether appearance of some name in a given pragma is to be considered
28238 -- as a reference for the purposes of warnings about unreferenced objects.
28240 -- -1 indicates that appearence in any argument is significant
28241 -- 0 indicates that appearance in any argument is not significant
28242 -- +n indicates that appearance as argument n is significant, but all
28243 -- other arguments are not significant
28244 -- 9n arguments from n on are significant, before n insignificant
28246 Sig_Flags : constant array (Pragma_Id) of Int :=
28247 (Pragma_Abort_Defer => -1,
28248 Pragma_Abstract_State => -1,
28249 Pragma_Ada_83 => -1,
28250 Pragma_Ada_95 => -1,
28251 Pragma_Ada_05 => -1,
28252 Pragma_Ada_2005 => -1,
28253 Pragma_Ada_12 => -1,
28254 Pragma_Ada_2012 => -1,
28255 Pragma_All_Calls_Remote => -1,
28256 Pragma_Allow_Integer_Address => -1,
28257 Pragma_Annotate => 93,
28258 Pragma_Assert => -1,
28259 Pragma_Assert_And_Cut => -1,
28260 Pragma_Assertion_Policy => 0,
28261 Pragma_Assume => -1,
28262 Pragma_Assume_No_Invalid_Values => 0,
28263 Pragma_Async_Readers => 0,
28264 Pragma_Async_Writers => 0,
28265 Pragma_Asynchronous => 0,
28266 Pragma_Atomic => 0,
28267 Pragma_Atomic_Components => 0,
28268 Pragma_Attach_Handler => -1,
28269 Pragma_Attribute_Definition => 92,
28270 Pragma_Check => -1,
28271 Pragma_Check_Float_Overflow => 0,
28272 Pragma_Check_Name => 0,
28273 Pragma_Check_Policy => 0,
28274 Pragma_CPP_Class => 0,
28275 Pragma_CPP_Constructor => 0,
28276 Pragma_CPP_Virtual => 0,
28277 Pragma_CPP_Vtable => 0,
28279 Pragma_C_Pass_By_Copy => 0,
28280 Pragma_Comment => -1,
28281 Pragma_Common_Object => 0,
28282 Pragma_Compile_Time_Error => -1,
28283 Pragma_Compile_Time_Warning => -1,
28284 Pragma_Compiler_Unit => -1,
28285 Pragma_Compiler_Unit_Warning => -1,
28286 Pragma_Complete_Representation => 0,
28287 Pragma_Complex_Representation => 0,
28288 Pragma_Component_Alignment => 0,
28289 Pragma_Constant_After_Elaboration => 0,
28290 Pragma_Contract_Cases => -1,
28291 Pragma_Controlled => 0,
28292 Pragma_Convention => 0,
28293 Pragma_Convention_Identifier => 0,
28294 Pragma_Debug => -1,
28295 Pragma_Debug_Policy => 0,
28296 Pragma_Detect_Blocking => 0,
28297 Pragma_Default_Initial_Condition => -1,
28298 Pragma_Default_Scalar_Storage_Order => 0,
28299 Pragma_Default_Storage_Pool => 0,
28300 Pragma_Depends => -1,
28301 Pragma_Disable_Atomic_Synchronization => 0,
28302 Pragma_Discard_Names => 0,
28303 Pragma_Dispatching_Domain => -1,
28304 Pragma_Effective_Reads => 0,
28305 Pragma_Effective_Writes => 0,
28306 Pragma_Elaborate => 0,
28307 Pragma_Elaborate_All => 0,
28308 Pragma_Elaborate_Body => 0,
28309 Pragma_Elaboration_Checks => 0,
28310 Pragma_Eliminate => 0,
28311 Pragma_Enable_Atomic_Synchronization => 0,
28312 Pragma_Export => -1,
28313 Pragma_Export_Function => -1,
28314 Pragma_Export_Object => -1,
28315 Pragma_Export_Procedure => -1,
28316 Pragma_Export_Value => -1,
28317 Pragma_Export_Valued_Procedure => -1,
28318 Pragma_Extend_System => -1,
28319 Pragma_Extensions_Allowed => 0,
28320 Pragma_Extensions_Visible => 0,
28321 Pragma_External => -1,
28322 Pragma_Favor_Top_Level => 0,
28323 Pragma_External_Name_Casing => 0,
28324 Pragma_Fast_Math => 0,
28325 Pragma_Finalize_Storage_Only => 0,
28327 Pragma_Global => -1,
28328 Pragma_Ident => -1,
28329 Pragma_Ignore_Pragma => 0,
28330 Pragma_Implementation_Defined => -1,
28331 Pragma_Implemented => -1,
28332 Pragma_Implicit_Packing => 0,
28333 Pragma_Import => 93,
28334 Pragma_Import_Function => 0,
28335 Pragma_Import_Object => 0,
28336 Pragma_Import_Procedure => 0,
28337 Pragma_Import_Valued_Procedure => 0,
28338 Pragma_Independent => 0,
28339 Pragma_Independent_Components => 0,
28340 Pragma_Initial_Condition => -1,
28341 Pragma_Initialize_Scalars => 0,
28342 Pragma_Initializes => -1,
28343 Pragma_Inline => 0,
28344 Pragma_Inline_Always => 0,
28345 Pragma_Inline_Generic => 0,
28346 Pragma_Inspection_Point => -1,
28347 Pragma_Interface => 92,
28348 Pragma_Interface_Name => 0,
28349 Pragma_Interrupt_Handler => -1,
28350 Pragma_Interrupt_Priority => -1,
28351 Pragma_Interrupt_State => -1,
28352 Pragma_Invariant => -1,
28353 Pragma_Keep_Names => 0,
28354 Pragma_License => 0,
28355 Pragma_Link_With => -1,
28356 Pragma_Linker_Alias => -1,
28357 Pragma_Linker_Constructor => -1,
28358 Pragma_Linker_Destructor => -1,
28359 Pragma_Linker_Options => -1,
28360 Pragma_Linker_Section => 0,
28362 Pragma_Lock_Free => 0,
28363 Pragma_Locking_Policy => 0,
28364 Pragma_Loop_Invariant => -1,
28365 Pragma_Loop_Optimize => 0,
28366 Pragma_Loop_Variant => -1,
28367 Pragma_Machine_Attribute => -1,
28369 Pragma_Main_Storage => -1,
28370 Pragma_Memory_Size => 0,
28371 Pragma_No_Return => 0,
28372 Pragma_No_Body => 0,
28373 Pragma_No_Elaboration_Code_All => 0,
28374 Pragma_No_Inline => 0,
28375 Pragma_No_Run_Time => -1,
28376 Pragma_No_Strict_Aliasing => -1,
28377 Pragma_No_Tagged_Streams => 0,
28378 Pragma_Normalize_Scalars => 0,
28379 Pragma_Obsolescent => 0,
28380 Pragma_Optimize => 0,
28381 Pragma_Optimize_Alignment => 0,
28382 Pragma_Overflow_Mode => 0,
28383 Pragma_Overriding_Renamings => 0,
28384 Pragma_Ordered => 0,
28387 Pragma_Part_Of => 0,
28388 Pragma_Partition_Elaboration_Policy => 0,
28389 Pragma_Passive => 0,
28390 Pragma_Persistent_BSS => 0,
28391 Pragma_Polling => 0,
28392 Pragma_Prefix_Exception_Messages => 0,
28394 Pragma_Postcondition => -1,
28395 Pragma_Post_Class => -1,
28397 Pragma_Precondition => -1,
28398 Pragma_Predicate => -1,
28399 Pragma_Predicate_Failure => -1,
28400 Pragma_Preelaborable_Initialization => -1,
28401 Pragma_Preelaborate => 0,
28402 Pragma_Pre_Class => -1,
28403 Pragma_Priority => -1,
28404 Pragma_Priority_Specific_Dispatching => 0,
28405 Pragma_Profile => 0,
28406 Pragma_Profile_Warnings => 0,
28407 Pragma_Propagate_Exceptions => 0,
28408 Pragma_Provide_Shift_Operators => 0,
28409 Pragma_Psect_Object => 0,
28411 Pragma_Pure_Function => 0,
28412 Pragma_Queuing_Policy => 0,
28413 Pragma_Rational => 0,
28414 Pragma_Ravenscar => 0,
28415 Pragma_Refined_Depends => -1,
28416 Pragma_Refined_Global => -1,
28417 Pragma_Refined_Post => -1,
28418 Pragma_Refined_State => -1,
28419 Pragma_Relative_Deadline => 0,
28420 Pragma_Remote_Access_Type => -1,
28421 Pragma_Remote_Call_Interface => -1,
28422 Pragma_Remote_Types => -1,
28423 Pragma_Restricted_Run_Time => 0,
28424 Pragma_Restriction_Warnings => 0,
28425 Pragma_Restrictions => 0,
28426 Pragma_Reviewable => -1,
28427 Pragma_Short_Circuit_And_Or => 0,
28428 Pragma_Share_Generic => 0,
28429 Pragma_Shared => 0,
28430 Pragma_Shared_Passive => 0,
28431 Pragma_Short_Descriptors => 0,
28432 Pragma_Simple_Storage_Pool_Type => 0,
28433 Pragma_Source_File_Name => 0,
28434 Pragma_Source_File_Name_Project => 0,
28435 Pragma_Source_Reference => 0,
28436 Pragma_SPARK_Mode => 0,
28437 Pragma_Storage_Size => -1,
28438 Pragma_Storage_Unit => 0,
28439 Pragma_Static_Elaboration_Desired => 0,
28440 Pragma_Stream_Convert => 0,
28441 Pragma_Style_Checks => 0,
28442 Pragma_Subtitle => 0,
28443 Pragma_Suppress => 0,
28444 Pragma_Suppress_Exception_Locations => 0,
28445 Pragma_Suppress_All => 0,
28446 Pragma_Suppress_Debug_Info => 0,
28447 Pragma_Suppress_Initialization => 0,
28448 Pragma_System_Name => 0,
28449 Pragma_Task_Dispatching_Policy => 0,
28450 Pragma_Task_Info => -1,
28451 Pragma_Task_Name => -1,
28452 Pragma_Task_Storage => -1,
28453 Pragma_Test_Case => -1,
28454 Pragma_Thread_Local_Storage => -1,
28455 Pragma_Time_Slice => -1,
28457 Pragma_Type_Invariant => -1,
28458 Pragma_Type_Invariant_Class => -1,
28459 Pragma_Unchecked_Union => 0,
28460 Pragma_Unimplemented_Unit => 0,
28461 Pragma_Universal_Aliasing => 0,
28462 Pragma_Universal_Data => 0,
28463 Pragma_Unmodified => 0,
28464 Pragma_Unreferenced => 0,
28465 Pragma_Unreferenced_Objects => 0,
28466 Pragma_Unreserve_All_Interrupts => 0,
28467 Pragma_Unsuppress => 0,
28468 Pragma_Unevaluated_Use_Of_Old => 0,
28469 Pragma_Use_VADS_Size => 0,
28470 Pragma_Validity_Checks => 0,
28471 Pragma_Volatile => 0,
28472 Pragma_Volatile_Components => 0,
28473 Pragma_Volatile_Full_Access => 0,
28474 Pragma_Volatile_Function => 0,
28475 Pragma_Warning_As_Error => 0,
28476 Pragma_Warnings => 0,
28477 Pragma_Weak_External => 0,
28478 Pragma_Wide_Character_Encoding => 0,
28479 Unknown_Pragma => 0);
28481 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
28487 function Arg_No return Nat;
28488 -- Returns an integer showing what argument we are in. A value of
28489 -- zero means we are not in any of the arguments.
28495 function Arg_No return Nat is
28500 A := First (Pragma_Argument_Associations (Parent (P)));
28514 -- Start of processing for Non_Significant_Pragma_Reference
28519 if Nkind (P) /= N_Pragma_Argument_Association then
28523 Id := Get_Pragma_Id (Parent (P));
28524 C := Sig_Flags (Id);
28539 return AN < (C - 90);
28545 end Is_Non_Significant_Pragma_Reference;
28547 ------------------------------
28548 -- Is_Pragma_String_Literal --
28549 ------------------------------
28551 -- This function returns true if the corresponding pragma argument is a
28552 -- static string expression. These are the only cases in which string
28553 -- literals can appear as pragma arguments. We also allow a string literal
28554 -- as the first argument to pragma Assert (although it will of course
28555 -- always generate a type error).
28557 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
28558 Pragn : constant Node_Id := Parent (Par);
28559 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
28560 Pname : constant Name_Id := Pragma_Name (Pragn);
28566 N := First (Assoc);
28573 if Pname = Name_Assert then
28576 elsif Pname = Name_Export then
28579 elsif Pname = Name_Ident then
28582 elsif Pname = Name_Import then
28585 elsif Pname = Name_Interface_Name then
28588 elsif Pname = Name_Linker_Alias then
28591 elsif Pname = Name_Linker_Section then
28594 elsif Pname = Name_Machine_Attribute then
28597 elsif Pname = Name_Source_File_Name then
28600 elsif Pname = Name_Source_Reference then
28603 elsif Pname = Name_Title then
28606 elsif Pname = Name_Subtitle then
28612 end Is_Pragma_String_Literal;
28614 ---------------------------
28615 -- Is_Private_SPARK_Mode --
28616 ---------------------------
28618 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
28621 (Nkind (N) = N_Pragma
28622 and then Pragma_Name (N) = Name_SPARK_Mode
28623 and then Is_List_Member (N));
28625 -- For pragma SPARK_Mode to be private, it has to appear in the private
28626 -- declarations of a package.
28629 Present (Parent (N))
28630 and then Nkind (Parent (N)) = N_Package_Specification
28631 and then List_Containing (N) = Private_Declarations (Parent (N));
28632 end Is_Private_SPARK_Mode;
28634 -------------------------------------
28635 -- Is_Unconstrained_Or_Tagged_Item --
28636 -------------------------------------
28638 function Is_Unconstrained_Or_Tagged_Item
28639 (Item : Entity_Id) return Boolean
28641 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
28642 -- Determine whether record type Typ has at least one unconstrained
28645 ---------------------------------
28646 -- Has_Unconstrained_Component --
28647 ---------------------------------
28649 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
28653 Comp := First_Component (Typ);
28654 while Present (Comp) loop
28655 if Is_Unconstrained_Or_Tagged_Item (Comp) then
28659 Next_Component (Comp);
28663 end Has_Unconstrained_Component;
28667 Typ : constant Entity_Id := Etype (Item);
28669 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28672 if Is_Tagged_Type (Typ) then
28675 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
28678 elsif Is_Record_Type (Typ) then
28679 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
28682 return Has_Unconstrained_Component (Typ);
28685 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
28691 end Is_Unconstrained_Or_Tagged_Item;
28693 -----------------------------
28694 -- Is_Valid_Assertion_Kind --
28695 -----------------------------
28697 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
28704 Name_Assertion_Policy |
28705 Name_Static_Predicate |
28706 Name_Dynamic_Predicate |
28711 Name_Type_Invariant |
28712 Name_uType_Invariant |
28716 Name_Assert_And_Cut |
28718 Name_Contract_Cases |
28720 Name_Default_Initial_Condition |
28722 Name_Initial_Condition |
28725 Name_Loop_Invariant |
28726 Name_Loop_Variant |
28727 Name_Postcondition |
28728 Name_Precondition |
28730 Name_Refined_Post |
28731 Name_Statement_Assertions => return True;
28733 when others => return False;
28735 end Is_Valid_Assertion_Kind;
28737 --------------------------------------
28738 -- Process_Compilation_Unit_Pragmas --
28739 --------------------------------------
28741 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
28743 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28744 -- strange because it comes at the end of the unit. Rational has the
28745 -- same name for a pragma, but treats it as a program unit pragma, In
28746 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28747 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28748 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28749 -- the context clause to ensure the correct processing.
28751 if Has_Pragma_Suppress_All (N) then
28752 Prepend_To (Context_Items (N),
28753 Make_Pragma (Sloc (N),
28754 Chars => Name_Suppress,
28755 Pragma_Argument_Associations => New_List (
28756 Make_Pragma_Argument_Association (Sloc (N),
28757 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
28760 -- Nothing else to do at the current time
28762 end Process_Compilation_Unit_Pragmas;
28764 ------------------------------------
28765 -- Record_Possible_Body_Reference --
28766 ------------------------------------
28768 procedure Record_Possible_Body_Reference
28769 (State_Id : Entity_Id;
28773 Spec_Id : Entity_Id;
28776 -- Ensure that we are dealing with a reference to a state
28778 pragma Assert (Ekind (State_Id) = E_Abstract_State);
28780 -- Climb the tree starting from the reference looking for a package body
28781 -- whose spec declares the referenced state. This criteria automatically
28782 -- excludes references in package specs which are legal. Note that it is
28783 -- not wise to emit an error now as the package body may lack pragma
28784 -- Refined_State or the referenced state may not be mentioned in the
28785 -- refinement. This approach avoids the generation of misleading errors.
28788 while Present (Context) loop
28789 if Nkind (Context) = N_Package_Body then
28790 Spec_Id := Corresponding_Spec (Context);
28792 if Present (Abstract_States (Spec_Id))
28793 and then Contains (Abstract_States (Spec_Id), State_Id)
28795 if No (Body_References (State_Id)) then
28796 Set_Body_References (State_Id, New_Elmt_List);
28799 Append_Elmt (Ref, To => Body_References (State_Id));
28804 Context := Parent (Context);
28806 end Record_Possible_Body_Reference;
28808 ------------------------------------------
28809 -- Relocate_Pragmas_To_Anonymous_Object --
28810 ------------------------------------------
28812 procedure Relocate_Pragmas_To_Anonymous_Object
28813 (Typ_Decl : Node_Id;
28814 Obj_Decl : Node_Id)
28818 Next_Decl : Node_Id;
28821 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
28822 Def := Protected_Definition (Typ_Decl);
28824 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
28825 Def := Task_Definition (Typ_Decl);
28828 -- The concurrent definition has a visible declaration list. Inspect it
28829 -- and relocate all canidate pragmas.
28831 if Present (Def) and then Present (Visible_Declarations (Def)) then
28832 Decl := First (Visible_Declarations (Def));
28833 while Present (Decl) loop
28835 -- Preserve the following declaration for iteration purposes due
28836 -- to possible relocation of a pragma.
28838 Next_Decl := Next (Decl);
28840 if Nkind (Decl) = N_Pragma
28841 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
28844 Insert_After (Obj_Decl, Decl);
28846 -- Skip internally generated code
28848 elsif not Comes_From_Source (Decl) then
28851 -- No candidate pragmas are available for relocation
28860 end Relocate_Pragmas_To_Anonymous_Object;
28862 ------------------------------
28863 -- Relocate_Pragmas_To_Body --
28864 ------------------------------
28866 procedure Relocate_Pragmas_To_Body
28867 (Subp_Body : Node_Id;
28868 Target_Body : Node_Id := Empty)
28870 procedure Relocate_Pragma (Prag : Node_Id);
28871 -- Remove a single pragma from its current list and add it to the
28872 -- declarations of the proper body (either Subp_Body or Target_Body).
28874 ---------------------
28875 -- Relocate_Pragma --
28876 ---------------------
28878 procedure Relocate_Pragma (Prag : Node_Id) is
28883 -- When subprogram stubs or expression functions are involves, the
28884 -- destination declaration list belongs to the proper body.
28886 if Present (Target_Body) then
28887 Target := Target_Body;
28889 Target := Subp_Body;
28892 Decls := Declarations (Target);
28896 Set_Declarations (Target, Decls);
28899 -- Unhook the pragma from its current list
28902 Prepend (Prag, Decls);
28903 end Relocate_Pragma;
28907 Body_Id : constant Entity_Id :=
28908 Defining_Unit_Name (Specification (Subp_Body));
28909 Next_Stmt : Node_Id;
28912 -- Start of processing for Relocate_Pragmas_To_Body
28915 -- Do not process a body that comes from a separate unit as no construct
28916 -- can possibly follow it.
28918 if not Is_List_Member (Subp_Body) then
28921 -- Do not relocate pragmas that follow a stub if the stub does not have
28924 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
28925 and then No (Target_Body)
28929 -- Do not process internally generated routine _Postconditions
28931 elsif Ekind (Body_Id) = E_Procedure
28932 and then Chars (Body_Id) = Name_uPostconditions
28937 -- Look at what is following the body. We are interested in certain kind
28938 -- of pragmas (either from source or byproducts of expansion) that can
28939 -- apply to a body [stub].
28941 Stmt := Next (Subp_Body);
28942 while Present (Stmt) loop
28944 -- Preserve the following statement for iteration purposes due to a
28945 -- possible relocation of a pragma.
28947 Next_Stmt := Next (Stmt);
28949 -- Move a candidate pragma following the body to the declarations of
28952 if Nkind (Stmt) = N_Pragma
28953 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28955 Relocate_Pragma (Stmt);
28957 -- Skip internally generated code
28959 elsif not Comes_From_Source (Stmt) then
28962 -- No candidate pragmas are available for relocation
28970 end Relocate_Pragmas_To_Body;
28972 -------------------
28973 -- Resolve_State --
28974 -------------------
28976 procedure Resolve_State (N : Node_Id) is
28981 if Is_Entity_Name (N) and then Present (Entity (N)) then
28982 Func := Entity (N);
28984 -- Handle overloading of state names by functions. Traverse the
28985 -- homonym chain looking for an abstract state.
28987 if Ekind (Func) = E_Function and then Has_Homonym (Func) then
28988 State := Homonym (Func);
28989 while Present (State) loop
28991 -- Resolve the overloading by setting the proper entity of the
28992 -- reference to that of the state.
28994 if Ekind (State) = E_Abstract_State then
28995 Set_Etype (N, Standard_Void_Type);
28996 Set_Entity (N, State);
28997 Set_Associated_Node (N, State);
29001 State := Homonym (State);
29004 -- A function can never act as a state. If the homonym chain does
29005 -- not contain a corresponding state, then something went wrong in
29006 -- the overloading mechanism.
29008 raise Program_Error;
29013 ----------------------------
29014 -- Rewrite_Assertion_Kind --
29015 ----------------------------
29017 procedure Rewrite_Assertion_Kind (N : Node_Id) is
29021 if Nkind (N) = N_Attribute_Reference
29022 and then Attribute_Name (N) = Name_Class
29023 and then Nkind (Prefix (N)) = N_Identifier
29025 case Chars (Prefix (N)) is
29030 when Name_Type_Invariant =>
29031 Nam := Name_uType_Invariant;
29032 when Name_Invariant =>
29033 Nam := Name_uInvariant;
29038 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
29040 end Rewrite_Assertion_Kind;
29048 Dummy := Dummy + 1;
29051 --------------------------------
29052 -- Set_Encoded_Interface_Name --
29053 --------------------------------
29055 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
29056 Str : constant String_Id := Strval (S);
29057 Len : constant Nat := String_Length (Str);
29062 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
29065 -- Stores encoded value of character code CC. The encoding we use an
29066 -- underscore followed by four lower case hex digits.
29072 procedure Encode is
29074 Store_String_Char (Get_Char_Code ('_'));
29076 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
29078 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
29080 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
29082 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
29085 -- Start of processing for Set_Encoded_Interface_Name
29088 -- If first character is asterisk, this is a link name, and we leave it
29089 -- completely unmodified. We also ignore null strings (the latter case
29090 -- happens only in error cases).
29093 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
29095 Set_Interface_Name (E, S);
29100 CC := Get_String_Char (Str, J);
29102 exit when not In_Character_Range (CC);
29104 C := Get_Character (CC);
29106 exit when C /= '_' and then C /= '$'
29107 and then C not in '0' .. '9'
29108 and then C not in 'a' .. 'z'
29109 and then C not in 'A' .. 'Z';
29112 Set_Interface_Name (E, S);
29120 -- Here we need to encode. The encoding we use as follows:
29121 -- three underscores + four hex digits (lower case)
29125 for J in 1 .. String_Length (Str) loop
29126 CC := Get_String_Char (Str, J);
29128 if not In_Character_Range (CC) then
29131 C := Get_Character (CC);
29133 if C = '_' or else C = '$'
29134 or else C in '0' .. '9'
29135 or else C in 'a' .. 'z'
29136 or else C in 'A' .. 'Z'
29138 Store_String_Char (CC);
29145 Set_Interface_Name (E,
29146 Make_String_Literal (Sloc (S),
29147 Strval => End_String));
29149 end Set_Encoded_Interface_Name;
29151 ------------------------
29152 -- Set_Elab_Unit_Name --
29153 ------------------------
29155 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
29160 if Nkind (N) = N_Identifier
29161 and then Nkind (With_Item) = N_Identifier
29163 Set_Entity (N, Entity (With_Item));
29165 elsif Nkind (N) = N_Selected_Component then
29166 Change_Selected_Component_To_Expanded_Name (N);
29167 Set_Entity (N, Entity (With_Item));
29168 Set_Entity (Selector_Name (N), Entity (N));
29170 Pref := Prefix (N);
29171 Scop := Scope (Entity (N));
29172 while Nkind (Pref) = N_Selected_Component loop
29173 Change_Selected_Component_To_Expanded_Name (Pref);
29174 Set_Entity (Selector_Name (Pref), Scop);
29175 Set_Entity (Pref, Scop);
29176 Pref := Prefix (Pref);
29177 Scop := Scope (Scop);
29180 Set_Entity (Pref, Scop);
29183 Generate_Reference (Entity (With_Item), N, Set_Ref => False);
29184 end Set_Elab_Unit_Name;
29186 -------------------
29187 -- Test_Case_Arg --
29188 -------------------
29190 function Test_Case_Arg
29193 From_Aspect : Boolean := False) return Node_Id
29195 Aspect : constant Node_Id := Corresponding_Aspect (Prag);
29200 pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
29205 -- The caller requests the aspect argument
29207 if From_Aspect then
29208 if Present (Aspect)
29209 and then Nkind (Expression (Aspect)) = N_Aggregate
29211 Args := Expression (Aspect);
29213 -- "Name" and "Mode" may appear without an identifier as a
29214 -- positional association.
29216 if Present (Expressions (Args)) then
29217 Arg := First (Expressions (Args));
29219 if Present (Arg) and then Arg_Nam = Name_Name then
29227 if Present (Arg) and then Arg_Nam = Name_Mode then
29232 -- Some or all arguments may appear as component associatons
29234 if Present (Component_Associations (Args)) then
29235 Arg := First (Component_Associations (Args));
29236 while Present (Arg) loop
29237 if Chars (First (Choices (Arg))) = Arg_Nam then
29246 -- Otherwise retrieve the argument directly from the pragma
29249 Arg := First (Pragma_Argument_Associations (Prag));
29251 if Present (Arg) and then Arg_Nam = Name_Name then
29255 -- Skip argument "Name"
29259 if Present (Arg) and then Arg_Nam = Name_Mode then
29263 -- Skip argument "Mode"
29267 -- Arguments "Requires" and "Ensures" are optional and may not be
29270 while Present (Arg) loop
29271 if Chars (Arg) = Arg_Nam then